/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * error.d - error handling
 *
 * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
 * Copyright (c) 1990 Giuseppe Attardi
 * Copyright (c) 2001 Juan Jose Garcia Ripoll
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

#include <ecl/ecl.h>
#include <stdio.h>
#include <string.h>
#include <errno.h>
#include <signal.h>
#include <stdlib.h>
#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
# include <windows.h>
#endif
#include <ecl/internal.h>
#include <ecl/ecl-inl.h>

void
ecl_unrecoverable_error(cl_env_ptr the_env, const char *message)
{
  /* Right now we have no means of specifying a jump point for really bad
   * events. We just jump to the outermost frame, which is equivalent to
   * quitting, and wait for someone to intercept this jump. */
  ecl_frame_ptr destination;
  cl_object tag;

  /*
   * We output the error message with very low level routines
   * because we can not risk another stack overflow.
   */
  writestr_stream(message, cl_core.error_output);

  tag = ECL_SYM_VAL(the_env, @'si::*quit-tag*');
  the_env->nvalues = 0;
  if (tag) {
    destination = frs_sch(tag);
    if (destination) {
      ecl_unwind(the_env, destination);
    }
  }
  if (the_env->frs_stack.org <= the_env->frs_stack.top) {
    destination = ecl_process_env()->frs_stack.org;
    ecl_unwind(the_env, destination);
  } else {
    ecl_internal_error("\n;;;\n;;; No frame to jump to\n;;; Aborting ECL\n;;;");
  }
}

