2010-02-15 Basile Starynkevitch <basile@starynkevitch.net>

	MELT branch merged with trunk rev 156774



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

8 files changed, 149 insertions, 20 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 5efa90cdcfa..b498dc4ad7b 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,40 @@
+2010-02-14  Jerry DeLisle  <jvdelisle@gcc.gnu.org>
+
+	PR fortran/32382
+	* trans-stmt.h: Add prototype for gfc_trans_code_cond. Add tree cond to
+	gfc_trans_do prototype.
+	* trans-stmt.c (gfc_trans_simple_do): Add optional argument to pass in
+	a loop exit condition.  If exit condition is given, build the loop exit
+	code, checking IO results of implied do loops in READ and WRITE.
+	(gfc_trans_do): Likewise.
+	* trans.c (trans_code): New static work function, previously
+	gfc_trans_code. Passes exit condition to gfc_trans_do.
+	(gfc_trans_code): Calls trans_code with NULL_TREE condition.
+	(gfc_trans_code_cond): Calls trans_code with loop exit condition.
+	* trans-io.c (build_dt): Build an exit condition to allow checking IO
+	result status bits in the dtparm structure. Use this condition in call
+	to gfc_trans_code_cond.
+
+2010-02-13  Paul Thomas  <pault@gcc.gnu.org>
+
+	PR fortran/41113
+	PR fortran/41117
+	* trans-array.c (gfc_conv_array_parameter): Use
+	gfc_full_array_ref_p to detect full and contiguous variable
+	arrays. Full array components and contiguous arrays do not need
+	internal_pack and internal_unpack.
+
+2010-02-11  Jakub Jelinek  <jakub@redhat.com>
+
+	PR fortran/43030
+	* resolve.c (gfc_resolve_dim_arg): Call gfc_clear_ts.
+
+	PR fortran/43029
+	* decl.c (enumerator_decl): Don't call gfc_free_enum_history
+	here.
+	(gfc_match_enumerator_def): But here whenever enumerator_decl returns
+	MATCH_ERROR.
+
 2010-02-10  Joost VandeVondele <jv244@cam.ac.uk>
 	    Tobias Burnus <burnus@net-b.de>
 
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 82c67ae0045..0f3898f7844 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -7124,10 +7124,9 @@ enumerator_decl (void)
 
   if (initializer == NULL || initializer->ts.type != BT_INTEGER)
     {
-      gfc_error("ENUMERATOR %L not initialized with integer expression",
-		&var_locus);
+      gfc_error ("ENUMERATOR %L not initialized with integer expression",
+		 &var_locus);
       m = MATCH_ERROR;
-      gfc_free_enum_history ();
       goto cleanup;
     }
 
