2008-04-07 Jerry DeLisle <jvdelisle@gcc.gnu.org>

	PR fortran/25829 28655
	* io.c (io_tag): Add new tags for decimal, encoding, asynchronous,
	round, sign, and id. (match_open_element): Match new tags.
	(gfc_resolve_open): Resolve new tags. (gfc_match_open): Enable encoding
	for DEFAULT only. Update error messages. (match_dt_element): Fix match
	tag for asynchronous. Update error messages. (gfc_free_inquire): Free
	new expressions. (match_inquire_element): Match new tags.
	(gfc_match_inquire): Add constraint for ID and PENDING.
	(gfc_resolve_inquire): Resolve new tags.
	* trans-io.c (gfc_trans_inquire): Clean up whitespace and fix setting of
	mask for ID parameter.
	* ioparm.def: Fix order of parameters for pending, round, and sign.
	NOTE: These must line up with the definitions in libgfortran/io/io.h. or
	things don't work.


git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@133989 138bc75d-0d04-0410-961f-82ee72b054a4

4 files changed, 95 insertions, 44 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 12afa21286b..7833747bec7 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,20 @@
+2008-04-07  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/25829 28655
+	* io.c (io_tag): Add new tags for decimal, encoding, asynchronous,
+	round, sign, and id. (match_open_element): Match new tags.
+	(gfc_resolve_open): Resolve new tags. (gfc_match_open): Enable encoding
+	for DEFAULT only. Update error messages. (match_dt_element): Fix match
+	tag for asynchronous. Update error messages. (gfc_free_inquire): Free
+	new expressions. (match_inquire_element): Match new tags.
+	(gfc_match_inquire): Add constraint for ID and PENDING.
+	(gfc_resolve_inquire): Resolve new tags.
+	* trans-io.c (gfc_trans_inquire): Clean up whitespace and fix setting of
+	mask for ID parameter.
+	* ioparm.def: Fix order of parameters for pending, round, and sign.
+	NOTE: These must line up with the definitions in libgfortran/io/io.h. or
+	things don't work.
+
 2008-04-06  Paul Thomas  <pault@gcc.gnu.org>
 
 	PR fortran/35780
diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 5ea051c87f9..11907a72a89 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -50,6 +50,7 @@ static const io_tag
 	tag_e_pad	= {"PAD", " pad =", " %e", BT_CHARACTER},
 	tag_e_decimal	= {"DECIMAL", " decimal =", " %e", BT_CHARACTER},
 	tag_e_encoding	= {"ENCODING", " encoding =", " %e", BT_CHARACTER},
