/* rlerrors.c
********************************************************************************
* rlerrors.c -- RingLib error handling routines.
*
* Mark Showalter & Neil Heather, PDS Ring-Moon Systems Node, March 1998
*******************************************************************************/
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "ringlib.h"
#include "fortran.h"

/********************
 * Type definitions *
 ********************/

#define RL_ERROR_ID_LEN	31	/* max length of an error id, excluding null */

typedef struct RL_ERRORNODE_STRUCT {
    struct RL_ERRORNODE_STRUCT	*next;
    RL_CHAR			id[RL_ERROR_ID_LEN+1];
    RL_INT4			type;
} RL_ERRORNODE;

/********************
 * Static variables *
 ********************/

#define		ERROR_TYPE_LIST		32
#define		ERROR_TYPE_MASK		31

static RL_ERRORNODE RL_TypeInfo[ERROR_TYPE_LIST] = {
	{NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0},
	{NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0},
	{NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0},
	{NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0},
	{NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0},
	{NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0},
	{NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0},
	{NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}, {NULL, "", 0}};

static RL_ERRORNODE RL_LastError = {NULL, "", 0};
static RL_ERRORNODE RL_TempNode  = {NULL, "", 0};
static FILE         *errfile     = NULL;

/********************************
 * Internal function prototypes *
 ********************************/

static RL_ERRORNODE *ZRL_FindNode   RL_PROTO((RL_CHAR *error_id,
                                              RL_ERRORNODE *top));
static RL_ERRORNODE *ZRL_MakeNode   RL_PROTO((RL_CHAR *error_id,
                                              RL_ERRORNODE *top));
static RL_ERRORNODE *ZRL_UnlinkNode RL_PROTO((RL_CHAR *error_id,
                                              RL_ERRORNODE *top));
static RL_INT4       ZRL_Hash       RL_PROTO((RL_CHAR *error_id));

/*
********************************************************************************
* EXPORTED ROUTINES
********************************************************************************
*$ Component_name:
*	RL_RaiseError (rlerrors.c)
*$ Abstract:
*	This routine raises an error in the manner specified by the error type.
*$ Keywords:
*	RINGLIB, ERRORS
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	void		RL_RaiseError(error_id, message)
*	RL_CHAR		*error_id;
*	RL_CHAR		*message;
*$ Inputs:
*	error_id	string identifying the error category.
*	message 	specific message relating to this particular error.
*$ Outputs:
*	none
*$ Returns:
*	none
*$ Detailed_description:
*	This routine raises an error in the manner specified by the error type.
*	The error may or may not print a message and it may or may not be
*	recorded.  The default action is for the error message to be printed on
*	the stream specified by errfile and for the program to abort.
*
*	The behavior depends on the value of the error_type parameter associated
*	with the error code.  Options are:
*		RL_IGNORE = -1: don't print; don't record in stack.
*		RL_INFORM =  1:       print; don't record in stack.
*		RL_RECORD = -2: don't print;       record in stack.
*		RL_SIGNAL =  2:       print;       record in stack.
*		RL_ABORT  =  3:       print; abort program
*	RL_ABORT is the default behavior.  These constants are defined in the
*	include file ringlib.h.
*$ External_references:
*	none
*$ Side_effects:
*	Depending on the error type, an error may be pushed onto the top of the
*	stack, a message may be printed, and the program may abort.
*$ Examples:
*	This snippet of code raises a "DIV_BY_ZERO" error before the program
*	attempts to divide by zero.
*
*	if (x == 0.) {
*	    RL_RaiseError("DIV_BY_ZERO",
*		"You're attempting to divide by x when x is zero!");
*	    y = 0.;
*	}
*	else {
*	    y = 1. / x;
*	}
*$ Error_handling:
*	No error conditions are raised.  If out of critical memory, the program
*	prints a fatal error message and aborts.
*$ Limitations:
*	Error ids are limited to 31 characters, plus final null character.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

void		RL_RaiseError(error_id, message)
RL_CHAR		*error_id;
RL_CHAR		*message;
{
RL_ERRORNODE	*node;
RL_INT4		type;
RL_BOOL		qprint, qrecord, qabort;
RL_CHAR		*info;

    /* Search error-type tree for matching node */
    node = ZRL_FindNode(error_id, RL_TypeInfo + ZRL_Hash(error_id));

    /* Determine error type */
    if (node == NULL) type = RL_ABORT;		/* the default */
    else              type = node->type;

    /* Decide what to do */
    switch (type) {

    case RL_IGNORE:
	qprint = FALSE; qrecord = FALSE; qabort = FALSE;
	break;

    case RL_INFORM:
	qprint = TRUE;  qrecord = FALSE; qabort = FALSE;
	break;

    case RL_RECORD:
	qprint = FALSE; qrecord = TRUE;  qabort = FALSE;
	break;

    case RL_SIGNAL:
	qprint = TRUE;  qrecord = TRUE;  qabort = FALSE;
	break;

    case RL_ABORT:
    default:
	qprint = TRUE;  qrecord = FALSE; qabort = TRUE;
	break;
    }

    /* Record error condition if necessary */
    if (qrecord) {
	ZRL_MakeNode(error_id, &RL_LastError);
    }

    /* Print message if necessary */
    if (qprint) {
	if (qabort)       info = "fatal";
	else if (qrecord) info = "error";
	else              info = "warning";

	if (errfile == NULL)
	    fprintf(stderr,  "%s (%s): %s\n", error_id, info, message);
	else
	    fprintf(errfile, "%s (%s): %s\n", error_id, info, message);
    }

    /* Abort program if necessary */
    if (qabort) {
	exit(1);
    }
}