/* -- Integration with low-level exceptions */
cl_object
ecl_exception_handler(cl_object o)
{
  if (ECL_EXCEPTIONP(o)) {
    cl_object arg1 = o->exception.arg1;
    cl_object arg2 = o->exception.arg2;
    cl_object arg3 = o->exception.arg3;
    void *arg4 = o->exception.arg4;
    cl_object hand = @'si::universal-error-handler';
    switch (o->exception.ex_type) {
    /* General conditions */
    case ECL_EX_FERROR:
      ecl_enable_interrupts();
      return _ecl_funcall4(hand, ECL_NIL, arg1, arg2);
    case ECL_EX_CERROR:
      ecl_enable_interrupts();
      return _ecl_funcall4(hand, ECL_T, arg1, arg2);
      /* Specific conditions */
    case ECL_EX_BADARG:
      FEwrong_type_argument(arg1, arg2);
      break;
    case ECL_EX_BADARG_ONLY:
      FEwrong_type_only_arg(arg1, arg2, arg3);
      break;
    case ECL_EX_BADARG_NTH:
      FEwrong_type_nth_arg(arg1, (cl_narg)arg4, arg2, arg3);
      break;
    case ECL_EX_UNSATISFIED:
      FEwrong_type_pred_arg(arg1, arg2);
      break;
    case ECL_EX_STRM_BADELT:
      FEwrong_type_strm_elt(arg1, arg2);
      break;
    case ECL_EX_STRM_CLOSED:
      FEclosed_stream(arg1);
      break;
    case ECL_EX_STRM_UNREAD:
      FEunread_stream(arg1, arg2);
      break;
    case ECL_EX_READ_BADELT:
      FEreader_error("Found invalid character ~:C", arg1, 1, arg2);
     break;
    case ECL_EX_READ_VALUES:
      FEerror("The readmacro ~S returned ~D values.", 2, arg1, arg2);
      break;
    case ECL_EX_EOF:
      FEend_of_file(arg1);
      break;
    case ECL_EX_NIY:
      FEerror("The operation is not implemented yet.", 0);
      break;
    case ECL_EX_NAO:
      FEerror("The operation is not applicable to ~A.", 1, arg1);
      break;
    /* Stack conditions */
    case ECL_EX_CS_OVR:
      CEstack_overflow(@'ext::c-stack', arg1, arg2);
      break;
    case ECL_EX_FRS_OVR:
      CEstack_overflow(@'ext::frame-stack', arg1, arg2);
      break;
    case ECL_EX_BDS_OVR:
      CEstack_overflow(@'ext::binding-stack', arg1, arg2);
      break;
    /* KLUDGE ByteVM-specific conditions */
    case ECL_EX_VM_BADARG_EXCD:
      FEprogram_error("Too many arguments passed to function ~A~&"
                      "Argument list: ~S",
                      2, arg1, cl_apply(2, @'list', arg2));
      break;
    case ECL_EX_VM_BADARG_UNKK:
      FEprogram_error("Unknown keyword argument passed to function ~A.~&"
                      "Argument list: ~S",
                      2, arg1, cl_apply(2, @'list', arg2));
      break;
    case ECL_EX_VM_BADARG_ODDK:
      FEprogram_error("Odd number of keyword arguments passed to function ~A.~&"
                      "Argument list: ~S",
                      2, arg1, cl_apply(2, @'list', arg2));
      break;
    case ECL_EX_VM_BADARG_NTH_VAL:
      FEerror("Wrong index passed to NTH-VAL", 0);
      break;
    case ECL_EX_VM_BADARG_ENDP:
      FEwrong_type_only_arg(@[endp], arg1, @[list]);
      break;
    case ECL_EX_VM_BADARG_CAR:
      FEwrong_type_only_arg(@[car], arg1, @[list]);
      break;
    case ECL_EX_VM_BADARG_CDR:
      FEwrong_type_only_arg(@[cdr], arg1, @[list]);
      break;
    case ECL_EX_VM_BADARG_PROGV:
      FEerror("Wrong arguments to special form PROGV. Either~%"
              "~A~%or~%~A~%are not proper lists",
              2, arg1, arg2);
      break;
    /* Variable conditions */
    case ECL_EX_V_CSETQ:
      FEassignment_to_constant(arg1);
      break;
    case ECL_EX_V_CBIND:
      FEbinding_a_constant(arg1);
      break;
    case ECL_EX_V_UNBND:
      FEunbound_variable(arg1);
      break;
    case ECL_EX_V_BNAME:
      FEunbound_variable(arg1);
      break;
    /* Function conditions */
    case ECL_EX_F_NARGS:
      FEwrong_num_arguments(arg1);
      break;
    case ECL_EX_F_EARGS:
      FEwrong_num_arguments_exceed(arg1);
      break;
    case ECL_EX_F_UNDEF:
      FEundefined_function(arg1);
      break;
    case ECL_EX_F_INVAL:
      FEinvalid_function(arg1);
      break;
    case ECL_EX_S_FMISS:
      FEcontrol_error("UNWIND: frame ~s not found.", 1, arg1);
      break;
    default:
      ecl_internal_error("Unknown exception type.");
    }
  }
  return ECL_NIL;
}

/*****************************************************************************/
/*              Support for Lisp Error Handler                               */
/*****************************************************************************/

static cl_object
cl_symbol_or_object(cl_object x)
{
  if (ECL_FIXNUMP(x))
    return (cl_object)(cl_symbols + ecl_fixnum(x));
  return x;
}

void
FEerror(const char *s, int narg, ...)
{
  ecl_va_list args;
  cl_object rest;
  ecl_va_start(args, narg, narg, 0);
  ecl_enable_interrupts();
  rest = cl_grab_rest_args(args);
  ecl_va_end(args);
  funcall(4, @'si::universal-error-handler',
          ECL_NIL,                    /*  not correctable  */
          ecl_make_constant_base_string(s,-1),    /*  condition text  */
          rest);
  _ecl_unexpected_return();
}

cl_object
CEerror(cl_object c, const char *err, int narg, ...)
{
  ecl_va_list args;
  cl_object rest;
  ecl_va_start(args, narg, narg, 0);
  ecl_enable_interrupts();
  rest = cl_grab_rest_args(args);
  ecl_va_end(args);
  return funcall(4, @'si::universal-error-handler',
                 c,                       /*  correctable  */
                 ecl_make_constant_base_string(err,-1),  /*  continue-format-string  */
                 rest);
}