+	tag_e_async	= {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
 	tag_e_round	= {"ROUND", " round =", " %e", BT_CHARACTER},
 	tag_e_sign	= {"SIGN", " sign =", " %e", BT_CHARACTER},
 	tag_unit	= {"UNIT", " unit =", " %e", BT_INTEGER},
@@ -81,14 +82,19 @@ static const io_tag
 	tag_readwrite	= {"READWRITE", " readwrite =", " %v", BT_CHARACTER},
 	tag_s_delim	= {"DELIM", " delim =", " %v", BT_CHARACTER},
 	tag_s_pad	= {"PAD", " pad =", " %v", BT_CHARACTER},
+	tag_s_decimal	= {"DECIMAL", " decimal =", " %v", BT_CHARACTER},
+	tag_s_encoding	= {"ENCODING", " encoding =", " %v", BT_CHARACTER},
+	tag_s_async	= {"ASYNCHRONOUS", " asynchronous =", " %v", BT_CHARACTER},
+	tag_s_round	= {"ROUND", " round =", " %v", BT_CHARACTER},
+	tag_s_sign	= {"SIGN", " sign =", " %v", BT_CHARACTER},
 	tag_iolength	= {"IOLENGTH", " iolength =", " %v", BT_INTEGER},
 	tag_convert     = {"CONVERT", " convert =", " %e", BT_CHARACTER},
 	tag_strm_out    = {"POS", " pos =", " %v", BT_INTEGER},
 	tag_err		= {"ERR", " err =", " %l", BT_UNKNOWN},
 	tag_end		= {"END", " end =", " %l", BT_UNKNOWN},
 	tag_eor		= {"EOR", " eor =", " %l", BT_UNKNOWN},
-	tag_async	= {"ASYNCHRONOUS", " asynchronous =", " %e", BT_CHARACTER},
-	tag_id		= {"ID", " id =", " %v", BT_INTEGER};
+	tag_id		= {"ID", " id =", " %v", BT_INTEGER},
+	tag_pending	= {"PENDING", " pending =", " %v", BT_LOGICAL};
 
 static gfc_dt *current_dt;
 
@@ -1277,7 +1283,7 @@ match_open_element (gfc_open *open)
 {
   match m;
 
-  m = match_etag (&tag_async, &open->asynchronous);
+  m = match_etag (&tag_e_async, &open->asynchronous);
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_unit, &open->unit);
@@ -1394,6 +1400,7 @@ gfc_resolve_open (gfc_open *open)
   RESOLVE_TAG (&tag_e_pad, open->pad);
   RESOLVE_TAG (&tag_e_decimal, open->decimal);
   RESOLVE_TAG (&tag_e_encoding, open->encoding);
+  RESOLVE_TAG (&tag_e_async, open->asynchronous);
   RESOLVE_TAG (&tag_e_round, open->round);
   RESOLVE_TAG (&tag_e_sign, open->sign);
   RESOLVE_TAG (&tag_convert, open->convert);
@@ -1652,16 +1659,14 @@ gfc_match_open (void)
   /* Checks on the ENCODING specifier.  */
   if (open->encoding)
     {
-      /* When implemented, change the following to use gfc_notify_std F2003.
       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENCODING= at %C "
 	  "not allowed in Fortran 95") == FAILURE)
-	goto cleanup; */
-      gfc_error ("F2003 Feature: ENCODING=specifier at %C not implemented");
-      goto cleanup;
+	goto cleanup;
     
       if (open->encoding->expr_type == EXPR_CONSTANT)
 	{
-	  static const char * encoding[] = { "UTF-8", "DEFAULT", NULL };
+	  /* TODO: Implement UTF-8 here.  */
+	  static const char * encoding[] = { "DEFAULT", NULL };
 
 	  if (!compare_to_allowed_values ("ENCODING", encoding, NULL, NULL,
 					  open->encoding->value.character.string,
@@ -1707,7 +1712,7 @@ gfc_match_open (void)
   if (open->round)
     {
       /* When implemented, change the following to use gfc_notify_std F2003.  */
-      gfc_error ("F2003 Feature: ROUND=specifier at %C not implemented");
+      gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented");
       goto cleanup;
 
       if (open->round->expr_type == EXPR_CONSTANT)
@@ -1772,8 +1777,8 @@ gfc_match_open (void)
 				      "OPEN", warn))
 	goto cleanup;
 
-      /* F2003, 9.4.5: If the STATUS=specifier has the value NEW or REPLACE,
-	 the FILE=specifier shall appear.  */
+      /* F2003, 9.4.5: If the STATUS= specifier has the value NEW or REPLACE,
+	 the FILE= specifier shall appear.  */
       if (open->file == NULL
 	  && (strncasecmp (open->status->value.character.string, "replace", 7)
 	      == 0
@@ -1785,8 +1790,8 @@ gfc_match_open (void)
 			 open->status->value.character.string);
 	}
 
-      /* F2003, 9.4.5: If the STATUS=specifier has the value SCRATCH,
-	 the FILE=specifier shall not appear.  */
+      /* F2003, 9.4.5: If the STATUS= specifier has the value SCRATCH,
+	 the FILE= specifier shall not appear.  */
       if (strncasecmp (open->status->value.character.string, "scratch", 7)
 	  == 0 && open->file)
 	{
@@ -2324,7 +2329,7 @@ match_dt_element (io_kind k, gfc_dt *dt)
       return MATCH_YES;
     }
 
-  m = match_etag (&tag_async, &dt->asynchronous);
+  m = match_etag (&tag_e_async, &dt->asynchronous);
   if (m != MATCH_NO)
     return m;
   m = match_etag (&tag_e_blank, &dt->blank);
@@ -2869,13 +2874,13 @@ if (condition) \
       io_constraint (dt->eor, "EOR tag not allowed with output at %L",
 		     &dt->eor_where);
 
-      io_constraint (dt->blank, "BLANK=specifier not allowed with output at %L",
+      io_constraint (dt->blank, "BLANK= specifier not allowed with output at %L",
 		     &dt->blank->where);
 
-      io_constraint (dt->pad, "PAD=specifier not allowed with output at %L",
+      io_constraint (dt->pad, "PAD= specifier not allowed with output at %L",
 		     &dt->pad->where);
 
-      io_constraint (dt->size, "SIZE=specifier not allowed with output at %L",
+      io_constraint (dt->size, "SIZE= specifier not allowed with output at %L",
 		     &dt->size->where);
     }
   else
@@ -2912,7 +2917,7 @@ if (condition) \
       io_constraint (!dt->asynchronous
 		     || strcmp (dt->asynchronous->value.character.string,
 				 "yes"),
-		     "ID=specifier at %L must be with ASYNCHRONOUS='yes' "
+		     "ID= specifier at %L must be with ASYNCHRONOUS='yes' "
 		     "specifier", &dt->id->where);
     }
 
@@ -2932,7 +2937,7 @@ if (condition) \
 	    return MATCH_ERROR;
 
 	  io_constraint (unformatted,
-			 "the DECIMAL=specifier at %L must be with an "
+			 "the DECIMAL= specifier at %L must be with an "
 			 "explicit format expression", &dt->decimal->where);
 	}
     }
@@ -2953,7 +2958,7 @@ if (condition) \
 	    return MATCH_ERROR;
 
 	  io_constraint (unformatted,
-			 "the BLANK=specifier at %L must be with an "
+			 "the BLANK= specifier at %L must be with an "
 			 "explicit format expression", &dt->blank->where);
 	}
     }
@@ -2974,7 +2979,7 @@ if (condition) \
 	    return MATCH_ERROR;
 
 	  io_constraint (unformatted,
-			 "the PAD=specifier at %L must be with an "
+			 "the PAD= specifier at %L must be with an "
 			 "explicit format expression", &dt->pad->where);
 	}
     }