/*
********************************************************************************
*$ Component_name:
*	RL_PipeErrors (rlerrors.c)
*$ Abstract:
*	This routine changes the file into which error messages are placed.  By
*	default, error messages are displayed on the "stderr" stream.
*$ Keywords:
*	RINGLIB, ERRORS
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	void		RL_PipeErrors(filename)
*	RL_CHAR		*filename;
*$ Inputs:
*	filename	file where error messages are to be recorded.  Use blank
*			or NULL to direct messages back to "stderr".
*$ Outputs:
*	none
*$ Returns:
*	none
*$ Detailed_description:
*	This routine changes the file into which error messages are placed.  By
*	default, error messages are displayed on the "stderr" stream.
*$ External_references:
*	none
*$ Side_effects:
*	A file is opened if necessary.
*$ Examples:
*	This sends future error messages to file "errors.lis":
*		RL_PipeErrors("errors.lis");
*	This redirects future error messages to the terminal:
*		RL_PipeErrors(NULL);
*	or
*		RL_PipeErrors("");
*$ Error_handling:
*	RingLib error handling is in effect.  Conditions raised:
*	RL_OPEN_FAILURE		if file could not be opened for writing; in
*				this case stderr is used for this and future
*				messages.
*$ Limitations:
*	none
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

void	RL_PipeErrors(filename)
RL_CHAR	*filename;
{
    /* Close current error file if necessary */
    if (errfile != NULL) {
	fclose(errfile);
        errfile = NULL;
    }

    /* Open new error file if necessary */
    if (filename == NULL || filename[0] == '\0') {
	errfile = NULL;
    } else {
	errfile = fopen(filename, "w+t");
	if (errfile == NULL) {
	    RL_RaiseError("RL_OPEN_FAILURE", "unable to open error file");
	}
    }
}

/*
********************************************************************************
*$ Component_name:
*	RL_TestError (rlerrors.c)
*$ Abstract:
*	This routine tests for the presence of an error on the top of the error
*	stack and returns a pointer to the error_id string.  It does not modify
*	the error stack.
*$ Keywords:
*	RINGLIB, ERRORS
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	RL_CHAR	*RL_TestError(void)
*$ Inputs:
*	none
*$ Outputs:
*	none
*$ Returns:
*	pointer (read-only) to a string containing the error id, or NULL if no
*	error condition has been raised.
*$ Detailed_description:
*	This routine tests for the presence of an error on the top of the error
*	stack and returns a pointer to the error_id string.  If it does not find
*	an error, it returns a NULL.  It does not modify the error stack.
*$ External_references:
*	none
*$ Side_effects:
*	none
*$ Examples:
*	Suppose you call a routine Math() that might raise errors "DIV_BY_ZERO"
*	or "SQRT_NEGATIVE".  You wish to print your own error message if either
*	of these errors occurred, and then to remove them from the error stack.
*
*	RL_SetErrorType("DIV_BY_ZERO", RL_RECORD);
*	RL_SetErrorType("SQRT_NEGATIVE", RL_RECORD);
*	Math();
*	if (RL_TestError() != NULL) {
*	    printf("Error %s occurred!\n", RL_ClearError());
*	}
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters, plus final null character.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

RL_CHAR	*RL_TestError()
{
    if (RL_LastError.next == NULL)	/* stack is empty */
	return NULL;
    else
	return (RL_LastError.next->id);
}

/*
********************************************************************************
*$ Component_name:
*	RL_ClearError (rlerrors.c)
*$ Abstract:
*	This routine removes the most recent error from the top of the error
*	stack and returns a pointer to the error_id string.
*$ Keywords:
*	RINGLIB, ERRORS
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	RL_CHAR	*RL_ClearError(void)
*$ Inputs:
*	none
*$ Outputs:
*	none
*$ Returns:
*	pointer (read-only) to a string containing the error id, or NULL if no
*	error condition has been raised.
*$ Detailed_description:
*	This routine removes the most recent error from the top of the error
*	stack and returns a pointer to the error_id string.  If it does not find
*	an error, it returns a NULL.
*$ External_references:
*	none
*$ Side_effects:
*	The first error is removed from the stack and freed.
*$ Examples:
*	Suppose you call a routine Math() that might raise errors "DIV_BY_ZERO"
*	or "SQRT_NEGATIVE".  You wish to print your own error message if either
*	of these errors occurred, and then to remove them from the error stack.
*
*	RL_SetErrorType("DIV_BY_ZERO", RL_RECORD);
*	RL_SetErrorType("SQRT_NEGATIVE", RL_RECORD);
*	Math();
*	if (RL_TestError() != NULL) {
*	    printf("Error %s occurred!\n", RL_ClearError());
*	}
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters, plus final null character.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

RL_CHAR *RL_ClearError()
{
RL_ERRORNODE *top;

    /* If stack is empty, return NULL */
    if (RL_LastError.next == NULL) return NULL;

    /* Otherwise pop stack and return error id */
    top = RL_LastError.next;				/* save top pointer */
    RL_TempNode = *top;					/* copy top node */
    RL_LastError.next = RL_LastError.next->next;	/* unlink */
    XRL_Free(top);					/* free */
    return RL_TempNode.id;				/* return id pointer */
}