/***********************
 * Conditions signaler *
 ***********************/

void
CEstack_overflow(cl_object type, cl_object limit, cl_object resume)
{
  cl_env_ptr the_env = ecl_process_env();
  cl_index the_size;
  if (!Null(resume)) resume = @"Extend stack size";
  ECL_UNWIND_PROTECT_BEGIN(the_env) {
    cl_cerror(6, resume, @'ext::stack-overflow', @':type', type, @':size', limit);
  } ECL_UNWIND_PROTECT_EXIT {
    /* reset the margin */
    si_set_limit(type, limit);
  } ECL_UNWIND_PROTECT_END;
  /* resize the stack */
  the_size = ecl_to_size(limit);
  the_size = the_size + the_size/2;
  si_set_limit(type, ecl_make_fixnum(the_size));
}

void
FEprogram_error(const char *s, int narg, ...)
{
  cl_object real_args, text;
  ecl_va_list args;
  ecl_va_start(args, narg, narg, 0);
  text = ecl_make_constant_base_string(s,-1);
  real_args = cl_grab_rest_args(args);
  if (cl_boundp(@'si::*current-form*') != ECL_NIL) {
    /* When FEprogram_error is invoked from the compiler, we can
     * provide information about the offending form.
     */
    cl_object stmt = ecl_symbol_value(@'si::*current-form*');
    if (stmt != ECL_NIL) {
      real_args = @list(3, stmt, text, real_args);
      text = @"In form~%~S~%~?";
    }
  }
  si_signal_simple_error(4, 
                         @'program-error', /* condition name */
                         ECL_NIL, /* not correctable */
                         text,
                         real_args);
  _ecl_unexpected_return();
}

void
FEcontrol_error(const char *s, int narg, ...)
{
  ecl_va_list args;
  cl_object rest;
  ecl_va_start(args, narg, narg, 0);
  rest = cl_grab_rest_args(args);
  ecl_va_end(args);
  si_signal_simple_error(4,
                         @'control-error', /* condition name */
                         ECL_NIL, /* not correctable */
                         ecl_make_constant_base_string(s,-1), /* format control */
                         rest); /* format args */
  _ecl_unexpected_return();
}

void
FEreader_error(const char *s, cl_object stream, int narg, ...)
{
  cl_object message = ecl_make_constant_base_string(s,-1);
  cl_object args_list;
  ecl_va_list args;
  ecl_va_start(args, narg, narg, 0);
  args_list = cl_grab_rest_args(args);
  ecl_va_end(args);
  if (Null(stream)) {
    /* Parser error */
    si_signal_simple_error(4,
                           @'parse-error', /* condition name */
                           ECL_NIL, /* not correctable */
                           message, /* format control */
                           args_list);
  } else {
    /* Actual reader error */
    cl_object prefix = @"Reader error in file ~S, position ~D:~%";
    cl_object position = ecl_file_position(stream);
    message = si_base_string_concatenate(2, prefix, message);
    args_list = cl_listX(3, stream, position, args_list);
    si_signal_simple_error(6,
                           @'reader-error', /* condition name */
                           ECL_NIL, /* not correctable */
                           message, /* format control */
                           args_list, /* format args */
                           @':stream', stream);
  }
  _ecl_unexpected_return();
}


void
FEcannot_open(cl_object file)
{
  cl_object c_error = _ecl_strerror(errno);
  si_signal_simple_error
    (6, @'file-error', /* condition */
     ECL_NIL, /* continuable */
     @"Cannot open ~S.~%C library error: ~A", /* format */
     cl_list(2, file, c_error), /* format args */
     @':pathname', /* file-error options */
     file);
  _ecl_unexpected_return();
}

void
FEend_of_file(cl_object strm)
{
  cl_error(3, @'end-of-file', @':stream', strm);
}

