/* Copyright 1989-93 GROUPE BULL -- See license conditions in file COPYRIGHT */
/******************************************************************************\
*
* klerror.c: *
* error message printing and support for internationalisation *
* *
\*****************************************************************************/
#include "EXTERN.h"
#include "klone.h"
#include "kl_atom.h"
#include "kl_string.h"
#include "kl_stream.h"
#include "kl_number.h"
#include "kl_list.h"
#include "kl_func.h"
#include "kl_hash.h"
#ifdef KOALA
#ifdef ISM
#undef ISM
#endif
#endif
#ifdef ISM
#include <syslog.h>
#include <locale.h>
#include <nl_types.h>
#if !defined(__NUTC__)
#include <langinfo.h>
#endif
#include "ilo_define.h"
#ifndef SML_CATALOGUE_NAME
#define SML_CATALOGUE_NAME "mes-sml"
#endif /* SML_CATALOGUE_NAME */
#if defined(BOS) || defined(hpux) || defined(sgi)
char *CATGETS(nl_catd cat_id, int set, int msg_nb, const char *def) {
#else
char *CATGETS(nl_catd cat_id, int set, int msg_nb, char *def) {
#endif /* BOS || hpux || sgi */
char *tmp1, *tmp2;
tmp1 = catgets(cat_id, set, msg_nb, def);
if ( tmp1 == def)
return(tmp1);
/* strlen gives length without '\0' char */
/* strcpy copy all chars including '\0' */
tmp2 = (char *) Malloc(strlen(tmp1) + 1);
strcpy(tmp2, tmp1);
return(tmp2);
}
#else /* !ISM */
#endif /* ISM */
int KlMAX_STACKED_ERRORS = 100;
KlO KlErrorHandlerDefault();
KlO KlNoElementErrorTrigger();
extern KlHash KlErrorUnRecoverableTable;
KlConstant KlErrorHandlerDefaultSymbol;
#ifdef DO_BUS_ERROR
#define DoABusError() *((int *)0) = 1
#else /* DO_BUS_ERROR */
#define DoABusError()
#endif /* DO_BUS_ERROR */
char *KlFatalErrorMessagesDefault[] = {
"Internal error %s", /* 0 */
"Uncaught ERROR", /* 1 */
"No more memory, failed to allocate %d bytes", /* 2 */
"KlDeclareSelector(%s): bad arity, use KlDeclareSelectorArity",/* 3 */
"stack overflow (asked for %d cells)", /* 4 */
"string too long for parser (%d chars)", /* 5 */
"Too many errors, error %s in an error/handler/corrector?", /* 6 */
"Function called at the wrong step (%d) of the Initialization",/* 7 */
"KlDeclareSelector(%s) called after type declarations", /* 8 */
"KlTypesInit(): a type (%s) is already defined", /* 9 */
"Trying to free a profiled function", /* 10 */
"Too many keywords for a Subr. Increase KLMAX_KEYWORDS (%d)", /* 11 */
"Type too big (%d bytes)", /* 12 */
"KlDeclareSelectorArity error: %s!", /* 13 */
"Cannot load file init \"%s\", bad installation, load path or extensions?",
/* 14 */
"Bad selector value: %d" /* 15 */
};
char **KlFatalErrorMessages = KlFatalErrorMessagesDefault;
int
KlFatalErrorDefaultHandler(code, data)
int code;
char *data;
{
fprintf(stderr, "FATAL %s error #%d, aborting: ",
#ifdef ISM
"SML",
#else
"Klone",
#endif
code);
fprintf(stderr, KlFatalErrorMessages[code], data);
putc('\n', stderr);
fflush(stderr);
stop_if_in_dbx(KlFatalErrorMessages[code]);
if (code == 3) /* me MUST not flush buffers */
_exit(code);
else
exit(code);
}
int
KlInternalWarning(code, data)
int code;
char *data;
{
#ifdef ISM
fprintf(stderr, "SML internal warning: ");
#else
fprintf(stderr, "Klone internal warning: ");
#endif
fprintf(stderr, KlFatalErrorMessages[code], data);
putc('\n', stderr);
fflush(stderr);
stop_if_in_dbx(KlFatalErrorMessages[code]);
}
/* exec error is executed in a VForked son, so we can only do a exit in a hurry
* with restricted use of ressources
*/
KlExecError(ermes, command)
char *ermes; /* 0 for execution */
char *command;
{
static char *prefix = "Klone fork error, cannot open for ";
if (!ermes) ermes = "executing: "; /* cannot use stdio in fork */
write(2, prefix, strlen(prefix));
write(2, ermes, strlen(ermes));
write(2, command, strlen(command));
write(2, "\n", 1);
_exit(255); /* cannot use exit in fork */
}
/* recoverable error */
KlAtom
KlErrorCodeMakeSRecoverable(name, value)
char *name;
char *value;
{
KlAtom atom = KlIntern(name);
KlDecRef(atom->c_val);
KlIncRef(atom->c_val = (KlO) KlStringMake(value));
return atom;
}
/* unrecoverable error */
KlAtom
KlErrorCodeMakeS(name, value)
char *name;
char *value;
{
KlAtom atom = KlErrorCodeMakeSRecoverable(name, value);
KlHashPut(KlErrorUnRecoverableTable, atom, TRU);
return atom;
}
int
KlErrorIsRecoverable(atom)
KlAtom atom;
{
if (KlIsASymbol(atom) &&
NIL != KlHashGet(KlErrorUnRecoverableTable, atom, NIL)) {
KlSPrintf(KlStderr,
"\n*** WARNING: trying to correct unrecoverable error \"%s\"\n",
atom->p_name);
return 0;
} else {
return 1;
}
}
/* generate the documentation for the error code with the following Klone code:
(setq re1 (regcomp "^ [/][*] (Errors:.*)$"))
(setq re2 (regcomp "^[ \t]*(.*[^ ])[ ]*[*][/]"))
(setq re3 (regcomp "^[ \t]*(.*[^ ])$"))
(with (fd (open "klerror.c"))
(while (setq line (read-line fd ()))
(if (regexec re1 line) (progn
(setq desc (regsub re1 1))
(while (not (regexec re2 desc))
(if (regexec re3 (read-line fd))
(nconc desc " " (regsub re3 1))))
(setq desc (regsub re2 1))
(read-line fd)
(setq name (match "[\"]([^\"]*)[\"]" (read-line fd) 1))
(setq text (match "^[ \t]*(.*)[)]; *$" (read-line fd) 1))
(print-format "%0\n %1\n %2\n\n" name desc text)
))))
*/
KlErrorCodesInit()
{
#ifdef ISM
char *rc = setlocale(LC_ALL, "");
nl_catd smlcatd = catopen (SML_CATALOGUE_NAME, 0);
if (smlcatd == (nl_catd) -1)
{
fprintf (stderr,
"Cannot open catalogue message \"%s.cat\"\n",
SML_CATALOGUE_NAME);
fprintf (stderr,
"Check the values of the Shell variables $LANG and $NLSPATH\nFor example:\tLANG=%s\tNLSPATH=$ISMROOT/messages/%%L/%%N.cat\n",
#ifdef _AIX
"en_US" /* En_US is the default language */
#else /* _AIX */
"C" /* C is the default language */
#endif /* _AIX */
);
}
#else
int smlcatd = 0;
#endif
/* Errors:Error is the default error called when (error) is called
without arguments.
Correctable. */
KlE_ERROR = KlErrorCodeMakeSRecoverable
( "Errors:Error" ,
"Error" );
/* Errors:Break is a fake error called by the break function to be caught
by the debugger for stopping in it.
WARNING: is obsoleted by KlE_DBTK_BREAK
Correctable. */
KlE_BREAK = KlErrorCodeMakeSRecoverable
( "Errors:Break" ,
"(break %0), condition %2 = %1" );
/* Errors:DbtkBreak is a fake error called by the dbtk:break function to
be caught by the debugger for stopping in it.
args: expr_to_be_evaluated, tag, closure_data, list-of-conditions,
number of the condition which trigerred the error, its value
Correctable. */
KlE_DBTK_BREAK = KlErrorCodeMakeSRecoverable
( "Errors:DbtkBreak" ,
"(break %1), condition %4 of %3 = %5" );
/* Errors:UndefinedVariable is called when an undefined symbol is evaluated
Correctable. */
KlE_UNDEFINED_VARIABLE = KlErrorCodeMakeSRecoverable
(
"Errors:UndefinedVariable" ,
"undefined variable: %0" );
/* Errors:BadNumberOfArgs is called when a function is called with an
incorrect number of arguments */
KlE_BAD_NUMBER_OF_ARGS = KlErrorCodeMakeSRecoverable
(
"Errors:BadNumberOfArgs" ,
"bad number of arguments: %0" );
/* Errors:UndefinedFunction is called when an undefined symbol is evaluated
as the first element of an evaluated list. If corrected, the return value
of the corrector is taken as the function to be applied to the arguments.
Correctable. */
KlE_UNDEFINED_FUNCTION = KlErrorCodeMakeSRecoverable
(
"Errors:UndefinedFunction" ,
"undefined function: %r0" );
/* Errors:BadDefun is called when trying to define a function (Expr,
FExpr, Macro) with a badly formed lambda list declaration. */
KlE_BAD_DEFUN = KlErrorCodeMakeSRecoverable
( "Errors:BadDefun" ,
"bad definition of function: %0" );
/* Errors:BadArgType is called when a parameter to a function do not
match the expected arg types. */
#ifdef ISM
KlE_BAD_ARG_TYPE = KlErrorCodeMakeS
( "Errors:BadArgType" ,
"bad argument: %r0 (of type %t0, at position %1), expecting a %2" );
#else /* !ISM */
KlE_BAD_ARG_TYPE = KlErrorCodeMakeS
( "Errors:BadArgType" ,
"bad %fnum-incr-one1%fnth-for-num-incr1 argument: %r0 (of type %t0), expecting a %2" );
#endif /* !ISM */
/* Errors:ReleasingAtom should not be called. If called, it indicates that
the reference counting system has gone wild. */
KlE_RELEASING_ATOM = KlErrorCodeMakeS
( "Errors:ReleasingAtom" ,
"Internal error: trying to free atom: %0" );
/* Errors:BadLocalSyntax is called when an error is made in the declaration
of local symbols to constructs such as with, let... */
KlE_BAD_LOCAL_SYNTAX = KlErrorCodeMakeSRecoverable
( "Errors:BadLocalSyntax" ,
"bad local variable declaration" );
/* Errors:SyntaxError is called when a parsing error occurs when read-ing
an expression or loading a file. */
KlE_SYNTAX_ERROR = KlErrorCodeMakeS
( "Errors:SyntaxError" ,
"%0" );
/* Errors:CannotSet is called when trying to set un unsettable symbol:
constant, keyword, or non-settable active value. */
KlE_CANNOT_SET = KlErrorCodeMakeSRecoverable
( "Errors:CannotSet" ,
"Cannot set %r0 (of type %t0)" );
/* Errors:NonKlo should not be called normally. It indicates that an invalid
pointer has been given to a Klone function at the C level. */
KlE_NON_KlO = KlErrorCodeMakeS
( "Errors:NonKlo" ,
#ifdef ISM
"%0 on a non SML object %1"
#else
"%0 on a non Klone object %1"
#endif
);
/* Errors:UndefinedMethod is called when a primitive internal functionnality
(method) such as eval, print, setq, get... has been applyied on a type
not supporting it. */
KlE_UNDEFINED_METHOD = KlErrorCodeMakeSRecoverable
(
"Errors:UndefinedMethod" ,
"\"%1\" not defined for object %r0 (of type %t0)" );
/* Errors:NoInternalMethod is called when trying to hook non-existing
internal methods */
KlE_UNDEFINED_INTERNAL_METHOD = KlErrorCodeMakeS
(
"Errors:UndefinedInternalMethod" ,
"\"%0\" is not an internal method" );
#ifdef ISM
/* TODO: see if ISM actually uses these... */
KlE_NOT_REDEFINABLE = KlErrorCodeMakeS
( "Errors:NotRedefinable" ,
"Cannot redefine object: %r0 (of type %t0)" );
KlE_NOT_MODIFIABLE = KlErrorCodeMakeS
( "Errors:NotModifiable" ,
"Cannot modify object: %r0 (of type %t0)" );
#endif ISM
/* Errors:NoCoercion is called when coerce fails to find a coercion
converter. */
KlE_NO_COERCION = KlErrorCodeMakeSRecoverable
( "Errors:NoCoercion" ,
"Cannot coerce %r0 (of type %t0) to a %1" );
/* Errors:NotAPackage is called when *package* tries to be prepended to
a symbol but is neither a string or ().*/
/* KlE_NOT_A_PACKAGE = KlErrorCodeMakeS
(CATGETS(smlcatd, 10, Errors_NotAPackage, "Errors:NotAPackage"),
CATGETS(smlcatd, 11, Errors_NotAPackage, "*package* contents is not a string but %0 (of type %t0)"));*/
#ifdef LOCATORS
/* Errors:BadLocator is called when trying to make a locator with less
than 2 elements */
KlE_BAD_LOCATOR = KlErrorCodeMakeSRecoverable
( "Errors:BadLocator" ,
"Cannot make locator with %0, needs more elements" );
#endif /* LOCATORS */
/* Errors:ErrorOpeningFile is called when opening a file fails. */
KlE_ERROR_OPENING_FILE = KlErrorCodeMakeSRecoverable
(
"Errors:ErrorOpeningFile" ,
"Cannot open file %r0 with mode %1, reason: %2" );
/* Errors:ErrorCannotLoadFile is called when a file cannot be found in
*load-pathname* and with *load-extensions* to be loaded. */
KlE_CANNOT_LOAD_FILE = KlErrorCodeMakeSRecoverable
(
"Errors:ErrorCannotLoadFile" ,
"file %0 not found" );
/* Errors:BadDirectory is called when trying to go to or to list a
non-existing or protected directory. */
KlE_BAD_DIRECTORY = KlErrorCodeMakeSRecoverable
( "Errors:BadDirectory" ,
"bad directory: %0" );
#ifdef CHECK_FILE_TYPE_ON_LOAD
KlE_INVALID_LOAD_FILE = KlErrorCodeMakeSRecoverable
(
"Errors:ErrorInvalidLoadFile" ,
#ifdef ISM
"file %0 not loadable, not a SML file"
#else /* !ISM */
"file %0 not loadable, not a Klone file"
#endif /* !ISM */
);
#endif /* CHECK_FILE_TYPE_ON_LOAD */
/* Errors:StreamError is called when an I/O operation (read or write) fails
on a stream. */
KlE_STREAM_ERROR = KlErrorCodeMakeS
( "Errors:StreamError" ,
"cannot %0 on stream %1" );
/* Errors:InvalidKeyword is called when a function is given a keyword not
belonging to the list of available ones. The authorized ones are
listed. */
KlE_INVALID_KEYWORD = KlErrorCodeMakeS
( "Errors:InvalidKeyword" ,
"Unvalid Keyword: %0. Should be one of: %1" );
/* Errors:InvalidKeywordValue is called when a value is given for a keyword
parameter not belonging to the list of authorized ones. The possible
ones are listed. */
KlE_INVALID_KEYWORD_VALUE = KlErrorCodeMakeS
(
"Errors:InvalidKeywordValue" ,
"Unvalid Keyword value: %0 for keyword %1. Should be one of: %2" );
/* Errors:BadDoSyntax is called when an error is made in the local variable
declaration of thd do, do*, dolist, dohash, dotimes constructs. */
KlE_BAD_DO_SYNTAX = KlErrorCodeMakeSRecoverable
( "Errors:BadDoSyntax" ,
"Bad syntax in iteration function" );
/* Errors:DivideByZero is called when trying to divide a number by 0. */
KlE_DIVIDE_BY_ZERO = KlErrorCodeMakeS
( "Errors:DivideByZero" ,
"Division by zero on %0" );
/* Errors:NumericError is called for various numeric errors, out-of-range,
floating exceptions... */
KlE_NUMERIC_ERROR = KlErrorCodeMakeS
( "Errors:NumericError" ,
"Numeric Error (floating point exception)" );
/* Errors:NoElement is called when trying to get an inexisting field in
a Klone object. */
KlE_NO_ELEMENT = KlErrorCodeMakeSRecoverable
( "Errors:NoElement" ,
"No element named %0 for %1" );
/* OBSOLETE: replaced by KlE_NO_ELEMENT everywhere
KlE_NO_SLOT = KlErrorCodeMakeS
(CATGETS(smlcatd, 10, Errors_NoSlot, "Errors:NoSlot"),
CATGETS(smlcatd, 11, Errors_NoSlot, "No slot named %0 for class %1"));
*/
/* Errors:NoModifiable is called when trying to modify a hashtable or a
p-list while scanning it by dohash. */
KlE_NO_MODIFY = KlErrorCodeMakeS
( "Errors:NoModifiable" ,
"Object %0 cannot be modified while scanned" );
/* MaxArity Internal error when a C definition is invalid */
KlE_MAX_ARITY = KlErrorCodeMakeS
( "Errors:MaxArity" ,
"Maximum arity overflowed for function: %0" );
/* Errors:StackOverflow is called when the soft value for the max stack is
overflowed. This is just a check to trap infinite loops. */
KlE_STACK_OVERFLOKl = KlErrorCodeMakeS
( "Errors:StackOverflow" ,
"Stack overflow (%0 words). May be an infinite loop" );
/* Errors:NoCatch is called when trying to throw to an uncaught catch. */
KlE_NO_CATCH = KlErrorCodeMakeS
( "Errors:NoCatch" ,
"No catch named %0" );
/* Errors:NoPut is called when trying to put in a non-modifiable object,
most notably nil (but you can put in empty lists). */
KlE_NO_PUT = KlErrorCodeMakeS
( "Errors:NoPut" ,
"cannot put %1 in %0" );
/* Errors:NoAppend is called when trying to append in a non-resizable
object, most notably StringPtr */
KlE_NO_APPEND = KlErrorCodeMakeS
( "Errors:NoAppend" ,
"cannot resize %0" );
/* Errors:BadCompareCall is called when sorting and the compare function
returns something else than a number. */
KlE_BAD_COMPARE_CALL = KlErrorCodeMakeS
( "Errors:BadCompareCall" ,
"sort: compare function must return a number, not %0 (of type %t0)" );
/* Errors:BadRegexpr is called when compiling (via regcomp) an ill-formed
regular expression. */
KlE_BAD_REGEXPR = KlErrorCodeMakeS
( "Errors:BadRegexpr" ,
"Error in regular expression: %0" );
/* Errors:BadSymbchar is called when a construction #\foo is parsed with foo
not being a legal character full name. If corrected, should return
a number (ascii code) */
KlE_BAD_SYMBCHAR = KlErrorCodeMakeSRecoverable
( "Errors:BadSymbchar" ,
"No such character name: %0" );
/* Errors:BadLambdalist is called when trying to define a function with an
ill-formed parameter declaration. */
KlE_BAD_LAMBDALIST = KlErrorCodeMakeS
( "Errors:BadLambdalist" ,
"Bad lambda list declaration: %0, parameter %1" );
/* Errors:BadAccess is called when trying to get or put a field of an
object which cannot be accessed with this mode (put or get). */
KlE_BAD_ACCESS = KlErrorCodeMakeS
( "Errors:BadAccess" ,
"Invalid access" );
/* Errors:CommaOutsideBackquote is called when trying to evaluate a
comma-prefixed symbol outside the context of the evaluation of a
backquoted list. */
KlE_COMMA_OUTSIDE_BACKQUOTE = KlErrorCodeMakeS
(
"Errors:CommaOutsideBackquote" ,
"Comma outside a backquote" );
/* Errors:InvalidIdentifier is called when an invalid identifier is used.
Currently only used for invalid names for putenv variables. */
KlE_INVALID_IDENTIFIER = KlErrorCodeMakeS
(
"Errors:InvalidIdentifier" ,
"Invalid identifier name: %r0" );
/* Errors:NumberOutOfRange is called when a number is outside the
interval (must be between start and end inclusive. */
KlE_NUMBER_OUT_OF_RANGE = KlErrorCodeMakeS
(
"Errors:NumberOutOfRange" ,
"Number out of range: %0, should be between %1 and %2 inclusive" );
/******************************************************************* KLOS */
/* Errors:NoMethod is called when a generic function is called on an ExO
not implementing it. */
KlE_NO_METHOD = KlErrorCodeMakeS
( "Errors:NoMethod" ,
"No method named %0 for class %1" );
/* Errors:NoGeneric called when trying to define a generic function on a
symbol already having a non-functional value. please undefine the
symbol first. */
KlE_CANNOT_DECLARE_GENERIC = KlErrorCodeMakeS
( "Errors:NoGeneric" ,
"Cannot create generic function of name %0, already defined to be a %t1: %1" );
/* Errors:NotAMethod is called when trying to add-method something else than
a Expr or a Subr. */
KlE_NOT_A_METHOD = KlErrorCodeMakeS
( "Errors:NotAMethod" ,
"for selector %1, method %0 (of type %t0) is not an Expr or a Subr" );
/* Errors:NoClass called when a non-class object is given to functions
operation on classes. */
KlE_NO_CLASS = KlErrorCodeMakeS
( "Errors:NoClass" ,
"Not a Class: %0 (of type %t0)" );
/* Errors:BadClassDef called on ill-formed defclass calls. */
KlE_BAD_CLASS_DEF = KlErrorCodeMakeS
( "Errors:BadClassDef" ,
"Bad class definition for %0: %1" );
/* Errors:NoPreviousMethod is called then trying to call call-next-method
not inside a method invocation. */
KlE_NO_PREVIOUS_METHOD = KlErrorCodeMakeS
(
"Errors:NoPreviousMethod" ,
"not inside a method" );
#ifdef OLD_ERROR_ON_NO_NEXT_METHOD
KlE_NO_NEXT_METHOD = KlErrorCodeMakeSRecoverable
( "Errors:NoNextMethod" ,
"no next method %0 for class %1 %2" );
#endif /* !OLD_ERROR_ON_NO_NEXT_METHOD */
KlE_NO_METACLASS_INSTANCE = KlErrorCodeMakeSRecoverable
(
"Errors:NoMetaclassInstanciation" ,
"cannot make instances from metaclass %0" );
#ifdef DEBUG2
KlE_BAD_STACK = KlErrorCodeMakeS
( "Errors:BadStack" ,
"BAD STACK: bad frame type at %0" );
#endif /* DEBUG2 */
#ifdef WPPB
KlE_BAD_WPPB = KlErrorCodeMakeS
( "Errors:BadWPPB" ,
"Invalid preparsed WPPB file %r0, byte %1: %2" );
#endif /* WPPB */
#ifdef KLSES
KlE_SES_IO_ERROR = KlErrorCodeMakeS
( "Errors:SES_IO_ERROR" ,
"Fatal connection error for the SES dynamic extension: %0" );
KlE_SES_NOT_FOUND = KlErrorCodeMakeS
( "Errors:SES_NOT_FOUND" ,
"SES dynamic extension %0 not found" );
KlE_SES_INTERNAL_ERROR = KlErrorCodeMakeS
(
"Errors:SES_INTERNAL_ERROR" ,
"Internal protocol error in the SES dynamic extension: %0" );
KlE_SES_BAD_ARGUMENT = KlErrorCodeMakeS
(
"Errors:SES_BAD_ARGUMENT" ,
"bad argument type: SES extension %0 returned %2, expected %1" );
KlE_SES_BAD_ERROR = KlErrorCodeMakeS
(
"Errors:SES_BAD_ERROR" ,
"bad error returned by SES extension: %0: %r1" );
#endif /* KLSES */
#ifdef ISM
if (smlcatd != (nl_catd) -1)
catclose (smlcatd);
#endif
}
/******************************************************************************\
ERRORS run-time errors *
\*****************************************************************************/
/* handlers
* handlers klone functions or functions (pointed to by klone integers)
* which are given the error type and some data,
* and must return a Wob, which can be:
* :nil next handler is executed
* :true jump in error immediately, bypassing rest of handlers
* other do not execute rest of error handlers, but execution
* goes on after this point, the error returning the object
*/
KlO
KlHandlerExecute(obj, argc, argv)
KlO obj;
int argc; /* first arg is error code (atom) */
KlO *argv; /* additional datas (Klone objects) */
{
return KlApplyN(obj, argc, argv); /* does nothing now other than apply */
}
int KlIsInErrorInError = 0;
KlO
KlHandlerExecutes(disable, name, argc, argv)
int disable; /* disable the handler on entry ? */
KlAtom name; /* the name of handlers */
int argc; /* first arg is error code (atom) */
KlO *argv; /* additional datas (Klone objects) */
{
int i;
KlO result = (KlO) KlK_nil;
KlList list;
int stackptr = KlStackPtr;
list = (KlList) KlSend_eval(name);
if (disable) {
/* KlA_is_in_error_handler is succ. undef, nil, t
* undef: normal: execute handler normally
* nil: error in an error handler: caution: use the default built-in
* t: error in the default: just do nothing, hope it's OK...
*/
KlStackFramePush(1, &KlA_is_in_error_handler, NIL, NIL);
if (KlA_is_in_error_handler->c_val == (KlO) list) {
/* we are in the same, we may be looping, execute default */
KlSend_setq(KlA_is_in_error_handler, TRU);
result = KlErrorHandlerDefault(argc, argv);
KlStackFramePopNormal(stackptr);
return result;
} else if (KlA_is_in_error_handler->c_val == TRU) {
/* still an error, just do nothing and abort */
KlStackFramePopNormal(stackptr);
return result;
} else {
/* we enter a new handler has been set, Ok,
register which one we are in */
KlSend_setq(KlA_is_in_error_handler, list);
}
}
KlCurVariable = name;
if (KlIsAList(list)) {
for (i = list->size - 1; i >= 0; i--) {
result = KlHandlerExecute(list->list[i], argc, argv);
if (result != (KlO) KlK_nil) {
goto return_result;
}
}
} else {
result = KlHandlerExecute(list, argc, argv);
}
return_result:
KlIsInErrorInError = 0;
if (disable) {
KlStackFramePopNormal(stackptr);
}
return result;
}
#ifdef ISM
static void SmlSyslog(argc, argv)
int argc; /* first arg is error code (atom) */
KlO *argv; /* additional datas (Klone objects) */
{
KlO *args = (KlO *) KlAlloca(argc + 1);
int i;
args[0] = (KlO) KlStreamStringMake(KlStringMake(""), 3);
args[1] = KlSend_eval(argv[0]);
for (i = 1; i < argc; i++) {
args[i + 1] = argv[i];
}
KlPrintFormat(argc + 1, args);
{
char *p = (((KlStreamString)args[0])->klstring)->string;
char *message = Malloc(strlen(p) + strlen(KlErrorMessagePrefix) + 2);
strcpy(stpcpy(stpcpy(message, KlErrorMessagePrefix), p), "\n");
syslog (LOG_ERR, message);
Free (message);
}
}
#endif /* ISM */
/* KlError:
* This is the standard error function.
* It is called with the error code (an atom), and then calls the Klone errors
* handlers with the errors and the arguments
*
* WARNING: Don't forget to clean your structures before going here,
* you won't return!
*
* KlA_error_correctors are non-interactive handlers which should try
* to correct the error or do nothing, whereas KlA_error_handlers should
* high-level debugging
*/
KlO
_KlError(argc, argv)
int argc; /* first arg is error code (atom) */
KlO *argv; /* additional datas (Klone objects) */
{
KlO result;
KlGCMark();
if (KlIsCleaningStack) {
return NIL;
}
if (KlIsInFrameHook > KlMAX_STACKED_ERRORS) { /* prevents looping */
KlTooManyErrors(argc, argv);
return NIL;
}
KlStackFramePushSetHook();
if (!argc) {
argc = 1;
argv = (KlO *) &KlE_ERROR;
}
#ifdef ISM
else if (argc >= 2 && argv[0] == (KlO) KlE_STREAM_ERROR &&
(argv[2] == (KlO) KlStderr ||
argv[2] == (KlO) KlStdout ||
argv[2] == (KlO) KlStdin)) {
SmlSyslog(argc, argv);
goto direct_return;
}
#endif /* ISM */
result = KlHandlerExecutes(0, KlA_error_correctors, argc, argv);
if (result != (KlO) KlK_nil && result != (KlO) KlK_true
&& KlErrorIsRecoverable(argv[0])) {
goto direct_return;
}
result = KlHandlerExecutes(1, KlA_error_handlers, argc, argv);
if (result != (KlO) KlK_nil && result != (KlO) KlK_true
&& KlErrorIsRecoverable(argv[0])) {
goto direct_return;
}
if (!KlContinueReadingOnError)
KlErrorStatus = 1;
DoABusError(); /* debug only */
stop_if_in_dbx("Error (after handler execution)");
#ifdef ISM
SmlSyslog(argc, argv);
#endif
direct_longjmp:
KlGC();
KlStackFramePopHook();
KlThrowFromError(KlA_ERROR, argv[0]);
/* NOTREACHED *//* for lint */
direct_return:
KlStackFramePop();
return result;
}
/* KlTooManyErrors
* We are looping in error correctors/handlers, try to give some hints to
* user before aborting
*/
KlTooManyErrors(argc, argv)
int argc;
KlString *argv;
{
int stackptr = KlStackPtr;
KlStackFramePushValuesV(2,
KlA_error_correctors, NIL,
KlA_error_handlers, NIL);
KlInternalWarning(6, KlIsAString(argv[0]) ? argv[0]->string : "");
KlErrorHandlerDefault(argc, argv);
KlStackFramePopNormal(stackptr);
}
/******************************************************************************\
error-calling facilities *
\*****************************************************************************/
/************************************************************** VARARGS form */
/* KlErrorV(KlO error, int number_of_args, KlO args...)
*/
KlO
#if 1
KlErrorV(KlO error, int size, ...)
#else
KlErrorV(va_alist)
va_dcl
#endif
{
va_list argList;
int i;
KlList list;
KlO *p;
#if 1
va_start(argList, size);
#else
KlO error;
int size;
va_start(argList);
error = va_arg(argList, KlO);
size = va_arg(argList, int);
#endif
list = KlListNMake(size + 1);
p = list->list;
KlIncRef(*p++ = error);
for (i = 0; i < size; i++) {
*p = va_arg(argList, KlO);
KlIncRef(*p++);
}
va_end(argList);
return _KlError(size + 1, list->list);
}
/*********************************************** specialized error functions */
KlO
KlErrorNumberOutOfRange(number, low, high)
int number, low, high;
{
return KlError3(KlE_NUMBER_OUT_OF_RANGE, KlNumberMake(number),
KlNumberMake(low), KlNumberMake(high));
}
/******************************************************************************\
C error handlers *
\*****************************************************************************/
/* default error handler when throwing at a not caught ERROR tag */
void
KlNonCaughtErrorHandlerDefault()
{
if (KlNonCaughtErrorFrame != -1) {
if (KlNonCaughtErrorVerbose)
KlSPuts("Uncaught ERROR\n", KlStderr);
KlStackFramePopTo(KlNonCaughtErrorFrame);
Kllongjmp(KlNonCaughtErrorJumpPoint, TRU);
}
CFAPPLY(KlFatalError, (1, 0));
}
int
KlMallocErrorDefault(bytes)
int bytes;
{
CFAPPLY(KlFatalError, (2, bytes));
return 0;
}
/* KlErrorHandlerDefault
* the primitive built-in error handler
* only prints the error message
*/
KlO
KlErrorHandlerDefault(argc, argv)
int argc; /* first arg is error code (atom) */
KlO *argv; /* additional datas (Klone objects) */
{
int i;
KlO *args = (KlO *) KlAlloca(argc + 1);
if (argv[0] == (KlO) KlE_BREAK || argv[0] == (KlO) KlE_DBTK_BREAK) {
KlSend_setq(KlA_error_handlers, KlErrorHandlerDefaultSymbol);
return (argc > 1 ? KlSend_eval(argv[1]) : NIL);
}
if (KlIsReadingFile()) {
KlSPrintf(KlStderr, "\"%s\", line ", KlIsReadingFile());
KlSPrintf(KlStderr, "%d: ", Klyylinenoget());
}
KlSPuts(KlErrorMessagePrefix, KlStderr);
args[0] = (KlO) KlStderr;
args[1] = KlSend_eval(argv[0]);
for (i = 1; i < argc; i++) {
args[i + 1] = argv[i];
}
KlPrintFormat(argc + 1, args);
KlSPutc('\n', KlStderr);
{
int actual_ptr;
KlO call;
KlO *vars;
int varsize;
KlO write_args[2];
if (KlStackFrameInfo(0, &call, &actual_ptr, &vars, &varsize) == -1)
return (KlO) KlK_nil;
write_args[0] = call;
write_args[1] = (KlO) KlStderr;
KlWrite(2, write_args);
KlSPutc('\n', KlStderr);
}
stop_if_in_dbx("End of default error handler");
return (KlO) KlK_nil;
}
/* Bootstrap to load in the Klone 'smartloader code */
KlO
KlSmartLoader(argc, argv)
int argc;
KlO *argv;
{
KlO success;
KlAtom errorcode = (KlAtom) argv[0];
if (errorcode != KlE_UNDEFINED_FUNCTION &&
errorcode != KlE_UNDEFINED_VARIABLE)
return (KlO) KlK_nil;
#ifndef ISM
if (NIL == KlLoadSilent(KlA_smartloader)) {
(*KlFatalError)(14, KlA_smartloader->p_name);
}
#else
{
KlAtom KlA_smartloader_file = KlIntern("CL.sml");
if (NIL == KlLoadSilent(KlA_smartloader_file)) {
(*KlFatalError)(14, KlA_smartloader_file->p_name);
}
}
#endif
return KlApplyN(KlA_smartloader, argc, argv); /* and call it */
}
/* (break [expr condition data])
* call error handler before executing expr
* if condition, breaks only if condition evals to true
* data is there just to be passed on stack (with evaluation)
* WARNING: OBSOLETE, please use KlDBTKBreak underneath
* The "break" klone function wil be replaced by something based upon
* dbtk:break in the future
*/
KlO
KlBreak(argc, argv)
int argc;
KlO *argv;
{
KlO expr = argc ? argv[0] : TRU; /* expr defaults to TRU */
KlO res;
if (argc < 2 || (res = KlSend_eval(argv[1]), KlTrueP(res))) {
return KlError3(KlE_BREAK,
expr, /* expression */
(argc >= 2 ? res : TRU), /* condition or t */
/* data or () */
(argc >= 3 ? KlSend_eval(argv[2]) : NIL)
);
}
return KlSend_eval(expr);
}
/* (dbtk:break expr tag data list-of-conditions)
* break version more manageable via code
* call error handler before executing expr
* if any of conditions is true, calls KlE_DBTK_BREAK
* tag not evaluated, must give type of tag
* data is there just to be passed on stack, semantics depens on tag
* expr will be evaluated and returned if error was not treated
* i.e. if the handler returns a correction which is KlE_DBTK_BREAK
* Note: conditions ignored if expr is dbtk:* or (dbtk:* ...)
*/
KlAtom KlA_dbtk_watchpoints;
KlAtom KlA_watch;
KlAtom KlA_dbtk_result;
KlAtom KlA_dbtk_expr;
Int KlIsInDbtkBreak = 0;
KlO
KlDbtkBreak(expr, tag, data, conditions)
KlO expr; /* expr, or 'dbtk:result for retval */
KlO tag;
KlO data; /* the expr to be evaluated */
KlList conditions;
{
if (KlIsInDbtkBreak) { /* do not recurse */
return CFAPPLY(KlUnHookedMethod(expr->type, KlSelEval), (expr));
} else {
KlO res;
KlMustBeList(conditions, 2);
if (conditions->size) {
int i;
int stackptr = KlStackPtr;
KlStackFramePush(1, &KlA_is_in_dbtk_break, NIL, NIL);
KlIsInDbtkBreak = stackptr;
/* if we are in the debugger code, dont check */
if (KlA_is_in_error_handler->c_val == KlA_error_handlers->c_val)
goto eval_expr;
/* test all conditions. raise a break error if one return true */
for (i = 0; i < conditions->size; i++) {
res = KlSend_eval(conditions->list[i]);
if (KlTrueP(res)
&& (!KlIsAString(data) /* skip debug frames */
|| strncmp("dbtk:", ((KlString) data)->string, 5))
&& (!KlIsAList(data)
|| !(((KlList) data)->size)
|| !KlIsAString(((KlList) data)->list[0])
|| strncmp("dbtk:", ((KlString)
(((KlList) data)->list[0]))->string
, 5))) {
KlO p[7];
p[0] = (KlO) KlE_DBTK_BREAK;
p[1] = expr;
p[2] = tag;
p[3] = data;
p[4] = (KlO) conditions;
p[5] = (KlO) KlNumberMake(i);
p[6] = res;
res = _KlError(7, p);
KlStackFramePopNormal(stackptr);
if (res != (KlO) KlE_DBTK_BREAK)
return res;
else
goto eval_expr;
}
}
KlStackFramePopNormal(stackptr);
}
eval_expr:
/* apply eval but bypass hooks once */
if (expr != (KlO) KlA_dbtk_result) {
if (expr != NIL) {
KlStackFramePushUnsetHook();
res = CFAPPLY((KlMethod)
(KlTypeMHooksGet(expr->type)
? KlTypeSlotGet(KlTypeMHooksGet(expr->type),
KlSelEval)
: KlTypeSlotGet(expr->type, KlSelEval)),
(expr));
KlStackFramePopHook();
return res;
} else {
return NIL;
}
} else {
return KlA_dbtk_result->c_val;
}
}
}
/* auxiliary function: exec all watchpoints
* return 1 if must return now, 0 otherwise
* resp is set to the value that must be returned
* resp must point to 0 if this is a pre-cond test, postc-cond otherwise
*/
int
KlDbtkBreak_ExecWatchpoints(expr, tag, data, conditions, resp)
KlO expr;
KlO tag;
KlO data;
KlList conditions;
KlO *resp; /* return result value */
{
KlO res;
int retval = 0;
int postcond = (*resp != 0); /* 0 for precond */
int i;
int stackptr = KlStackPtr;
/* if we are in the debugger code, dont check */
if (KlA_is_in_error_handler->c_val == KlA_error_handlers->c_val)
return 0;
KlStackFramePush(1, &KlA_is_in_dbtk_break, NIL, NIL);
KlIsInDbtkBreak = stackptr;
for (i = 0; i < conditions->size; i++) {
/* test all break conditions */
res = KlSend_eval(conditions->list[i]);
if (KlTrueP(res)
&& (!KlIsAString(expr) /* skip debug frames */
|| strncmp("dbtk:", ((KlString) expr)->string, 5))
&& (!KlIsAList(expr)
|| !(((KlList) expr)->size)
|| !KlIsAString(((KlList) expr)->list[0])
|| strncmp("dbtk:", ((KlString)
(((KlList) expr)->list[0]))->string
, 5))) { /* a condition happened! */
KlO p[9];
p[0] = (KlO) KlE_DBTK_BREAK;
p[1] = expr;
p[2] = tag;
p[3] = data;
p[4] = (KlO) conditions;
p[5] = (KlO) KlNumberMake(i);
p[6] = res;
p[7] = postcond ? TRU : NIL;
p[8] = postcond ? *resp : NIL;
res = _KlError(9, p); /* signal it by raising an error */
KlStackFramePopNormal(stackptr);
if (res != (KlO) KlE_DBTK_BREAK) {
*resp = res; /* debugger forced the return value */
retval = 1;
goto end;
} else {
goto end; /* go eval main expr */
}
}
}
end:
KlStackFramePopNormal(stackptr);
return retval;
}
/* dbtk:runtime-hook-eval
* runtime checker of dbtk watchpoints
* NOTE: since this function is *:mhook -able, it needs to bypass itself if
* KlIsInFrameHook is set. See the implementation of KlSelectorHooker1
* in klone.c. It also need to do a KlStackFramePushSetHook() in the other case
*/
KlAtom KlDbtkRuntimeHookEvalLocalVars[2];
KlO
KlDbtkRuntimeHookEval(expr)
KlO expr;
{
int stackptr;
KlO res;
if (KlIsInFrameHook) { /* in hook code, bypass */
return CFAPPLY(KlUnHookedMethod(expr->type, KlSelEval), (expr));
}
KlStackPtrInHook = KlStackPtr;
KlStackFramePushSpecial(KlSFID_hook, KlIsInFrameHook);
KlIsInFrameHook++;
stackptr = KlStackPtr;
KlStackFramePush(2, KlDbtkRuntimeHookEvalLocalVars, NIL, NIL);
KlDecRefNonNull(KlA_dbtk_result->c_val); /* (setq dbtk:result :nil) */
KlIncRef(KlA_dbtk_result->c_val = (KlO) KlK_nil);
KlDecRefNonNull(KlA_dbtk_expr->c_val); /* (setq dbtk:expr :nil) */
KlIncRef(KlA_dbtk_expr->c_val = (KlO) KlK_nil);
res = KlDbtkBreak(expr, KlA_watch, expr, KlA_dbtk_watchpoints->c_val);
KlDecRefNonNull(KlA_dbtk_result->c_val);
KlIncRef(KlA_dbtk_result->c_val = res);
res = KlDbtkBreak(KlA_dbtk_result, KlA_watch, expr,
KlA_dbtk_watchpoints->c_val);
KlStackFramePopNormal(stackptr);
KlStackFramePopHook();
return res;
}
/******************************************************************************\
Init *
\*****************************************************************************/
/* Initialises application-redefinable error message printing system
*/
KlErrorInit() {
KlList handlers = KlListKl(1, &KlA_error_handlers_orig);
KlErrorCodesInit();
KlMallocError = KlMallocErrorDefault;
KlSend_setq(KlA_error_handlers, handlers);
handlers = KlListKl(1, &KlA_smartloader);
KlSend_setq(KlA_error_correctors, handlers);
KlDeclareSubr(KlSmartLoader, "smartloader", NARY);
KlDeclareFSubr(KlBreak, "break", NARY);
KlDeclareSubr(KlDbtkBreak, "dbtk:break", 4);
KlDeclareFSubr(KlDbtkBreak, "dbtk:breakq", 4);
KlErrorHandlerDefaultSymbol = (KlConstant)
KlDeclareSubr(KlErrorHandlerDefault, "*error-handlers-orig*", NARY);
KlA_is_in_dbtk_break = (KlAtom)
KlActivePointerToIntMake("*is-in-dbtk-break*", &KlIsInDbtkBreak);
KlA_dbtk_watchpoints = KlIntern("dbtk:watchpoints");
KlSend_setq(KlA_dbtk_watchpoints, NIL);
KlA_watch = KlIntern("watch");
KlA_dbtk_result = KlIntern("dbtk:result");
KlSend_setq(KlA_dbtk_result, KlK_nil);
KlA_dbtk_expr = KlIntern("dbtk:expr");
KlSend_setq(KlA_dbtk_expr, KlK_nil);
KlDeclareSubr(KlDbtkRuntimeHookEval, "dbtk:runtime-hook-eval", 1);
KlDbtkRuntimeHookEvalLocalVars[0] = KlA_dbtk_expr;
KlDbtkRuntimeHookEvalLocalVars[1] = KlA_dbtk_result;
KlA_error_handlers_orig->type = KlConstantType;
KlDeclareSubr(_KlError, "error", NARY);
}
syntax highlighted by Code2HTML, v. 0.9.1