gfortran.h: Add iomsg to gfc_open, gfc_close, gfc_filepos, gfc_inquire and gfc_dt.

2005-09-09  Thomas Koenig  <Thomas.Koenig@online.de>

	* gfortran.h:  Add iomsg to gfc_open, gfc_close, gfc_filepos,
	gfc_inquire and gfc_dt.
	* dump-parse-tree.c (gfc_show_code_node):  Add iomsg
	for open, close, file positioning, inquire and namelist.
	* io.c (io_tag):  Add tag_iomsg.
	(resolve_tag): Add standards warning for iomsg.
	(match_open_element):  Add iomsg.
	(gfc_free_open):  Add iomsg.
	(gfc_resolve_open):  Add iomsg.
	(gfc_free_close):  Add iomsg.
	(match_close_element):  Add iomsg.
	(gfc_resolve_close):  Add iomsg.
	(gfc_free_filepos):  Add iomsg.
	(match_file_element):  Add iomsg.
	(gfc_resolve_filepos):  Add iostat and iomsg.
	(match-dt_element):  Add iomsg.
	(gfc_free_dt):  Add iomsg.
	(gfc_resolve_dt):  Add iomsg.
	(gfc_free_inquire):  Add iomsg.
	(match_inquire_element):  Add iomsg.
	(gfc_resolve_inquire):  Add iomsg.
	* trans_io.c:  Add ioparm_iomsg and ioparm_iomsg_len.
	(gfc_build_io_library_fndecls):  Add iomsg as last field.
	(gfc_trans_open):  Add iomsg.
	(gfc_trans_close):  Add iomsg.
	(build_fileos):  Call set_string for iomsg.
	(gfc_trans_inquire):  Add iomsg.
	(build_dt):  Add iomsg.

2005-09-09  Thomas Koenig  <Thomas.Koenig@online.de>

	* io/io.h:  Add iomsg as last field of st_parameter.
	* runtime/error.c (generate_error):  If iomsg is present, copy
	the message there.

2005-09-09  Thomas Koenig  <Thomas.Koenig@online.de>

	* gfortran.dg/iomsg_1.f90:  New test case.

From-SVN: r104102

gcc/fortran/dump-parse-tree.c

@@ -1084,6 +1084,11 @@ gfc_show_code_node (int level, gfc_code * c)
 	  gfc_status (" UNIT=");
 	  gfc_show_expr (open->unit);
 	}
+      if (open->iomsg)
+	{
+	  gfc_status (" IOMSG=");
+	  gfc_show_expr (open->iomsg);
+	}
       if (open->iostat)
 	{
 	  gfc_status (" IOSTAT=");
@@ -1153,6 +1158,11 @@ gfc_show_code_node (int level, gfc_code * c)
 	  gfc_status (" UNIT=");
 	  gfc_show_expr (close->unit);
 	}
+      if (close->iomsg)
+	{
+	  gfc_status (" IOMSG=");
+	  gfc_show_expr (close->iomsg);
+	}
       if (close->iostat)
 	{
 	  gfc_status (" IOSTAT=");
@@ -1190,6 +1200,11 @@ gfc_show_code_node (int level, gfc_code * c)
 	  gfc_status (" UNIT=");
 	  gfc_show_expr (fp->unit);
 	}
+      if (fp->iomsg)
+	{
+	  gfc_status (" IOMSG=");
+	  gfc_show_expr (fp->iomsg);
+	}
       if (fp->iostat)
 	{
 	  gfc_status (" IOSTAT=");
@@ -1214,6 +1229,11 @@ gfc_show_code_node (int level, gfc_code * c)
 	  gfc_show_expr (i->file);
 	}
 