void
FEclosed_stream(cl_object strm)
{
  cl_error(3, @'stream-error', @':stream', strm);
}

void
FEunread_stream(cl_object strm, cl_object twice)
{
  if(Null(twice)) {
    FEerror("Error when using UNREAD-CHAR on stream ~D", 1, strm);
  } else {
    FEerror("Used UNREAD-CHAR twice on stream ~D", 1, strm);
  }
}

cl_object
si_signal_type_error(cl_object value, cl_object type)
{
  cl_error(5, @'type-error', @':expected-type', type,
           @':datum', value);
}

void
FEwrong_type_argument(cl_object type, cl_object value)
{
  si_signal_type_error(value, cl_symbol_or_object(type));
}

void
FEwrong_type_pred_arg(cl_object type, cl_object value)
{
  cl_object predicate = cl_symbol_or_object(type);
  cl_object expected = cl_list(2, @'satisfies', predicate);
  si_signal_type_error(value, expected);
}

void
FEwrong_type_strm_elt(cl_object type, cl_object value)
{
  cl_object expected = cl_symbol_or_object(type);
  cl_error(9, @'simple-type-error', @':format-control',
           @"~A stream element type is not ~S.",
           @':format-arguments', cl_list(2, value, expected),
           @':expected-type', expected,
           @':datum', cl_stream_element_type(value));
}

void
FEwrong_type_only_arg(cl_object function, cl_object value, cl_object type)
{
  const char *message =
    "In ~:[an anonymous function~;~:*function ~A~], "
    "the value of the only argument is~&  ~S~&which is "
    "not of the expected type ~A";
  cl_env_ptr env = ecl_process_env();
  struct ecl_ihs_frame tmp_ihs;
  function = cl_symbol_or_object(function);
  type = cl_symbol_or_object(type);
  if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
  }        
  si_signal_simple_error(8,
                         @'type-error', /* condition name */
                         ECL_NIL, /* not correctable */
                         ecl_make_constant_base_string(message,-1), /* format control */
                         cl_list(3, function, value, type),
                         @':expected-type', type,
                         @':datum', value);
  _ecl_unexpected_return();
}

void
FEwrong_type_nth_arg(cl_object function, cl_narg narg, cl_object value, cl_object type)
{
  const char *message =
    "In ~:[an anonymous function~;~:*function ~A~], "
    "the value of the ~:R argument is~&  ~S~&which is "
    "not of the expected type ~A";
  cl_env_ptr env = ecl_process_env();
  struct ecl_ihs_frame tmp_ihs;
  function = cl_symbol_or_object(function);
  type = cl_symbol_or_object(type);
  if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
  }        
  si_signal_simple_error(8,
                         @'type-error', /* condition name */
                         ECL_NIL, /* not correctable */
                         ecl_make_constant_base_string(message,-1), /* format control */
                         cl_list(4, function, ecl_make_fixnum(narg),
                                 value, type),
                         @':expected-type', type,
                         @':datum', value);
  _ecl_unexpected_return();
}

void
FEwrong_type_key_arg(cl_object function, cl_object key, cl_object value, cl_object type)
{
  const char *message =
    "In ~:[an anonymous function~;~:*function ~A~], "
    "the value of the argument ~S is~&  ~S~&which is "
    "not of the expected type ~A";
  cl_env_ptr env = ecl_process_env();
  struct ecl_ihs_frame tmp_ihs;
  function = cl_symbol_or_object(function);
  type = cl_symbol_or_object(type);
  key = cl_symbol_or_object(key);
  if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
  }        
  si_signal_simple_error(8,
                         @'type-error', /* condition name */
                         ECL_NIL, /* not correctable */
                         ecl_make_constant_base_string(message,-1), /* format control */
                         cl_list(4, function, key, value, type),
                         @':expected-type', type,
                         @':datum', value);
  _ecl_unexpected_return();
}