/*
********************************************************************************
*$ Component_name:
*	RL_TestError1 (rlerrors.c)
*$ Abstract:
*	This routine tests for the presence of a particular error on the error
*	stack.  If returns TRUE if it is found and FALSE otherwise.
*$ Keywords:
*	RINGLIB, ERRORS
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	RL_BOOL		RL_TestError1(error_id)
*	RL_CHAR		*error_id;
*$ Inputs:
*	error_id	pointer to a string containing the error id.
*$ Outputs:
*	none
*$ Returns:
*	TRUE if the error was found on the stack; FALSE otherwise.
*$ Detailed_description:
*	This routine tests for the presence of a particular error on the error
*	stack.  If returns TRUE if it is found and FALSE otherwise.  It does not
*	modify the error stack.
*$ External_references:
*	none
*$ Side_effects:
*	none
*$ Examples:
*	Suppose you call a routine Math() that might raise error "DIV_BY_ZERO".
*	You wish to print your own error message if this occurs, and then leave
*	it on the error stack for another routine to check.
*
*	RL_SetErrorType("DIV_BY_ZERO", RL_RECORD);
*	Math();
*	if (RL_TestError1("DIV_BY_ZERO")) {
*	    printf("You tried to divide by zero!\n");
*	}
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters, plus final null character.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

RL_BOOL		RL_TestError1(error_id)
RL_CHAR		*error_id;
{
RL_ERRORNODE	*node;

    node = ZRL_FindNode(error_id, &RL_LastError);

    if (node == NULL) return FALSE;
    else              return TRUE;
}

/*
********************************************************************************
*$ Component_name:
*	RL_ClearError1 (rlerrors.c)
*$ Abstract:
*	This routine removes a particular error from the error stack.  It
*	returns TRUE if the error was found and FALSE otherwise.
*$ Keywords:
*	RINGLIB, ERRORS
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	RL_BOOL		RL_ClearError1(error_id)
*	RL_CHAR		*error_id;
*$ Inputs:
*	error_id	pointer to a string containing the error id.
*$ Outputs:
*	none
*$ Returns:
*	TRUE if the error was found; FALSE otherwise.
*$ Detailed_description:
*	This routine removes a particular error from the error stack.  It
*	returns TRUE if the error was found and FALSE otherwise.
*$ External_references:
*	none
*$ Side_effects:
*	An error may be removed from the stack and freed.
*$ Examples:
*	Suppose you call a routine Math() that might raise error "DIV_BY_ZERO".
*	You wish to print your own error message if this occurs, and then
*	remove it from the error stack.
*
*	RL_SetErrorType("DIV_BY_ZERO", RL_RECORD);
*	Math();
*	if (RL_ClearError1("DIV_BY_ZERO")) {
*	    printf("You tried to divide by zero!\n");
*	}
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters, plus final null character.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

RL_BOOL		RL_ClearError1(error_id)
RL_CHAR		*error_id;
{
RL_ERRORNODE	*node;

    /* Find the desired node and unlink it from the stack */
    node = ZRL_UnlinkNode(error_id, &RL_LastError);

    /* If the node was not found, return FALSE */
    if (node == NULL) return FALSE;

    /* Otherwise, free it and return TRUE */
    XRL_Free(node);
    return TRUE;
}

