:ADDPATCH fortran:
The attached patch adds a new error to gfortran. When an attempt is
made to write larger then the record length on a direct access file, the
EOR could not be caught because ERROR_END and ERROR_EOR are not allowed
with direct access.
The new error allows the error machinery to default to ERR which is
allowed to be specified in the direct access WRITE statement.
Note: The attached test case tests both catching the error and jumping
past an abort as well as not catching it and getting the error message.
Tested. OK for trunk and 4.1.1?
Regards,
Jerry
2006-03-12 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR libgfortran/26509
* libgfortran.h: Add ERROR_DIRECT_EOR.
* runtime/error.c (translate_error): Add translation for new error.
* io/transfer.c (write_buf): Add check for EOR when mode is
direct access.
------------------------------------------------------------------------
Index: runtime/error.c
===================================================================
*** runtime/error.c (revision 111989)
--- runtime/error.c (working copy)
*************** translate_error (int code)
*** 431,436 ****
--- 431,440 ----
p = "Internal unit I/O error";
break;
+ case ERROR_DIRECT_EOR:
+ p = "Write exceeds length of DIRECT access record";
+ break;
+
default:
p = "Unknown error code";
break;
Index: libgfortran.h
===================================================================
*** libgfortran.h (revision 111989)
--- libgfortran.h (working copy)
*************** typedef enum
*** 380,385 ****
--- 380,386 ----
ERROR_INTERNAL,
ERROR_INTERNAL_UNIT,
ERROR_ALLOCATION,
+ ERROR_DIRECT_EOR,
ERROR_LAST /* Not a real error, the last error # + 1. */
}
error_codes;
Index: io/transfer.c
===================================================================
*** io/transfer.c (revision 111989)
--- io/transfer.c (working copy)
*************** write_buf (st_parameter_dt *dtp, void *b
*** 384,390 ****
{
if (dtp->u.p.current_unit->bytes_left < nbytes)
{
! generate_error (&dtp->common, ERROR_EOR, NULL);
return FAILURE;
}
--- 384,393 ----
{
if (dtp->u.p.current_unit->bytes_left < nbytes)
{
! if (dtp->u.p.current_unit->flags.access == ACCESS_DIRECT)
! generate_error (&dtp->common, ERROR_DIRECT_EOR, NULL);
! else
! generate_error (&dtp->common, ERROR_EOR, NULL);
return FAILURE;
}