@@ -7193,7 +7192,10 @@ gfc_match_enumerator_def (void)
     {
       m = enumerator_decl ();
       if (m == MATCH_ERROR)
-	goto cleanup;
+	{
+	  gfc_free_enum_history ();
+	  goto cleanup;
+	}
       if (m == MATCH_NO)
 	break;
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index b525e32b166..bcc8eaeddb5 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -3958,6 +3958,7 @@ gfc_resolve_dim_arg (gfc_expr *dim)
     {
       gfc_typespec ts;
 
+      gfc_clear_ts (&ts);
       ts.type = BT_INTEGER;
       ts.kind = gfc_index_integer_kind;
 
diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index d512da4db6b..ae39aed1c58 100644
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -5468,17 +5468,27 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
   tree tmp = NULL_TREE;
   tree stmt;
   tree parent = DECL_CONTEXT (current_function_decl);
-  bool full_array_var, this_array_result;
+  bool full_array_var;
+  bool this_array_result;
+  bool contiguous;
   gfc_symbol *sym;
   stmtblock_t block;
+  gfc_ref *ref;
+
+  for (ref = expr->ref; ref; ref = ref->next)
+    if (ref->next == NULL)
+      break;
+
+  full_array_var = false;
+  contiguous = false;
+
+  if (expr->expr_type == EXPR_VARIABLE && ref)
+    full_array_var = gfc_full_array_ref_p (ref, &contiguous);
 
-  full_array_var = (expr->expr_type == EXPR_VARIABLE
-		    && expr->ref->type == REF_ARRAY
-		    && expr->ref->u.ar.type == AR_FULL);
   sym = full_array_var ? expr->symtree->n.sym : NULL;
 
   /* The symbol should have an array specification.  */
-  gcc_assert (!sym || sym->as);
+  gcc_assert (!sym || sym->as || ref->u.ar.as);
 
   if (expr->expr_type == EXPR_ARRAY && expr->ts.type == BT_CHARACTER)
     {
@@ -5501,6 +5511,14 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
 
       if (sym->ts.type == BT_CHARACTER)
 	se->string_length = sym->ts.u.cl->backend_decl;
+
+      if (sym->ts.type == BT_DERIVED && !sym->as)
+	{
+	  gfc_conv_expr_descriptor (se, expr, ss);
+	  se->expr = gfc_conv_array_data (se->expr);
+	  return;
+	}
+
       if (!sym->attr.pointer && sym->as->type != AS_ASSUMED_SHAPE 
           && !sym->attr.allocatable)
         {
@@ -5514,6 +5532,7 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
 	    array_parameter_size (tmp, expr, size);
 	  return;
         }
+
       if (sym->attr.allocatable)
         {
 	  if (sym->attr.dummy || sym->attr.result)
@@ -5528,6 +5547,18 @@ gfc_conv_array_parameter (gfc_se * se, gfc_expr * expr, gfc_ss * ss, int g77,
         }
     }
 
+  if (contiguous && g77 && !this_array_result
+	&& !expr->symtree->n.sym->attr.dummy)
+    {
+      gfc_conv_expr_descriptor (se, expr, ss);
+      if (expr->ts.type == BT_CHARACTER)
+	se->string_length = expr->ts.u.cl->backend_decl;
+      if (size)
+	array_parameter_size (se->expr, expr, size);
+      se->expr = gfc_conv_array_data (se->expr);
+      return;
+    }
+
   if (this_array_result)
     {
       /* Result of the enclosing function.  */
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 30561bb168e..fd8a806d7d0 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1811,7 +1811,23 @@ build_dt (tree function, gfc_code * code)
   dt_parm = var;
   dt_post_end_block = &post_end_block;
 
-  gfc_add_expr_to_block (&block, gfc_trans_code (code->block->next));
+  /* Set implied do loop exit condition.  */
+  if (last_dt == READ || last_dt == WRITE)
+    {
+      gfc_st_parameter_field *p = &st_parameter_field[IOPARM_common_flags];
+
+      tmp = fold_build3 (COMPONENT_REF, st_parameter[IOPARM_ptype_common].type,
+			 dt_parm, TYPE_FIELDS (TREE_TYPE (dt_parm)), NULL_TREE);
+      tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (p->field),
+			  tmp, p->field, NULL_TREE);
+      tmp = fold_build2 (BIT_AND_EXPR, TREE_TYPE (tmp),
+			  tmp, build_int_cst (TREE_TYPE (tmp),
+			  IOPARM_common_libreturn_mask));
+    }
+  else /* IOLENGTH */
+    tmp = NULL_TREE;
+
+  gfc_add_expr_to_block (&block, gfc_trans_code_cond (code->block->next, tmp));
 
   gfc_add_block_to_block (&block, &post_iu_block);
 
diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index 84c3c85ead4..60bffdf96d6 100644
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -831,7 +831,7 @@ gfc_trans_block_construct (gfc_code* code)
 
 static tree
 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
-		     tree from, tree to, tree step)
+		     tree from, tree to, tree step, tree exit_cond)
 {
   stmtblock_t body;
   tree type;
@@ -864,7 +864,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
   gfc_start_block (&body);
 
   /* Main loop body.  */
-  tmp = gfc_trans_code (code->block->next);
+  tmp = gfc_trans_code_cond (code->block->next, exit_cond);
   gfc_add_expr_to_block (&body, tmp);
 
   /* Label for cycle statements (if needed).  */
@@ -882,6 +882,15 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
 			       "Loop variable has been modified");
     }
 