/*
********************************************************************************
*$ Component_name:
*	RL_SetErrorType (rlerrors.c)
*$ Abstract:
*	This routine sets the type for a particular error.  It also returns the
*	current value of the error type.
*$ Keywords:
*	RINGLIB, ERRORS
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	RL_INT4		RL_SetErrorType(error_id, error_type)
*	RL_CHAR		*error_id;
*	RL_INT4		error_type;
*$ Inputs:
*	error_id	string identifying the error id.
*	error_type	value indicating how the error is to be handled.
*			Options are:
*			    RL_IGNORE = -1: don't print; don't record in stack.
*			    RL_INFORM =  1:       print; don't record in stack.
*			    RL_RECORD = -2: don't print;       record in stack.
*			    RL_SIGNAL =  2:       print;       record in stack.
*			    RL_ABORT  =  3:       print; abort program
*			These constants are defined in the include file
*			ringlib.h.
*$ Outputs:
*	none
*$ Returns:
*	the previous error_type for this error_id.
*$ Detailed_description:
*	This routine sets the type for a particular error.  It also returns the
*	current value of the error type.
*
*	The error type controls what happens when RL_RaiseError() is called.
*	Error type values are:
*		RL_IGNORE = -1: don't print; don't record in stack.
*		RL_INFORM =  1:       print; don't record in stack.
*		RL_RECORD = -2: don't print;       record in stack.
*		RL_SIGNAL =  2:       print;       record in stack.
*		RL_ABORT  =  3:       print; abort program
*	RL_ABORT is the default behavior.  These constants are defined in the
*	include file ringlib.h.
*$ External_references:
*	none
*$ Side_effects:
*	Depending on the error type, an error may be removed from the stack and
*	freed.
*$ Examples:
*	Suppose you wish to change temporarily the method a program uses to
*	handle DIV_BY_ZERO errors to RL_RECORD, and then to restore it to the
*	previous method when you're done.
*
*	RL_INT4		old_type;
*
*	old_type = RL_SetErrorType("DIV_BY_ZERO", RL_RECORD);
*	... (DIV_BY_ZERO is now set to record)
*	RL_SetErrorType("DIV_BY_ZERO", old_type);
*	... (previous type of DIV_BY_ZERO is restored)
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters, plus final null character.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

RL_INT4		RL_SetErrorType(error_id, error_type)
RL_CHAR		*error_id;
RL_INT4		error_type;
{
RL_ERRORNODE	*node;
RL_INT4		save_type;

    /* On ABORT, free node */
    if (error_type == RL_ABORT) {
	node = ZRL_UnlinkNode(error_id, RL_TypeInfo + ZRL_Hash(error_id));
	if (node == NULL) {
	    save_type = RL_ABORT;
	} else {
	    save_type = node->type;
	    XRL_Free((RL_VOID *) node);
	}

    /* Otherwise, modify node */
    } else {
	node = ZRL_MakeNode(error_id, RL_TypeInfo + ZRL_Hash(error_id));
	save_type = node->type;
	node->type = error_type;
    }

    return save_type;
}

/*
********************************************************************************
*$ Component_name:
*	RL_GetErrorType (rlerrors.c)
*$ Abstract:
*	This routine returns the error type for a particular error id.
*$ Keywords:
*	RINGLIB, ERRORS
*	C, PUBLIC, SUBROUTINE
*$ Declarations:
*	RL_INT4		RL_GetErrorType(error_id)
*	RL_CHAR		*error_id;
*$ Inputs:
*	error_id	string identifying the error id.
*$ Outputs:
*	none
*$ Returns:
*	the error type for the given error id.
*$ Detailed_description:
*	This routine returns the error type for a particular error id.
*
*	The error type controls what happens when RL_RaiseError() is called.
*	Error type values are:
*		RL_IGNORE = -1: don't print; don't record in stack.
*		RL_INFORM =  1:       print; don't record in stack.
*		RL_RECORD = -2: don't print;       record in stack.
*		RL_SIGNAL =  2:       print;       record in stack.
*		RL_ABORT  =  3:       print; abort program
*	RL_ABORT is the default behavior.  These constants are defined in the
*	include file ringlib.h.
*$ External_references:
*	none
*$ Side_effects:
*	none
*$ Examples:
*	Suppose you call a routine Math() that might raise error "DIV_BY_ZERO".
*	Without changing the type of this error permanently, you wish to make
*	sure a message is printed.
*
*	RL_INT4		old_type;
*
*	old_type = RL_GetErrorType("DIV_BY_ZERO");
*	if (old_type < 0) RL_SetErrorType("DIV_BY_ZERO", -old_type);
*	Math();
*	RL_SetErrorType("DIV_BY_ZERO", old_type);
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters, plus final null character.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
*******************************************************************************/

RL_INT4		RL_GetErrorType(error_id)
RL_CHAR		*error_id;
{
RL_ERRORNODE	*node;

    node = ZRL_FindNode(error_id, RL_TypeInfo + ZRL_Hash(error_id));

    if (node == NULL) return RL_ABORT;
    else              return node->type;
}

/*
********************************************************************************
* INTERNAL ROUTINES
********************************************************************************
* RL_ERRORNODE *ZRL_FindNode(error_id, top)
*
* This internal function finds the node with matching error_id in a linked list
* of error nodes.
*
* Input:
*	error_id	error id to find in list.
*	top		pointer to a node whose "next" field points to the first
*			entry in list.
*
* Return:		pointer to the error node, or NULL if it was not found.
*******************************************************************************/

static RL_ERRORNODE *ZRL_FindNode(error_id, top)
RL_CHAR		*error_id;
RL_ERRORNODE	*top;
{
int		index;
RL_ERRORNODE	*node;

    /* Walk down list looking for matching node */
    for(node = top->next; node != NULL; node = node->next)
	if (strcmp(error_id, node->id) == 0) return node;

    /* If not found, return NULL */
    return NULL;
}

/*
********************************************************************************
* RL_ERRORNODE *ZRL_MakeNode(error_id, top)
*
* This internal function finds the node with matching error_id in a linked list
* of error nodes.  If it does not find a matching node, it creates one and
* adds it to the list.
*
* Input:
*	error_id	error id to find in list.
*	top		pointer to a node whose "next" field points to the first
*			entry in list.
*
* Return:		pointer to the error node.
*******************************************************************************/