+      if (i->iomsg)
+	{
+	  gfc_status (" IOMSG=");
+	  gfc_show_expr (i->iomsg);
+	}
       if (i->iostat)
 	{
 	  gfc_status (" IOSTAT=");
@@ -1360,6 +1380,12 @@ gfc_show_code_node (int level, gfc_code * c)
 	gfc_status (" FMT=%d", dt->format_label->value);
       if (dt->namelist)
 	gfc_status (" NML=%s", dt->namelist->name);
+
+      if (dt->iomsg)
+	{
+	  gfc_status (" IOMSG=");
+	  gfc_show_expr (dt->iomsg);
+	}
       if (dt->iostat)
 	{
 	  gfc_status (" IOSTAT=");

gcc/fortran/gfortran.h

@@ -1270,7 +1270,7 @@ gfc_alloc;
 typedef struct
 {
   gfc_expr *unit, *file, *status, *access, *form, *recl,
-    *blank, *position, *action, *delim, *pad, *iostat;
+    *blank, *position, *action, *delim, *pad, *iostat, *iomsg;
   gfc_st_label *err;
 }
 gfc_open;
@@ -1278,7 +1278,7 @@ gfc_open;
 
 typedef struct
 {
-  gfc_expr *unit, *status, *iostat;
+  gfc_expr *unit, *status, *iostat, *iomsg;
   gfc_st_label *err;
 }
 gfc_close;
@@ -1286,7 +1286,7 @@ gfc_close;
 
 typedef struct
 {
-  gfc_expr *unit, *iostat;
+  gfc_expr *unit, *iostat, *iomsg;
   gfc_st_label *err;
 }
 gfc_filepos;
@@ -1297,7 +1297,7 @@ typedef struct
   gfc_expr *unit, *file, *iostat, *exist, *opened, *number, *named,
     *name, *access, *sequential, *direct, *form, *formatted,
     *unformatted, *recl, *nextrec, *blank, *position, *action, *read,
-    *write, *readwrite, *delim, *pad, *iolength;
+    *write, *readwrite, *delim, *pad, *iolength, *iomsg;
 
   gfc_st_label *err;
 
@@ -1307,7 +1307,7 @@ gfc_inquire;
 
 typedef struct
 {
-  gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size;
+  gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg;
 
   gfc_symbol *namelist;
   /* A format_label of `format_asterisk' indicates the "*" format */

gcc/fortran/io.c

@@ -53,6 +53,7 @@ static const io_tag
 	tag_advance	= {"ADVANCE", " advance = %e", BT_CHARACTER},
 	tag_rec		= {"REC", " rec = %e", BT_INTEGER},
 	tag_format	= {"FORMAT", NULL, BT_CHARACTER},
+	tag_iomsg	= {"IOMSG", " iomsg = %e", BT_CHARACTER},
 	tag_iostat	= {"IOSTAT", " iostat = %v", BT_INTEGER},
 	tag_size	= {"SIZE", " size = %v", BT_INTEGER},
 	tag_exist	= {"EXIST", " exist = %v", BT_LOGICAL},
@@ -1035,6 +1036,12 @@ resolve_tag (const io_tag * tag, gfc_expr * e)
 	  gfc_error ("%s tag at %L must be scalar", tag->name, &e->where);
 	  return FAILURE;
 	}
+      if (tag == &tag_iomsg)
+	{
+	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IOMSG tag at %L",
+			      &e->where) == FAILURE)
+	    return FAILURE;
+	}
     }
 
   return SUCCESS;
@@ -1051,6 +1058,9 @@ match_open_element (gfc_open * open)
   m = match_etag (&tag_unit, &open->unit);
   if (m != MATCH_NO)
     return m;
+  m = match_out_tag (&tag_iomsg, &open->iomsg);
+  if (m != MATCH_NO)
+    return m;
   m = match_out_tag (&tag_iostat, &open->iostat);
   if (m != MATCH_NO)
     return m;
@@ -1102,6 +1112,7 @@ gfc_free_open (gfc_open * open)
     return;
 
   gfc_free_expr (open->unit);
+  gfc_free_expr (open->iomsg);
   gfc_free_expr (open->iostat);
   gfc_free_expr (open->file);
   gfc_free_expr (open->status);
