void _BOUNDS_ERROR( char *file, /* Fortran routine containing error */ int *line, /* Line number in Fortran routine */ char *variable, /* arrayname with out-of-bounds subscript */ int *dim, /* Dimension number of the array */ int *lowerbnd, /* Lower bound of dimension dim */ int *upperbnd, /* Upper bound of dimension dim */ int sub[1], /* Out-of-bounds subscript value */ int *count) /* Count/flag for number of messages */ { int *retcnt; /* ptr to static arg count word */ int intcnt = 0; /* local count if no count passed */ #ifdef _UNICOS /* Use local variable if count argument not passed. */ if (_numargs() < 8) retcnt = &intcnt; else #endif retcnt = count; if ((*retcnt)++ == 0) { #ifdef KEY /* Bug 7969 */ if (want_abort()) { (void) _lerror(_LELVL_MSG, FWARGSBV, sub[0], *dim, variable, *line, file, *lowerbnd, *upperbnd); do_abort(); } #endif /* KEY Bug 7969 */ (void) _fwarn(FWARGSBV, sub[0], *dim, variable, *line, file, *lowerbnd, *upperbnd); } return; }
void _RBOUNDS_ERROR( char *file, /* Fortran routine containing error */ int *line, /* Line number in Fortran routine */ char *variable, /* arrayname with out-of-bounds subscript */ int *dim, /* Dimension number with size mismatch */ int *lowerbnd, /* Lower bound of dimension dim */ int *upperbnd, /* Upper bound of dimension dim */ int *start, /* Out-of-bounds starting subscript */ int *end, /* Out-of-bounds ending subscript */ int *incr, /* Increment between subscript */ int *count) /* Count/flag for number of messages */ { int *retcnt; /* ptr to static arg count word */ int intcnt = 0; /* local count if no count passed */ #ifdef _UNICOS /* Use local variable if count argument not passed. */ if (_numargs() < 10) retcnt = &intcnt; else #endif retcnt = count; if ((*retcnt)++ == 0) { (void) _fwarn(FWARGSBR, *start, *end, *incr, *dim, variable, *line, file, *lowerbnd, *upperbnd); } return; }
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); }
/* * Error handler for an of out of bounds substring. * * Input: * file - File name in which error occurred. * line - Line number in file. * variable - Name of array which had an out of bounds substring. * size - Substring size. * start - Out of bounds substring start. * length - Out of bounds substring length. * count - Static count/flag to indicate if this message was * already given for this statement. */ void _SBOUNDS_ERROR( char *file, int *line, char *variable, int *size, int *subst, int *subln, int *count ) { int *retcnt; /* ptr to static arg count word */ int intcnt = 0; /* local count if no count passed */ int endst; #ifdef _UNICOS /* Use local variable if count argument not passed. */ if (_numargs() < 7) retcnt = &intcnt; else #endif retcnt = count; /* if substring length is zero or negative, not incorrect */ if ( *subln > 0) { if ((*retcnt)++ == 0) { /* calculate substring end. * subln is calculated by (ln = s2 - s1 + 1) * endst is calculated by (s2 = ln + s1 - 1) */ endst = *subln + *subst - 1; #ifdef KEY /* Bug 7969 */ if (want_abort()) { (void) _lerror(_LELVL_MSG, FWARGSTR, *subst, endst, variable, *line, file, *size); do_abort(); } #endif /* KEY Bug 7969 */ (void) _fwarn (FWARGSTR, *subst, endst, variable, *line, file, *size); } } return; }
void _CONFORM_ERROR( char *file, /* Fortran routine containing error */ int *line, /* Line number in Fortran routine */ int *dim, /* Dimension number with size mismatch */ int *count) /* count/flag to give message once per * statement. */ { int intcnt = 0; /* local count if no count passed */ int *retcnt; /* ptr to count word */ #ifdef _UNICOS /* Use local variable if count argument not passed. */ if (_numargs() < 4) retcnt = &intcnt; else #endif retcnt = count; if (*retcnt == 0) { *retcnt = 1; (void) _fwarn(FWARGDIM, *dim, *line, file); } return; }
void _VRBOUNDS_ERROR( char *file, /* Fortran routine with error */ int *line, /* Line number in Fortran routine */ char *variable, /* Arrayname with out-of-bounds subscript */ int *dim, /* Dimension number of the array */ int *lowerbnd, /* Lower bound of dimension dim */ int *upperbnd, /* Upper bound of dimension dim */ int start[128], /* Out-of-bounds starting subscript */ int end[128], /* Out-of-bounds ending subscript */ int incr[128], /* Increment between subscript */ long vm[2], /* Bit mask of the subscripts in error */ int *vl, /* Number of subscripts passed */ int *count) /* Count/flag for number of messages */ { int i, len; long mask; int first_error_start; int first_error_end; int first_error_incr; int all_same = 1; int first_error = 1; int *retcnt; /* ptr to static arg count word */ int intcnt = 0; /* local count if no count passed */ #ifdef _UNICOS /* Use local variable if count argument not passed. */ if (_numargs() < 12) retcnt = &intcnt; else #endif retcnt = count; if ((*retcnt)++ != 0) return; len = *vl; for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) { if ( i == 64 ) { mask = vm[1]; } if ( mask < 0 ) { if ( first_error ) { first_error = 0; first_error_start = start[i]; first_error_end = end[i]; first_error_incr = incr[i]; } else if ( first_error_start != start[i] || first_error_end != end[i] || first_error_incr != incr[i] ) { all_same = 0; break; } } } if ( all_same ) { (void) _fwarn(FWARGSBR, first_error_start, first_error_end, first_error_incr, *dim, variable, *line, file, *lowerbnd, *upperbnd); return; } for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) { if ( i == 64 ) { mask = vm[1]; } if ( mask < 0 ) { (void) _fwarn(FWARGSBR, start[i], end[i], incr[i], *dim, variable, *line, file, *lowerbnd, *upperbnd); } } }
void _VBOUNDS_ERROR( char *file, /* Fortran routine with error */ int *line, /* Line number in Fortran routine */ char *variable, /* Arrayname with out-of-bounds subscript */ int *dim, /* Dimension number of the array */ int *lowerbnd, /* Lower bound of dimension dim */ int *upperbnd, /* Upper bound of dimension dim */ int sub[128], /* Array of subscripts */ long vm[2], /* Bit mask of the subscripts in error */ int *vl, /* Number of subscripts passed */ int *count) /* Count/flag for number of messages */ { int i, len; long mask; int stride; int first_error_sub; int last_error_sub; int constant_stride = 1; int error_count = 0; int *retcnt; /* ptr to static arg count word */ int intcnt = 0; /* local count if no count passed */ #ifdef _UNICOS /* Use local variable if count argument not passed. */ if (_numargs() < 10) retcnt = &intcnt; else #endif retcnt = count; if ((*retcnt)++ != 0) return; len = *vl; for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) { if ( i == 64 ) { mask = vm[1]; } if ( mask < 0 ) { error_count++; if ( error_count == 1 ) { first_error_sub = sub[i]; } else if ( error_count == 2 ) { stride = sub[i] - last_error_sub; } else { if ( stride != sub[i] - last_error_sub ) { constant_stride = 0; break; } } last_error_sub = sub[i]; } } if ( error_count == 1 ) { (void) _fwarn(FWARGSBV, first_error_sub, *dim, variable, *line, file, *lowerbnd, *upperbnd); return; } else if ( constant_stride ) { if ( stride == 0 ) { (void) _fwarn(FWARGSBV, first_error_sub, *dim, variable, *line, file, *lowerbnd, *upperbnd); } else { (void) _fwarn(FWARGSBR, first_error_sub, last_error_sub, stride, *dim, variable, *line, file, *lowerbnd, *upperbnd); } return; } for ( mask = vm[0], i = 0; i < len; i++, mask <<= 1 ) { if ( i == 64 ) { mask = vm[1]; } if ( mask < 0 ) { (void) _fwarn(FWARGSBV, sub[i], *dim, variable, *line, file, *lowerbnd, *upperbnd); } } }