void
FEwrong_index(cl_object function, cl_object a, int which, cl_object ndx,
              cl_index nonincl_limit)
{
  const char *message1 =
    "In ~:[an anonymous function~;~:*function ~A~], "
    "the ~*index into the object~% ~S~%"
    "takes a value ~D out of the range ~A.";
  const char *message2 =
    "In ~:[an anonymous function~;~:*function ~A~], "
    "the ~:R index into the object~% ~S~%"
    "takes a value ~D out of the range ~A.";
  cl_object limit = ecl_make_integer(nonincl_limit-1);
  cl_object type = ecl_make_integer_type(ecl_make_fixnum(0), limit);
  cl_object message = ecl_make_constant_base_string((which<0) ? message1 : message2,-1);
  cl_env_ptr env = ecl_process_env();
  struct ecl_ihs_frame tmp_ihs;
  function = cl_symbol_or_object(function);
  if (!Null(function) && env->ihs_stack.top && env->ihs_stack.top->function != function) {
    ecl_ihs_push(env,&tmp_ihs,function,ECL_NIL,ECL_NIL);
  }        
  cl_error(9,
           @'simple-type-error', /* condition name */
           @':format-control', message,
           @':format-arguments',
           cl_list(5, function, ecl_make_fixnum(which+1), a, ndx, type),
           @':expected-type', type,
           @':datum', ndx);
}

void
FEunbound_variable(cl_object sym)
{
  cl_error(3, @'unbound-variable', @':name', sym);
}

void
FEundefined_function(cl_object fname)
{
  cl_error(3, @'undefined-function', @':name', fname);
}

void
FEprint_not_readable(cl_object x)
{
  cl_error(3, @'print-not-readable', @':object', x);
}

void
FEtimeout()
{
  cl_error(1, @'ext::timeout');
}

/*************
 * Shortcuts *
 *************/

void
FEwrong_num_arguments(cl_object fun)
{
  if (Null(fun)) {
    FEprogram_error("Wrong number of arguments passed to an anonymous function", 0);
  } else {
    fun = cl_symbol_or_object(fun);
    FEprogram_error("Wrong number of arguments passed to function ~S.", 1, fun);
  }
}

void
FEwrong_num_arguments_exceed(cl_object n)
{
  FEprogram_error("Too many arguments: ~S.", 1, n);
}

void
FEwrong_num_arguments_anonym(void)
{
  FEprogram_error("Wrong number of arguments passed to an anonymous function", 0);
}

void
FEinvalid_macro_call(cl_object name)
{
  FEerror("Invalid macro call to ~S.", 1, name);
}

void
FEinvalid_variable(const char *s, cl_object obj)
{
  FEerror(s, 1, obj);
}

void
FEillegal_variable_name(cl_object v)
{
  FEprogram_error("Not a valid variable name ~S.", 1, v);
}

void
FEassignment_to_constant(cl_object v)
{
  FEprogram_error("SETQ: Tried to assign a value to the constant ~S.", 1, v);
}

void
FEbinding_a_constant(cl_object v)
{
  FEprogram_error("The constant ~S is being bound.", 1, v);
}

void
FEinvalid_function(cl_object obj)
{
  FEwrong_type_argument(@'function', obj);
}

void
FEinvalid_function_name(cl_object fname)
{
  cl_error(9, @'simple-type-error', @':format-control',
           @"Not a valid function name ~D.",
           @':format-arguments', cl_list(1, fname),
           @':expected-type', cl_list(2, @'satisfies', @'si::valid-function-name-p'),
           @':datum', fname);
}

#ifdef ECL_THREADS
void
FEerror_not_owned(cl_object lock)
{
  FEerror("Attempted to give up lock ~S that is not owned by process ~S",
          2, lock, mp_current_process());
}

void
FEunknown_lock_error(cl_object lock)
{
#ifdef ECL_WINDOWS_THREADS
  FEwin32_error("When acting on lock ~A, got an unexpected error.", 1, lock);
#else
  FEerror("When acting on lock ~A, got an unexpected error.", 1, lock);
#endif
}
#endif