@@ -1125,6 +1136,7 @@ gfc_resolve_open (gfc_open * open)
 {
 
   RESOLVE_TAG (&tag_unit, open->unit);
+  RESOLVE_TAG (&tag_iomsg, open->iomsg);
   RESOLVE_TAG (&tag_iostat, open->iostat);
   RESOLVE_TAG (&tag_file, open->file);
   RESOLVE_TAG (&tag_status, open->status);
@@ -1217,6 +1229,7 @@ gfc_free_close (gfc_close * close)
     return;
 
   gfc_free_expr (close->unit);
+  gfc_free_expr (close->iomsg);
   gfc_free_expr (close->iostat);
   gfc_free_expr (close->status);
 
@@ -1237,6 +1250,9 @@ match_close_element (gfc_close * close)
   m = match_etag (&tag_status, &close->status);
   if (m != MATCH_NO)
     return m;
+  m = match_out_tag (&tag_iomsg, &close->iomsg);
+  if (m != MATCH_NO)
+    return m;
   m = match_out_tag (&tag_iostat, &close->iostat);
   if (m != MATCH_NO)
     return m;
@@ -1318,6 +1334,7 @@ gfc_resolve_close (gfc_close * close)
 {
 
   RESOLVE_TAG (&tag_unit, close->unit);
+  RESOLVE_TAG (&tag_iomsg, close->iomsg);
   RESOLVE_TAG (&tag_iostat, close->iostat);
   RESOLVE_TAG (&tag_status, close->status);
 
@@ -1335,6 +1352,7 @@ gfc_free_filepos (gfc_filepos * fp)
 {
 
   gfc_free_expr (fp->unit);
+  gfc_free_expr (fp->iomsg);
   gfc_free_expr (fp->iostat);
   gfc_free (fp);
 }
@@ -1350,6 +1368,9 @@ match_file_element (gfc_filepos * fp)
   m = match_etag (&tag_unit, &fp->unit);
   if (m != MATCH_NO)
     return m;
+  m = match_out_tag (&tag_iomsg, &fp->iomsg);
+  if (m != MATCH_NO)
+    return m;
   m = match_out_tag (&tag_iostat, &fp->iostat);
   if (m != MATCH_NO)
     return m;
@@ -1439,6 +1460,8 @@ gfc_resolve_filepos (gfc_filepos * fp)
 {
 
   RESOLVE_TAG (&tag_unit, fp->unit);
+  RESOLVE_TAG (&tag_iostat, fp->iostat);
+  RESOLVE_TAG (&tag_iomsg, fp->iomsg);
   if (gfc_reference_st_label (fp->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
 
@@ -1666,6 +1689,9 @@ match_dt_element (io_kind k, gfc_dt * dt)
   m = match_etag (&tag_rec, &dt->rec);
   if (m != MATCH_NO)
     return m;
+  m = match_out_tag (&tag_iomsg, &dt->iomsg);
+  if (m != MATCH_NO)
+    return m;
   m = match_out_tag (&tag_iostat, &dt->iostat);
   if (m != MATCH_NO)
     return m;
@@ -1715,6 +1741,7 @@ gfc_free_dt (gfc_dt * dt)
   gfc_free_expr (dt->format_expr);
   gfc_free_expr (dt->rec);
   gfc_free_expr (dt->advance);
+  gfc_free_expr (dt->iomsg);
   gfc_free_expr (dt->iostat);
   gfc_free_expr (dt->size);
 
@@ -1732,6 +1759,7 @@ gfc_resolve_dt (gfc_dt * dt)
   RESOLVE_TAG (&tag_format, dt->format_expr);
   RESOLVE_TAG (&tag_rec, dt->rec);
   RESOLVE_TAG (&tag_advance, dt->advance);
+  RESOLVE_TAG (&tag_iomsg, dt->iomsg);
   RESOLVE_TAG (&tag_iostat, dt->iostat);
   RESOLVE_TAG (&tag_size, dt->size);
 
@@ -2364,6 +2392,7 @@ gfc_free_inquire (gfc_inquire * inquire)
 
   gfc_free_expr (inquire->unit);
   gfc_free_expr (inquire->file);
+  gfc_free_expr (inquire->iomsg);
   gfc_free_expr (inquire->iostat);
   gfc_free_expr (inquire->exist);
   gfc_free_expr (inquire->opened);
@@ -2404,6 +2433,7 @@ match_inquire_element (gfc_inquire * inquire)
   m = match_etag (&tag_unit, &inquire->unit);
   RETM m = match_etag (&tag_file, &inquire->file);
   RETM m = match_ltag (&tag_err, &inquire->err);
+  RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
   RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
   RETM m = match_vtag (&tag_exist, &inquire->exist);
   RETM m = match_vtag (&tag_opened, &inquire->opened);
@@ -2555,6 +2585,7 @@ gfc_resolve_inquire (gfc_inquire * inquire)
 
   RESOLVE_TAG (&tag_unit, inquire->unit);
   RESOLVE_TAG (&tag_file, inquire->file);
+  RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
   RESOLVE_TAG (&tag_iostat, inquire->iostat);
   RESOLVE_TAG (&tag_exist, inquire->exist);
   RESOLVE_TAG (&tag_opened, inquire->opened);

gcc/fortran/trans-io.c

@@ -98,6 +98,8 @@ static GTY(()) tree ioparm_readwrite_len;
 static GTY(()) tree ioparm_namelist_name;
 static GTY(()) tree ioparm_namelist_name_len;
 static GTY(()) tree ioparm_namelist_read_mode;
+static GTY(()) tree ioparm_iomsg;
+static GTY(()) tree ioparm_iomsg_len;
 
 /* The global I/O variables */
 
@@ -213,6 +215,7 @@ gfc_build_io_library_fndecls (void)
 
   ADD_STRING (namelist_name);
   ADD_FIELD (namelist_read_mode, gfc_int4_type_node);
+  ADD_STRING (iomsg);
 
   gfc_finish_type (ioparm_type);
 
@@ -642,6 +645,10 @@ gfc_trans_open (gfc_code * code)
   if (p->pad)
     set_string (&block, &post_block, ioparm_pad, ioparm_pad_len, p->pad);
 
+  if (p->iomsg)
+    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
+		p->iomsg);
+
   if (p->iostat)
     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 
@@ -681,6 +688,10 @@ gfc_trans_close (gfc_code * code)
     set_string (&block, &post_block, ioparm_status,
 		ioparm_status_len, p->status);
 
+  if (p->iomsg)
+    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
+		p->iomsg);
+
   if (p->iostat)
     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 
@@ -703,19 +714,24 @@ gfc_trans_close (gfc_code * code)
 static tree
 build_filepos (tree function, gfc_code * code)
 {
-  stmtblock_t block;
+  stmtblock_t block, post_block;
   gfc_filepos *p;
   tree tmp;
 
   p = code->ext.filepos;
 
   gfc_init_block (&block);
+  gfc_init_block (&post_block);
 
   set_error_locus (&block, &code->loc);
 
   if (p->unit)
     set_parameter_value (&block, ioparm_unit, p->unit);
 
+  if (p->iomsg)
+    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
+		p->iomsg);
+
   if (p->iostat)
     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 
@@ -725,6 +741,8 @@ build_filepos (tree function, gfc_code * code)
   tmp = gfc_build_function_call (function, NULL);
   gfc_add_expr_to_block (&block, tmp);
 
+  gfc_add_block_to_block (&block, &post_block);
+
   io_result (&block, p->err, NULL, NULL);
 
   return gfc_finish_block (&block);
@@ -796,6 +814,10 @@ gfc_trans_inquire (gfc_code * code)
   if (p->file)
     set_string (&block, &post_block, ioparm_file, ioparm_file_len, p->file);
 
+  if (p->iomsg)
+    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
+		p->iomsg);
+
   if (p->iostat)
     set_parameter_ref (&block, ioparm_iostat, p->iostat);
 
@@ -1179,6 +1201,10 @@ build_dt (tree * function, gfc_code * code)
 		    ioparm_format_len, dt->format_label->format);
     }
 