@@ -2985,7 +2990,7 @@ if (condition) \
       if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ROUND= at %C "
 	  "not allowed in Fortran 95") == FAILURE)
 	return MATCH_ERROR;  */
-      gfc_error ("F2003 Feature: ROUND=specifier at %C not implemented");
+      gfc_error ("F2003 Feature: ROUND= specifier at %C not implemented");
       return MATCH_ERROR;
 
       if (dt->round->expr_type == EXPR_CONSTANT)
@@ -3018,11 +3023,11 @@ if (condition) \
 	    return MATCH_ERROR;
 
 	  io_constraint (unformatted,
-			 "SIGN=specifier at %L must be with an "
+			 "SIGN= specifier at %L must be with an "
 			 "explicit format expression", &dt->sign->where);
 
 	  io_constraint (k == M_READ,
-			 "SIGN=specifier at %L not allowed in a "
+			 "SIGN= specifier at %L not allowed in a "
 			 "READ statement", &dt->sign->where);
 	}
     }
@@ -3043,17 +3048,17 @@ if (condition) \
 	    return MATCH_ERROR;
 
 	  io_constraint (k == M_READ,
-			 "DELIM=specifier at %L not allowed in a "
+			 "DELIM= specifier at %L not allowed in a "
 			 "READ statement", &dt->delim->where);
       
 	  io_constraint (dt->format_label != &format_asterisk
 			 && dt->namelist == NULL,
-			 "DELIM=specifier at %L must have FMT=*",
+			 "DELIM= specifier at %L must have FMT=*",
 			 &dt->delim->where);
 
 	  io_constraint (unformatted && dt->namelist == NULL,
-			 "DELIM=specifier at %L must be with FMT=* or "
-			 "NML=specifier ", &dt->delim->where);
+			 "DELIM= specifier at %L must be with FMT=* or "
+			 "NML= specifier ", &dt->delim->where);
 	}
     }
   