static RL_ERRORNODE *ZRL_MakeNode(error_id, top)
RL_CHAR		*error_id;
RL_ERRORNODE	*top;
{
RL_ERRORNODE	*node, *root;

    /* Look for node and return it if found */
    node = ZRL_FindNode(error_id, top);
    if (node != NULL) return node;

    /* Allocate a new node and put it at top of list
     * Note that there is danger of infinite recursion here; if XRL_Malloc()
     * fails but RL_MEMORY_ERROR is set to record without aborting, then it will
     * recursively call this same routine ad infinitum.  We therefore abort if
     * this allocation fails. */
    node = (RL_ERRORNODE *) XRL_MustAlloc(sizeof(RL_ERRORNODE));

    node->next = top->next;
    top->next = node;

    /* Initialize node */
    strncpy(node->id, error_id, RL_ERROR_ID_LEN);
    node->id[RL_ERROR_ID_LEN] = '\0';		/* ensure null termination */
    node->type = RL_ABORT;

    return node;
}

/*
********************************************************************************
* RL_ERRORNODE *ZRL_UnlinkNode(error_id, top)
*
* This internal function finds the node giving error type for the specified
* error id.  If found, the node is removed from the linked list.
*
* Input:
*	error_id	error id to find in list.
*	top		pointer to a node whose "next" field points to the first
*			entry in list.
*
* Return:		pointer to the error node, or NULL if it is not found.
*
* Side effects:		node is unlinked from the list but is not freed.
*******************************************************************************/

static RL_ERRORNODE *ZRL_UnlinkNode(error_id, top)
RL_CHAR		*error_id;
RL_ERRORNODE	*top;
{
RL_ERRORNODE	*parent, *node;

    /* Walk down list looking for matching node */
    for (parent = top; parent->next != NULL; parent = parent->next) {

	if (strcmp(error_id, parent->next->id) == 0) {

	    /* Unlink node and return it */
	    node = parent->next;
	    parent->next = node->next;
	    return node;
	}
    }

    /* Node was not found */
    return NULL;
}

/*
********************************************************************************
* ZRL_Hash(error_id)
*
* This internal function calculates a quick hash value between 0 and 31 based on
* the given error id string.
*
* Inputs:
*	error_id	error id.
*
* Return:		pointer to the error node, or NULL if it is not found.
*
* Side effects:		node is unlinked from the list but is not freed.
*******************************************************************************/

static RL_INT4	ZRL_Hash(error_id)
RL_CHAR		*error_id;
{
RL_INT4		hash, i;

    hash = 0;
    for (i = 0; i < 8; i++) {
	if (error_id[i] == '\0') break;
	hash = 5*hash + (RL_INT4) error_id[i];
    }

    return (hash & ERROR_TYPE_MASK);
}

/*
********************************************************************************
* FORTRAN INTERFACE ROUTINES
********************************************************************************
*$ Component_name:
*	FRL_RaiseError (rlerrors.c, fringlib.for)
*$ Abstract:
*	This routine raises an error in the manner specified by the error type.
*$ Keywords:
*	RINGLIB, ERRORS
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	subroutine FRL_RaiseError(error_id, message)
*	character*(*)	error_id, message
*$ Inputs:
*	error_id	string identifying the error id.
*	message 	specific message relating to this particular error.
*$ Outputs:
*	none
*$ Returns:
*	none
*$ Detailed_description:
*	This routine raises an error in the manner specified by the error type.
*	The error may or may not print a message and it may or may not be
*	recorded.  The default action is for the error message to be printed on
*	the stream specified by errfile and for the program to abort.
*
*	The behavior depends on the value of the error_type parameter associated
*	with the error code.  Options are:
*		RL_IGNORE = -1: don't print; don't record in stack.
*		RL_INFORM =  1:       print; don't record in stack.
*		RL_RECORD = -2: don't print;       record in stack.
*		RL_SIGNAL =  2:       print;       record in stack.
*		RL_ABORT  =  3:       print; abort program
*	RL_ABORT is the default behavior.  These constants are defined in the
*	include file ringlib.h.
*$ External_references:
*	none
*$ Side_effects:
*	Depending on the error type, an error may be pushed onto the top of the
*	stack, a message may be printed, and the program may abort.
*$ Examples:
*	This snippet of code raises a "DIV_BY_ZERO" error before the program
*	attempts to divide by zero.
*
*	if (x .eq. 0.) then
*	    call FRL_RaiseError('DIV_BY_ZERO',
*		'You're attempting to divide by x when x is zero!')
*	    y = 0.
*	else
*	    y = 1. / x
*	end if
*$ Error_handling:
*	No error conditions are raised.  If out of critical memory, the program
*	prints a fatal error message and aborts.
*$ Limitations:
*	Error ids are limited to 31 characters; messages are limited to 255
*	characters.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
********************************************************************************
* Note: GRL_RaiseError() defined here is the intermediary routine between
* FRL_RaiseError() and RL_RaiseError(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C.  See fringlib.for for the
* rest of the code.
*
* subroutine GRL_RaiseError(error_id, message)
* byte		error_id(*), message(*)
*******************************************************************************/