+  if (dt->iomsg)
+    set_string (&block, &post_block, ioparm_iomsg, ioparm_iomsg_len,
+		dt->iomsg);
+
   if (dt->iostat)
     set_parameter_ref (&block, ioparm_iostat, dt->iostat);
 

gcc/testsuite/ChangeLog

+2005-09-09  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	* gfortran.dg/iomsg_1.f90:  New test case.
+
 2005-09-09  Richard Guenther  <rguenther@suse.de>
 
 	PR c++/23624

gcc/testsuite/gfortran.dg/iomsg_1.f90

+! { dg-do run }
+! Test implementation of the iomsg tag.
+program iomsg_test
+  character(len=70) ch
+
+  ! Test that iomsg is left unchanged with no error
+  ch = 'asdf'
+  open(10, status='scratch', iomsg=ch, iostat=i) ! { dg-warning "Fortran 2003: IOMSG tag" }
+  if (ch .ne. 'asdf') call abort
+
+  ! Test iomsg with data transfer statement
+  read(10,'(I2)', iomsg=ch, end=100) k ! { dg-warning "Fortran 2003: IOMSG tag" }
+  call abort
+100 continue
+  if (ch .ne. 'End of file') call abort
+
+  ! Test iomsg with open
+  open (-3, err=200, iomsg=ch) ! { dg-warning "Fortran 2003: IOMSG tag" }
+
+  call abort
+200 continue
+  if (ch .ne. 'Bad unit number in OPEN statement') call abort
+
+  ! Test iomsg with close
+  close(23,status="no_idea", err=500, iomsg=ch) ! { dg-warning "Fortran 2003: IOMSG tag" }
+500 continue
+  if (ch .ne. "Bad STATUS parameter in CLOSE statement") call abort
+end program iomsg_test

