void
__f90_bounds_check(char *procedure_name, _f_int4 line_number, char *array_name, _f_int4 axis_number)
{
char *unknown_nm = "name_unknown";
char *abort_now = NULL;
char *rtn_nm = "__f90_bounds_check";
/* note mips f90 compiler appends extra characters at
* the end of the procedure name.
*/
/* MIPSpro 7.2 and 7.2.1 documentation assumed that the
* routine would abort if this environment variable is
* is set. Otherwise, the message is just a warning.
*/
abort_now = getenv("F90_BOUNDS_CHECK_ABORT");
if (abort_now) {
if (*abort_now == 'y' || *abort_now == 'Y') {
if (array_name) {
(void) _lerror(_LELVL_MSG, FWARGSVB,
axis_number, array_name, line_number,
procedure_name, rtn_nm);
} else {
(void) _lerror(_LELVL_MSG, FWARGSVB,
axis_number, unknown_nm, line_number,
procedure_name, rtn_nm);
}
/* cleanup the fortran units before abort */
_fcleanup();
abort();
}
}
if (array_name)
(void) _fwarn(FWARGSVB,axis_number, array_name,
line_number, procedure_name, rtn_nm);
else
(void) _fwarn(FWARGSVB,axis_number, unknown_nm,
line_number, procedure_name, rtn_nm);
return;
}
/*
* Error handler for an array syntax conformance warning.
* This entry is called by the f90 compiler on IRIX only.
*
* Input Arguments:
* file - File name in which error occurred.
* line - Line number in file.
* dim - Dimension number which has a size mismatch.
* extent1 - One of two mismatched 64-bit extents of dimension dim.
* extent2 - One of two mismatched 64-bit extents of dimension dim.
*
* ON MIPS, if the environment varaiable is set to Y(ES), produce an
* error message with the information and then abort. Otherwise,
* produce a warning for the conformity check.
*
* When the input dimension is zero, this routine is being called
* from an inline version of a transformational function such as
* MATMUL and the use of a dimension would be confusing since the
* first dimension of one argument and the second dimension of the
* other argument are mismatched.
*
* When the input dimension is nonzero, this routine is being called
* when the specified dimension is the same for both arguments.
*
* The message contains the name of this routine for debugging.
*/
void
__f90_conform_check(
char *file,
int line,
int dim,
long long extent1,
long long extent2)
{
char *abort_now = NULL;
char *rtn_nm = "__f90_conform_check";
abort_now = getenv("F90_CONFORM_CHECK_ABORT");
if (extent1 < 0)
extent1 = 0;
if (extent2 < 0)
extent2 = 0;
/* abort only if environment variable is present and is Y(es) */
if (abort_now && (*abort_now == 'y' || *abort_now == 'Y')) {
/* Use proper message depending on value of dimension. */
if (dim != 0)
(void) _lerror(_LELVL_MSG,FWARGDMD, dim, line,
file, extent1, extent2, rtn_nm);
else
(void) _lerror(_LELVL_MSG,FWARGDMZ, line,
file, extent1, extent2, rtn_nm);
_fcleanup();
abort();
}
/* Use proper message depending on value of dimension. */
if (dim != 0)
(void) _fwarn(FWARGDMD, dim, line, file, extent1,
extent2, rtn_nm);
else
(void) _fwarn(FWARGDMZ, line, file, extent1, extent2,
rtn_nm);
}
/* Do cleanup and abort after issuing bounds/subscript error */
static void
do_abort() {
_fcleanup();
abort();
}