/*      bootstrap version                */
static int recursive_error = 0;

static cl_object
universal_error_handler(cl_object continue_string, cl_object datum,
                        cl_object args)
{
  const cl_env_ptr the_env = ecl_process_env();
  cl_object stream;
  if (recursive_error)
    goto ABORT;
  recursive_error = 1;
  stream = cl_core.error_output;
  if (!Null(stream)) {
    ecl_bds_bind(the_env, @'*print-readably*', ECL_NIL);
    ecl_bds_bind(the_env, @'*print-level*', ecl_make_fixnum(4));
    ecl_bds_bind(the_env, @'*print-length*', ecl_make_fixnum(8));
    ecl_bds_bind(the_env, @'*print-circle*', ECL_NIL);
    ecl_bds_bind(the_env, @'*print-base*', ecl_make_fixnum(10));
    writestr_stream("\n;;; Unhandled lisp initialization error", stream);
    writestr_stream("\n;;; Message:\n", stream);
    si_write_ugly_object(datum, stream);
    writestr_stream("\n;;; Arguments:\n", stream);
    si_write_ugly_object(args, stream);
    ecl_bds_unwind_n(the_env, 5);
  }
 ABORT:
  ecl_internal_error("\nLisp initialization error.\n");
}

void
FEdivision_by_zero(cl_object x, cl_object y)
{
  cl_error(5, @'division-by-zero', @':operation', @'/',
           @':operands', cl_list(2, x, y));
}

cl_object
_ecl_strerror(int code)
{
  const char *error = strerror(code);
  return ecl_make_simple_base_string(error,-1);
}

/*************************************
 * Errors generated by the C library *
 *************************************/
/*
 * Interprets an error code from the C library according to the POSIX
 * standard, and produces a suitable error message by combining the user
 * supplied format with an explanation of the cause of the error.
 */
void
FElibc_error(const char *msg, int narg, ...)
{
  ecl_va_list args;
  cl_object rest, error = _ecl_strerror(errno);

  ecl_va_start(args, narg, narg, 0);
  rest = cl_grab_rest_args(args);
  ecl_va_end(args);

  FEerror("~?~%C library explanation: ~A.", 3,
          ecl_make_constant_base_string(msg,-1), rest,
          error);
}

#if defined(ECL_MS_WINDOWS_HOST) || defined(cygwin)
ecl_def_ct_base_string(unknown_error,"[Unable to get error message]",28,static,const);

void
FEwin32_error(const char *msg, int narg, ...)
{
  ecl_va_list args;
  cl_object rest, win_msg_obj;
  char *win_msg;

  if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM|FORMAT_MESSAGE_ALLOCATE_BUFFER,
                    0, GetLastError(), 0, (void*)&win_msg, 0, NULL) == 0)
    win_msg_obj = unknown_error;
  else {
    win_msg_obj = ecl_make_simple_base_string(win_msg,-1);
    LocalFree(win_msg);
  }

  ecl_va_start(args, narg, narg, 0);
  rest = cl_grab_rest_args(args);
  ecl_va_end(args);
  FEerror("~?~%Windows library explanation: ~A.", 3,
          ecl_make_constant_base_string(msg,-1), rest,
          win_msg_obj);
}
#endif

/************************************
 * Higher level interface to errors *
 ************************************/

@(defun error (eformat &rest args)
@ {
  ecl_enable_interrupts();
  funcall(4, @'si::universal-error-handler', ECL_NIL, eformat,
          cl_grab_rest_args(args));
  _ecl_unexpected_return();
} @)

@(defun cerror (cformat eformat &rest args)
@ {
  ecl_enable_interrupts();
  @(return funcall(4, @'si::universal-error-handler', cformat, eformat,
                   cl_grab_rest_args(args)));
} @)

void
init_error(void)
{
  ecl_def_c_function(@'si::universal-error-handler',
                     (cl_objectfn_fixed)universal_error_handler, 3);
}