+  /* Exit the loop if there is an I/O result condition or error.  */
+  if (exit_cond)
+    {
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      tmp = fold_build3 (COND_EXPR, void_type_node, exit_cond, tmp,
+			 build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
   /* Evaluate the loop condition.  */
   cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
   cond = gfc_evaluate_now (cond, &body);
@@ -955,7 +964,7 @@ exit_label:
    because the loop count itself can overflow.  */
 
 tree
-gfc_trans_do (gfc_code * code)
+gfc_trans_do (gfc_code * code, tree exit_cond)
 {
   gfc_se se;
   tree dovar;
@@ -1010,7 +1019,7 @@ gfc_trans_do (gfc_code * code)
   if (TREE_CODE (type) == INTEGER_TYPE
       && (integer_onep (step)
 	|| tree_int_cst_equal (step, integer_minus_one_node)))
-    return gfc_trans_simple_do (code, &block, dovar, from, to, step);
+    return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond);
 
   pos_step = fold_build2 (GT_EXPR, boolean_type_node, step,
 			  fold_convert (type, integer_zero_node));
@@ -1125,7 +1134,7 @@ gfc_trans_do (gfc_code * code)
   code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
 
   /* Main loop body.  */
-  tmp = gfc_trans_code (code->block->next);
+  tmp = gfc_trans_code_cond (code->block->next, exit_cond);
   gfc_add_expr_to_block (&body, tmp);
 
   /* Label for cycle statements (if needed).  */
@@ -1143,6 +1152,15 @@ gfc_trans_do (gfc_code * code)
 			       "Loop variable has been modified");
     }
 
+  /* Exit the loop if there is an I/O result condition or error.  */
+  if (exit_cond)
+    {
+      tmp = build1_v (GOTO_EXPR, exit_label);
+      tmp = fold_build3 (COND_EXPR, void_type_node, exit_cond, tmp,
+			 build_empty_stmt (input_location));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
   /* Increment the loop variable.  */
   tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
   gfc_add_modify (&body, dovar, tmp);
diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h
index e6faacd0022..46abc09a098 100644
--- a/gcc/fortran/trans-stmt.h
+++ b/gcc/fortran/trans-stmt.h
@@ -23,6 +23,9 @@ along with GCC; see the file COPYING3.  If not see
    Calls gfc_trans_*.  */
 tree gfc_trans_code (gfc_code *);
 
+/* Wrapper function used to pass a check condition for implied DO loops.  */
+tree gfc_trans_code_cond (gfc_code *, tree);
+
 /* All other gfc_trans_* should only need be called by gfc_trans_code */
 
 /* trans-expr.c */
@@ -45,7 +48,7 @@ tree gfc_trans_return (gfc_code *);
 tree gfc_trans_if (gfc_code *);
 tree gfc_trans_arithmetic_if (gfc_code *);
 tree gfc_trans_block_construct (gfc_code *);
-tree gfc_trans_do (gfc_code *);
+tree gfc_trans_do (gfc_code *, tree);
 tree gfc_trans_do_while (gfc_code *);
 tree gfc_trans_select (gfc_code *);
 tree gfc_trans_forall (gfc_code *);
diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c
index a5bb6418780..535e639faad 100644
--- a/gcc/fortran/trans.c
+++ b/gcc/fortran/trans.c
@@ -1048,10 +1048,12 @@ gfc_set_backend_locus (locus * loc)
 }
 
 
-/* Translate an executable statement.  */
+/* Translate an executable statement. The tree cond is used by gfc_trans_do.
+   This static function is wrapped by gfc_trans_code_cond and
+   gfc_trans_code.  */
 
-tree
-gfc_trans_code (gfc_code * code)
+static tree
+trans_code (gfc_code * code, tree cond)
 {
   stmtblock_t block;
   tree res;
@@ -1172,7 +1174,7 @@ gfc_trans_code (gfc_code * code)
 	  break;
 
 	case EXEC_DO:
-	  res = gfc_trans_do (code);
+	  res = gfc_trans_do (code, cond);
 	  break;
 
 	case EXEC_DO_WHILE:
@@ -1298,6 +1300,25 @@ gfc_trans_code (gfc_code * code)
 }
 
 
+/* Translate an executable statement with condition, cond.  The condition is
+   used by gfc_trans_do to test for IO result conditions inside implied
+   DO loops of READ and WRITE statements.  See build_dt in trans-io.c.  */
+
+tree
+gfc_trans_code_cond (gfc_code * code, tree cond)
+{
+  return trans_code (code, cond);
+}
+
+/* Translate an executable statement without condition.  */
+
+tree
+gfc_trans_code (gfc_code * code)
+{
+  return trans_code (code, NULL_TREE);
+}
+
+
 /* This function is called after a complete program unit has been parsed
    and resolved.  */