@@ -3073,11 +3078,11 @@ if (condition) \
 		     "and format label at %L", spec_end);
 
       io_constraint (dt->rec,
-		     "NAMELIST IO is not allowed with a REC=specifier "
+		     "NAMELIST IO is not allowed with a REC= specifier "
 		     "at %L.", &dt->rec->where);
 
       io_constraint (dt->advance,
-		     "NAMELIST IO is not allowed with a ADVANCE=specifier "
+		     "NAMELIST IO is not allowed with a ADVANCE= specifier "
 		     "at %L.", &dt->advance->where);
     }
 
@@ -3085,10 +3090,10 @@ if (condition) \
     {
       io_constraint (dt->end,
 		     "An END tag is not allowed with a "
-		     "REC=specifier at %L.", &dt->end_where);
+		     "REC= specifier at %L.", &dt->end_where);
 
       io_constraint (dt->format_label == &format_asterisk,
-		     "FMT=* is not allowed with a REC=specifier "
+		     "FMT=* is not allowed with a REC= specifier "
 		     "at %L.", spec_end);
     }
 
@@ -3099,10 +3104,10 @@ if (condition) \
 
       io_constraint (dt->format_label == &format_asterisk,
 		     "List directed format(*) is not allowed with a "
-		     "ADVANCE=specifier at %L.", &expr->where);
+		     "ADVANCE= specifier at %L.", &expr->where);
 
       io_constraint (unformatted,
-		     "the ADVANCE=specifier at %L must appear with an "
+		     "the ADVANCE= specifier at %L must appear with an "
 		     "explicit format expression", &expr->where);
 
       if (expr->expr_type == EXPR_CONSTANT && expr->ts.type == BT_CHARACTER)
@@ -3118,7 +3123,7 @@ if (condition) \
 	}
 
       io_constraint (not_no && not_yes,
-		     "ADVANCE=specifier at %L must have value = "
+		     "ADVANCE= specifier at %L must have value = "
 		     "YES or NO.", &expr->where);
 
       io_constraint (dt->size && not_no && k == M_READ,
@@ -3418,10 +3423,16 @@ gfc_free_inquire (gfc_inquire *inquire)
   gfc_free_expr (inquire->write);
   gfc_free_expr (inquire->readwrite);
   gfc_free_expr (inquire->delim);
+  gfc_free_expr (inquire->encoding);
   gfc_free_expr (inquire->pad);
   gfc_free_expr (inquire->iolength);
   gfc_free_expr (inquire->convert);
   gfc_free_expr (inquire->strm_pos);
+  gfc_free_expr (inquire->asynchronous);
+  gfc_free_expr (inquire->pending);
+  gfc_free_expr (inquire->id);
+  gfc_free_expr (inquire->sign);
+  gfc_free_expr (inquire->round);
   gfc_free (inquire);
 }
 
@@ -3459,11 +3470,19 @@ match_inquire_element (gfc_inquire *inquire)
   RETM m = match_vtag (&tag_read, &inquire->read);
   RETM m = match_vtag (&tag_write, &inquire->write);
   RETM m = match_vtag (&tag_readwrite, &inquire->readwrite);
+  RETM m = match_vtag (&tag_s_async, &inquire->asynchronous);
   RETM m = match_vtag (&tag_s_delim, &inquire->delim);
+  RETM m = match_vtag (&tag_s_decimal, &inquire->decimal);
+  RETM m = match_vtag (&tag_s_blank, &inquire->blank);
+  RETM m = match_vtag (&tag_s_encoding, &inquire->encoding);
+  RETM m = match_vtag (&tag_s_round, &inquire->round);
+  RETM m = match_vtag (&tag_s_sign, &inquire->sign);
   RETM m = match_vtag (&tag_s_pad, &inquire->pad);
   RETM m = match_vtag (&tag_iolength, &inquire->iolength);
   RETM m = match_vtag (&tag_convert, &inquire->convert);
   RETM m = match_out_tag (&tag_strm_out, &inquire->strm_pos);
