2008-07-29 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk r138226 [after tuple merge into trunk]
	some compiler probe stuff are missing
	* gcc/compiler-probe.h: more gimple, less tree
	* gcc/compiler-probe.c: incomplete merge.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@138247 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 31 insertions, 18 deletions

diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c
index 5d3f454acc0..58326b707f5 100644
--- a/gcc/fortran/io.c
+++ b/gcc/fortran/io.c
@@ -119,6 +119,8 @@ format_token;
    process.  */
 static gfc_char_t *format_string;
 static int format_length, use_last_char;
+static char error_element;
+static locus format_locus;
 
 static format_token saved_token;
 
@@ -165,6 +167,9 @@ next_char (int in_string)
   if (mode == MODE_COPY)
     *format_string++ = c;
 
+  if (mode != MODE_STRING)
+    format_locus = gfc_current_locus;
+
   c = gfc_wide_toupper (c);
   return c;
 }
@@ -186,7 +191,7 @@ next_char_not_space (bool *error)
   char c;
   do
     {
-      c = next_char (0);
+      error_element = c = next_char (0);
       if (c == '\t')
 	{
 	  if (gfc_option.allow_std & GFC_STD_GNU)
@@ -431,14 +436,14 @@ format_lex (void)
 	{
 	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DP format "
 	      "specifier not allowed at %C") == FAILURE)
-	  return FMT_ERROR;
+	    return FMT_ERROR;
 	  token = FMT_DP;
 	}
       else if (c == 'C')
 	{
 	  if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: DC format "
 	      "specifier not allowed at %C") == FAILURE)
-	  return FMT_ERROR;
+	    return FMT_ERROR;
 	  token = FMT_DC;
 	}
       else
@@ -469,12 +474,13 @@ format_lex (void)
    by itself, and we are checking it for validity.  The dual origin
    means that the warning message is a little less than great.  */
 
-static try
+static gfc_try
 check_format (bool is_input)
 {
   const char *posint_required	  = _("Positive width required");
   const char *nonneg_required	  = _("Nonnegative width required");
-  const char *unexpected_element  = _("Unexpected element");
+  const char *unexpected_element  = _("Unexpected element '%c' in format string"
+				      " at %L");
   const char *unexpected_end	  = _("Unexpected end of format string");
   const char *zero_width	  = _("Zero width in format descriptor");
   const char *g0_precision	= _("Specifying precision with G0 not allowed");
@@ -483,7 +489,7 @@ check_format (bool is_input)
   format_token t, u;
   int level;
   int repeat;
-  try rv;
+  gfc_try rv;
 
   use_last_char = 0;
   saved_token = FMT_NONE;
@@ -960,10 +966,11 @@ extension_optional_comma:
   goto format_item;
 
 syntax:
-  gfc_error ("%s in format string at %C", error);
+  if (error == unexpected_element)
+    gfc_error (error, error_element, &format_locus);
+  else
+    gfc_error ("%s in format string at %L", error, &format_locus);
 fail:
-  /* TODO: More elaborate measures are needed to show where a problem
-     is within a format string that has been calculated.  */
   rv = FAILURE;
 
 finished:
@@ -974,7 +981,7 @@ finished:
 /* Given an expression node that is a constant string, see if it looks
    like a format string.  */
 
-static try
+static gfc_try
 check_format_string (gfc_expr *e, bool is_input)
 {
   if (!e || e->ts.type != BT_CHARACTER || e->expr_type != EXPR_CONSTANT)
@@ -982,6 +989,12 @@ check_format_string (gfc_expr *e, bool is_input)
 
   mode = MODE_STRING;
   format_string = e->value.character.string;
+
+  /* More elaborate measures are needed to show where a problem is within a
+     format string that has been calculated, but that's probably not worth the
+     effort.  */
+  format_locus = e->where;
+
   return check_format (is_input);
 }
 
@@ -1178,7 +1191,7 @@ match_ltag (const io_tag *tag, gfc_st_label ** label)
 
 /* Resolution of the FORMAT tag, to be called from resolve_tag.  */
 
-static try
+static gfc_try
 resolve_tag_format (const gfc_expr *e)
 {
   if (e->expr_type == EXPR_CONSTANT
@@ -1247,7 +1260,7 @@ resolve_tag_format (const gfc_expr *e)
 
 /* Do expression resolution and type-checking on an expression tag.  */
 
-static try
+static gfc_try
 resolve_tag (const io_tag *tag, gfc_expr *e)
 {
   if (e == NULL)
@@ -1404,7 +1417,7 @@ gfc_free_open (gfc_open *open)
 
 /* Resolve everything in a gfc_open structure.  */
 
-try
+gfc_try
 gfc_resolve_open (gfc_open *open)
 {
 
@@ -2004,7 +2017,7 @@ cleanup:
 
 /* Resolve everything in a gfc_close structure.  */
 
-try
+gfc_try
 gfc_resolve_close (gfc_close *close)
 {
   RESOLVE_TAG (&tag_unit, close->unit);
@@ -2128,7 +2141,7 @@ cleanup:
 }
 
 
-try
+gfc_try
 gfc_resolve_filepos (gfc_filepos *fp)
 {
   RESOLVE_TAG (&tag_unit, fp->unit);
@@ -2454,7 +2467,7 @@ gfc_free_dt (gfc_dt *dt)
 
 /* Resolve everything in a gfc_dt structure.  */
 
-try
+gfc_try
 gfc_resolve_dt (gfc_dt *dt)
 {
   gfc_expr *e;
@@ -3692,7 +3705,7 @@ cleanup:
 
 /* Resolve everything in a gfc_inquire structure.  */
 
-try
+gfc_try
 gfc_resolve_inquire (gfc_inquire *inquire)
 {
   RESOLVE_TAG (&tag_unit, inquire->unit);
@@ -3751,7 +3764,7 @@ gfc_free_wait (gfc_wait *wait)
 }
 
 
-try
+gfc_try
 gfc_resolve_wait (gfc_wait *wait)
 {
   RESOLVE_TAG (&tag_unit, wait->unit);