void	FORTRAN_NAME(grl_raiseerror) (error_id, message)
RL_CHAR	*error_id, *message;
{
    RL_RaiseError(error_id, message);
}

/*
********************************************************************************
*$ Component_name:
*	FRL_PipeErrors (rlerrors.c, fringlib.for)
*$ Abstract:
*	This routine changes the file into which error messages are placed.  By
*	default, error messages are displayed on the terminal.
*$ Keywords:
*	RINGLIB, ERRORS
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	subroutine FRL_PipeErrors(filename)
*	character*(*)	filename
*$ Inputs:
*	filename	file where error messages are to be recorded.  Use a
*			blank string to direct messages back to the terminal.
*$ Outputs:
*	none
*$ Returns:
*	none
*$ Detailed_description:
*	This routine changes the file into which error messages are placed.  By
*	default, error messages are displayed on the terminal.
*$ External_references:
*	none
*$ Side_effects:
*	A file is opened if necessary.
*$ Examples:
*	This sends future error messages to file "errors.lis":
*		call FRL_PipeErrors('errors.lis')
*	This redirects future error messages to the terminal:
*		call FRL_PipeErrors(' ')
*$ Error_handling:
*	RingLib error handling is in effect.  Conditions raised:
*	RL_OPEN_FAILURE		if file could not be opened for writing; in
*				this case the terminal is used for this and
*				future messages.
*$ Limitations:
*	File names are limited to 255 characters.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
********************************************************************************
* Note: GRL_PipeErrors() defined here is the intermediary routine between
* FRL_PipeErrors() and RL_PipeErrors(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C.  See fringlib.for for the
* rest of the code.
*
* subroutine GRL_PipeErrors(filename)
* byte		filename(*)
*******************************************************************************/

void	FORTRAN_NAME(grl_pipeerrors) (filename)
RL_CHAR *filename;
{
    RL_PipeErrors(filename);
}

/*
********************************************************************************
*$ Component_name:
*	FRL_TestError (rlerrors.c, fringlib.for)
*$ Abstract:
*	This routine tests for the presence of an error on the top of the error
*	stack and returns the error_id string.
*$ Keywords:
*	RINGLIB, ERRORS
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	logical*4 function FRL_TestError(error_id)
*	character*(*)	error_id
*$ Inputs:
*	none
*$ Outputs:
*	error_id	string containing the error id, or blank if no error
*			condition is found.
*$ Returns:
*	.TRUE. if an error condition was found on the stack; .FALSE. otherwise.
*$ Detailed_description:
*	This routine tests for the presence of an error on the top of the error
*	stack and returns the error_id string.  If it does not find an error, it
*	returns a blank string.  It does not modify the error stack.  It also
*	returns .TRUE. if an error was found and .FALSE. otherwise.
*$ External_references:
*	none
*$ Side_effects:
*	none
*$ Examples:
*	Suppose you call a routine Math() that might raise errors "DIV_BY_ZERO"
*	or "SQRT_NEGATIVE".  You wish to print your own error message if either
*	of these errors occurred, and then to remove them from the error stack.
*
*	character*40	id
*
*	call FRL_SetErrorType('DIV_BY_ZERO', RL_RECORD)
*	call FRL_SetErrorType('SQRT_NEGATIVE', RL_RECORD)
*	call Math()
*	if (FRL_TestError(id)) then
*	    write(*,*) 'Error ', id, ' occurred!'
*	    call FRL_ClearError(id)
*	end if
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
********************************************************************************
* Note: GRL_TestError() defined here is the intermediary routine between
* FRL_TestError() and RL_TestError(), allowing for the fact that strings cannot
* be passed directly between FORTRAN and C.  See fringlib.for for the rest of
* the code.
*
* logical*4 function GRL_TestError(buffer, lbuffer)
* byte		buffer(*)
* integer*4	lbuffer
*******************************************************************************/

RL_INT4 FORTRAN_NAME(grl_testerror) (buffer, lbuffer)
RL_CHAR *buffer;
RL_INT4 *lbuffer;
{
RL_CHAR	*error_id;

    error_id = RL_TestError();

    if (error_id == NULL) {
	buffer[0] = '\0';
	return FFALSE;
    }

    strncpy(buffer, error_id, *lbuffer-1);
    buffer[*lbuffer-1] = '\0';

    return FTRUE;
}