+  RETM m = match_vtag (&tag_pending, &inquire->pending);
+  RETM m = match_vtag (&tag_id, &inquire->id);
   RETM return MATCH_NO;
 }
 
@@ -3571,6 +3590,13 @@ gfc_match_inquire (void)
       gfc_error ("INQUIRE statement not allowed in PURE procedure at %C");
       goto cleanup;
     }
+  
+  if (inquire->id != NULL && inquire->pending == NULL)
+    {
+      gfc_error ("INQUIRE statement at %L requires a PENDING= specifier with "
+		 "the ID= specifier", &loc);
+      goto cleanup;
+    }
 
   new_st.op = EXEC_INQUIRE;
   new_st.ext.inquire = inquire;
@@ -3615,9 +3641,16 @@ gfc_resolve_inquire (gfc_inquire *inquire)
   RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
   RESOLVE_TAG (&tag_s_delim, inquire->delim);
   RESOLVE_TAG (&tag_s_pad, inquire->pad);
+  RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
+  RESOLVE_TAG (&tag_s_round, inquire->round);
   RESOLVE_TAG (&tag_iolength, inquire->iolength);
   RESOLVE_TAG (&tag_convert, inquire->convert);
   RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
+  RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
+  RESOLVE_TAG (&tag_s_sign, inquire->sign);
+  RESOLVE_TAG (&tag_s_round, inquire->round);
+  RESOLVE_TAG (&tag_pending, inquire->pending);
+  RESOLVE_TAG (&tag_id, inquire->id);
 
   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
diff --git a/gcc/fortran/ioparm.def b/gcc/fortran/ioparm.def
index b16fcb53c31..deb1b98389c 100644
--- a/gcc/fortran/ioparm.def
+++ b/gcc/fortran/ioparm.def
@@ -63,9 +63,9 @@ IOPARM (inquire, flags2,	1 << 31, int4)
 IOPARM (inquire, asynchronous,	1 << 0,  char1)
 IOPARM (inquire, decimal,	1 << 1,  char2)
 IOPARM (inquire, encoding,	1 << 2,  char1)
-IOPARM (inquire, round,		1 << 3,  char2)
-IOPARM (inquire, sign,		1 << 4,  char1)
-IOPARM (inquire, pending,	1 << 5,  pint4)
+IOPARM (inquire, pending,	1 << 3,  pint4)
+IOPARM (inquire, round,	        1 << 4,  char1)
+IOPARM (inquire, sign,		1 << 5,  char2)
 IOPARM (inquire, size,		1 << 6,  pint4)
 IOPARM (inquire, id,		1 << 7,  pint4)
 IOPARM (wait,    common,	0,	 common)
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 6bc41e1ce67..6316a426918 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1238,6 +1238,10 @@ gfc_trans_inquire (gfc_code * code)
     mask |= set_string (&block, &post_block, var, IOPARM_inquire_blank,
 			p->blank);
 
+  if (p->delim)
+    mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
+			p->delim);
+
   if (p->position)
     mask |= set_string (&block, &post_block, var, IOPARM_inquire_position,
 			p->position);
@@ -1258,14 +1262,10 @@ gfc_trans_inquire (gfc_code * code)
     mask |= set_string (&block, &post_block, var, IOPARM_inquire_readwrite,
 			p->readwrite);
 
-  if (p->delim)
-    mask |= set_string (&block, &post_block, var, IOPARM_inquire_delim,
-			p->delim);
-
   if (p->pad)
     mask |= set_string (&block, &post_block, var, IOPARM_inquire_pad,
 			p->pad);
-
+  
   if (p->convert)
     mask |= set_string (&block, &post_block, var, IOPARM_inquire_convert,
 			p->convert);
@@ -1304,7 +1304,8 @@ gfc_trans_inquire (gfc_code * code)
 				p->size);
 
   if (p->id)
-    mask2 |= set_parameter_value (&block, var, IOPARM_inquire_id, p->id);
+    mask2 |= set_parameter_ref (&block, &post_block,var, IOPARM_inquire_id,
+				p->id);
 
   set_parameter_const (&block, var, IOPARM_inquire_flags2, mask2);