libgfortran/ChangeLog

+2005-09-09  Thomas Koenig  <Thomas.Koenig@online.de>
+
+	* io/io.h:  Add iomsg as last field of st_parameter.
+	* runtime/error.c (generate_error):  If iomsg is present, copy
+	the message there.
+
 2005-09-09  Richard Sandiford  <richard@codesourcery.com>
 
 	PR fortran/12840

libgfortran/io/io.h

@@ -263,6 +263,9 @@ typedef struct
   CHARACTER (namelist_name);
   GFC_INTEGER_4 namelist_read_mode;
 
+  /* iomsg */
+  CHARACTER (iomsg);
+
 #undef CHARACTER
 }
 st_parameter;

libgfortran/runtime/error.c

@@ -441,10 +441,10 @@ translate_error (int code)
 
 
 /* generate_error()-- Come here when an error happens.  This
- * subroutine is called if it is possible to continue on after the
- * error.  If an IOSTAT variable exists, we set it.  If the IOSTAT or
- * ERR label is present, we return, otherwise we terminate the program
- * after print a message.  The error code is always required but the
+ * subroutine is called if it is possible to continue on after the error.
+ * If an IOSTAT or IOMSG variable exists, we set it.  If IOSTAT or
+ * ERR labels are present, we return, otherwise we terminate the program
+ * after printing a message.  The error code is always required but the
  * message parameter can be NULL, in which case a string describing
  * the most recent operating system error is used. */
 
@@ -455,6 +455,13 @@ generate_error (int family, const char *message)
   if (ioparm.iostat != NULL)
     *ioparm.iostat = family;
 
+  if (message == NULL)
+    message =
+      (family == ERROR_OS) ? get_oserror () : translate_error (family);
+
+  if (ioparm.iomsg)
+    cf_strcpy (ioparm.iomsg, ioparm.iomsg_len, message);
+
   /* Report status back to the compiler.  */
   switch (family)
     {
@@ -483,10 +490,6 @@ generate_error (int family, const char *message)
 
   /* Terminate the program */
 
-  if (message == NULL)
-    message =
-      (family == ERROR_OS) ? get_oserror () : translate_error (family);
-
   runtime_error (message);
 }