/*
********************************************************************************
*$ Component_name:
*	FRL_ClearError (rlerrors.c, fringlib.for)
*$ Abstract:
*	This routine removes the most recent error from the top of the error
*	stack and returns the error_id string.
*$ Keywords:
*	RINGLIB, ERRORS
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	logical*4 function FRL_ClearError(error_id)
*	character*(*)	error_id
*$ Inputs:
*	none
*$ Outputs:
*	error_id	string containing the error id, or blank if no error
*			condition was found.
*$ Returns:
*	.TRUE. if an error condition was found on the stack; .FALSE. otherwise.
*$ Detailed_description:
*	This routine removes the most recent error from the top of the error
*	stack and returns the error_id string.  If it does not find an error,
*	it returns a blank string.  It also returns .TRUE. if an error was
*	found and .FALSE. otherwise.
*$ External_references:
*	none
*$ Side_effects:
*	The first error is removed from the stack and freed.
*$ Examples:
*	Suppose you call a routine Math() that might raise errors "DIV_BY_ZERO"
*	or "SQRT_NEGATIVE".  You wish to print your own error message if either
*	of these errors occurred, and then to remove them from the error stack.
*
*	character*40	id
*
*	call FRL_SetErrorType('DIV_BY_ZERO', RL_RECORD)
*	call FRL_SetErrorType('SQRT_NEGATIVE', RL_RECORD)
*	call Math()
*	if (FRL_TestError(id)) then
*	    write(*,*) 'Error ', id, ' occurred!'
*	    call FRL_ClearError(id)
*	end if
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
********************************************************************************
* Note: GRL_ClearError() defined here is the intermediary routine between
* FRL_ClearError() and RL_ClearError(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C.  See fringlib.for for the
* rest of the code.
*
* logical*4 function GRL_ClearError(buffer, lbuffer)
* byte		buffer(*)
* integer*4	lbuffer
*******************************************************************************/

RL_INT4 FORTRAN_NAME(grl_clearerror) (buffer, lbuffer)
RL_CHAR *buffer;
RL_INT4 *lbuffer;
{
RL_CHAR	*error_id;

    error_id = RL_ClearError();

    if (error_id == NULL) {
	buffer[0] = '\0';
	return FFALSE;
    }

    strncpy(buffer, error_id, *lbuffer-1);
    buffer[*lbuffer-1] = '\0';

    return FTRUE;
}

/*
********************************************************************************
*$ Component_name:
*	FRL_TestError1 (rlerrors.c, fringlib.for)
*$ Abstract:
*	This routine tests for the presence of a particular error on the error
*	stack.  It returns .TRUE. if it is found and .FALSE. otherwise.
*$ Keywords:
*	RINGLIB, ERRORS
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	logical*4 function FRL_TestError1(error_id)
*	character*(*)	error_id
*$ Inputs:
*	error_id	string containing the error id to test.
*$ Outputs:
*	none
*$ Returns:
*	.TRUE. if the error was found on the stack; .FALSE. otherwise.
*$ Detailed_description:
*	This routine tests for the presence of a particular error on the error
*	stack.  It returns .TRUE. if it is found and .FALSE. otherwise.  It does
*	not modify the error stack.
*$ External_references:
*	none
*$ Side_effects:
*	none
*$ Examples:
*	Suppose you call a routine Math() that might raise error "DIV_BY_ZERO".
*	You wish to print your own error message if this occurs, and then leave
*	it on the error stack for another routine to check.
*
*	call FRL_SetErrorType('DIV_BY_ZERO', RL_RECORD)
*	call Math()
*	if (FRL_TestError1('DIV_BY_ZERO')) then
*	    write(*,*) 'You tried to divide by zero!'
*	end if
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
********************************************************************************
* Note: GRL_TestError1() defined here is the intermediary routine between
* FRL_TestError1() and RL_TestError1(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C.  See fringlib.for for the
* rest of the code.
*
* logical*4 function GRL_TestError1(error_id)
* byte		error_id(*)
*******************************************************************************/

RL_INT4 FORTRAN_NAME(grl_testerror1) (error_id)
RL_CHAR *error_id;
{
    return (RL_TestError1(error_id) ? FTRUE : FFALSE);
}

/*
********************************************************************************
*$ Component_name:
*	FRL_ClearError1 (rlerrors.c, fringlib.for)
*$ Abstract:
*	This routine removes a particular error from the error stack, if found.
*	It returns .TRUE. if the error was found and .FALSE. otherwise.
*$ Keywords:
*	RINGLIB, ERRORS
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	logical*4 function FRL_ClearError1(error_id)
*	character*(*)	error_id
*$ Inputs:
*	error_id	string containing the error id to clear.
*$ Outputs:
*	none
*$ Returns:
*	.TRUE. if the error was found; .FALSE. otherwise.
*$ Detailed_description:
*	This routine removes a particular error from the error stack, if found.
*	It returns .TRUE. if the error was found and .FALSE. otherwise.
*$ External_references:
*	none
*$ Side_effects:
*	An error may be removed from the stack and freed.
*$ Examples:
*	Suppose you call a routine Math() that might raise error "DIV_BY_ZERO".
*	You wish to print your own error message if this occurs, and then
*	remove this error from the stack.
*
*	call FRL_SetErrorType('DIV_BY_ZERO', RL_RECORD)
*	call Math()
*	if (FRL_ClearError1('DIV_BY_ZERO')) then
*	    write(*,*) 'You tried to divide by zero!'
*	end if
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
********************************************************************************
* Note: GRL_ClearError1() defined here is the intermediary routine between
* FRL_ClearError1() and RL_ClearError1(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C.  See fringlib.for for the
* rest of the code.
*
* logical*4 function GRL_ClearError1(error_id)
* byte		error_id(*)
*******************************************************************************/

RL_INT4 FORTRAN_NAME(grl_clearerror1) (error_id)
RL_CHAR *error_id;
{
    return (RL_ClearError1(error_id) ? FTRUE : FFALSE);
}

/*
********************************************************************************
*$ Component_name:
*	FRL_SetErrorType (rlerrors.c, fringlib.for)
*$ Abstract:
*	This routine sets the type for a particular error.  It also returns the
*	current value of the error type.
*$ Keywords:
*	RINGLIB, ERRORS
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
*	integer*4 function FRL_SetErrorType(error_id, error_type)
*	character*(*)	error_id
*	integer*4	error_type
*$ Inputs:
*	error_id	string identifying the error id.
*	error_type	value indicating how the error is to be handled.
*$ Outputs:
*	none
*$ Returns:
*	the previous error_type for this error_id.
*$ Detailed_description:
*	This routine sets the type for a particular error.  It also returns the
*	current value of the error type.
*
*	The error type controls what happens when RL_RaiseError() is called.
*	Error type values are:
*		RL_IGNORE = -1: don't print; don't record in stack.
*		RL_INFORM =  1:       print; don't record in stack.
*		RL_RECORD = -2: don't print;       record in stack.
*		RL_SIGNAL =  2:       print;       record in stack.
*		RL_ABORT  =  3:       print; abort program
*	RL_ABORT is the default behavior.  These constants are defined in the
*	include file ringlib.h.
*$ External_references:
*	none
*$ Side_effects:
*	Depending on the error type, an error may be removed from the stack and
*	freed.
*$ Examples:
*	Suppose you wish to change temporarily the method a program uses to
*	handle DIV_BY_ZERO errors to RL_RECORD, and then to restore it to the
*	previous method when you're done.
*
*	integer*4	old_type
*
*	old_type = FRL_SetErrorType('DIV_BY_ZERO', RL_RECORD)
*	... (DIV_BY_ZERO is now set to record)
*
*	call FRL_SetErrorType('DIV_BY_ZERO', old_type)
*	... (previous type of DIV_BY_ZERO is restored)
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
********************************************************************************
* Note: GRL_SetErrorType() defined here is the intermediary routine between
* FRL_SetErrorType() and RL_SetErrorType(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C.  See fringlib.for for the
* rest of the code.
*
* integer*4 function GRL_SetErrorType(error_id, error_type)
* byte		error_id(*)
* integer*4	error_type
*******************************************************************************/

RL_INT4 FORTRAN_NAME(grl_seterrortype) (error_id, error_type)
RL_CHAR *error_id;
RL_INT4 *error_type;
{
	return RL_SetErrorType(error_id, *error_type);
}

/*
********************************************************************************
*$ Component_name:
*	FRL_GetErrorType (rlerrors.c, fringlib.for)
*$ Abstract:
*	This routine returns the error type for a particular error id.
*$ Keywords:
*	RINGLIB, ERRORS
*	FORTRAN, PUBLIC, SUBROUTINE
*$ Declarations:
	integer*4 function FRL_GetErrorType(error_id)
	character*(*)	error_id
*$ Inputs:
*	error_id	string identifying the error id.
*$ Outputs:
*	none
*$ Returns:
*	the error type for the given error id.
*$ Detailed_description:
*	This routine returns the error type for a particular error id.
*
*	The error type controls what happens when RL_RaiseError() is called.
*	Error type values are:
*		RL_IGNORE = -1: don't print; don't record in stack.
*		RL_INFORM =  1:       print; don't record in stack.
*		RL_RECORD = -2: don't print;       record in stack.
*		RL_SIGNAL =  2:       print;       record in stack.
*		RL_ABORT  =  3:       print; abort program
*	RL_ABORT is the default behavior.  These constants are defined in the
*	include file ringlib.h.
*$ External_references:
*	none
*$ Side_effects:
*	none
*$ Examples:
*	Suppose you call a routine Math() that might raise error "DIV_BY_ZERO".
*	Without changing the type of this error permanently, you wish to make
*	sure a message is printed.
*
*	integer*4	old_type
*
*	old_type = FRL_GetErrorType('DIV_BY_ZERO')
*	if (old_type .lt. 0) call FRL_SetErrorType('DIV_BY_ZERO', -old_type)
*	call Math()
*	call FRL_SetErrorType('DIV_BY_ZERO', old_type)
*$ Error_handling:
*	No error conditions are raised.
*$ Limitations:
*	Error ids are limited to 31 characters.
*$ Author_and_institution:
*	Mark R. Showalter
*	NASA/Ames Research Center
*$ Version_and_date:
*	1.0: March 1998
*$ Change_history:
*	none
********************************************************************************
* Note: GRL_GetErrorType() defined here is the intermediary routine between
* FRL_GetErrorType() and RL_GetErrorType(), allowing for the fact that strings
* cannot be passed directly between FORTRAN and C.  See fringlib.for for the
* rest of the code.
*
* integer*4 function GRL_GetErrorType(error_id)
* byte		error_id(*)
*******************************************************************************/

RL_INT4 FORTRAN_NAME(grl_geterrortype) (error_id)
RL_CHAR *error_id;
{
	return RL_GetErrorType(error_id);
}

/*******************************************************************************
*/