Backport from gomp-20050608-branch

	* trans-decl.c (create_function_arglist): Handle dummy functions.

	* trans-decl.c (gfc_get_symbol_decl): Revert explicit setting of
	TYPE_SIZE_UNIT.
	(gfc_trans_vla_type_sizes): Also "gimplify"
	GFC_TYPE_ARRAY_DATAPTR_TYPE for GFC_DESCRIPTOR_TYPE_P types.
	* trans-array.c (gfc_trans_deferred_array): Call
	gfc_trans_vla_type_sizes.

	* trans-decl.c (saved_function_decls, saved_parent_function_decls):
	Remove unnecessary initialization.
	(create_function_arglist): Make sure __result has complete type.
	(gfc_get_fake_result_decl): Change current_fake_result_decl into
	a tree chain.  For entry master, create a separate variable
	for each result name.  For BT_CHARACTER results, call
	gfc_finish_var_decl on length even if it has been already created,
	but not pushdecl'ed.
	(gfc_trans_vla_type_sizes): For function/entry result, adjust
	result value type, not the FUNCTION_TYPE.
	(gfc_generate_function_code): Adjust for current_fake_result_decl
	changes.
	(gfc_trans_deferred_vars): Likewise.  Call gfc_trans_vla_type_sizes
	even on result if it is assumed-length character.

	* trans-decl.c (gfc_trans_dummy_character): Add SYM argument.
	Call gfc_trans_vla_type_sizes.
	(gfc_trans_auto_character_variable): Call gfc_trans_vla_type_sizes.
	(gfc_trans_vla_one_sizepos, gfc_trans_vla_type_sizes_1,
	gfc_trans_vla_type_sizes): New functions.
	(gfc_trans_deferred_vars): Adjust gfc_trans_dummy_character
	callers.  Call gfc_trans_vla_type_sizes on assumed-length
	character parameters.
	* trans-array.c (gfc_trans_array_bounds,
	gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias): Call
	gfc_trans_vla_type_sizes.
	* trans.h (gfc_trans_vla_type_sizes): New prototype.

	* trans-decl.c (gfc_build_qualified_array): For non-assumed-size
	arrays without constant size, create also an index var for
	GFC_TYPE_ARRAY_SIZE (type).  If the type is incomplete, complete
	it as 0..size-1.
	(gfc_create_string_length): Don't call gfc_defer_symbol_init
	if just creating DECL_ARGUMENTS.
	(gfc_get_symbol_decl): Call gfc_finish_var_decl and
	gfc_defer_symbol_init even if ts.cl->backend_decl is already
	set to a VAR_DECL that doesn't have DECL_CONTEXT yet.
	(create_function_arglist): Rework, so that hidden length
	arguments for CHARACTER parameters are created together with
	the parameters.  Resolve ts.cl->backend_decl for CHARACTER
	parameters.  If the argument is a non-constant length array
	or CHARACTER, ensure PARM_DECL has different type than
	its DECL_ARG_TYPE.
	(generate_local_decl): Call gfc_get_symbol_decl even
	for non-referenced non-constant length CHARACTER parameters
	after optionally issuing warnings.
	* trans-array.c (gfc_trans_array_bounds): Set last stride
	to GFC_TYPE_ARRAY_SIZE (type) to initialize it as well.
	(gfc_trans_dummy_array_bias): Initialize GFC_TYPE_ARRAY_SIZE (type)
	variable as well.

	* trans-expr.c (gfc_conv_expr_val): Fix comment typo.

	* trans-stmt.c (gfc_trans_simple_do): Fix comment.

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

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index d2a51f4..baef826 100644 (file)
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,70 @@
+2006-02-06  Jakub Jelinek  <jakub@redhat.com>
+
+       Backport from gomp-20050608-branch
+       * trans-decl.c (create_function_arglist): Handle dummy functions.
+
+       * trans-decl.c (gfc_get_symbol_decl): Revert explicit setting of
+       TYPE_SIZE_UNIT.
+       (gfc_trans_vla_type_sizes): Also "gimplify"
+       GFC_TYPE_ARRAY_DATAPTR_TYPE for GFC_DESCRIPTOR_TYPE_P types.
+       * trans-array.c (gfc_trans_deferred_array): Call
+       gfc_trans_vla_type_sizes.
+
+       * trans-decl.c (saved_function_decls, saved_parent_function_decls):
+       Remove unnecessary initialization.
+       (create_function_arglist): Make sure __result has complete type.
+       (gfc_get_fake_result_decl): Change current_fake_result_decl into
+       a tree chain.  For entry master, create a separate variable
+       for each result name.  For BT_CHARACTER results, call
+       gfc_finish_var_decl on length even if it has been already created,
+       but not pushdecl'ed.
+       (gfc_trans_vla_type_sizes): For function/entry result, adjust
+       result value type, not the FUNCTION_TYPE.
+       (gfc_generate_function_code): Adjust for current_fake_result_decl
+       changes.
+       (gfc_trans_deferred_vars): Likewise.  Call gfc_trans_vla_type_sizes
+       even on result if it is assumed-length character.
+
+       * trans-decl.c (gfc_trans_dummy_character): Add SYM argument.
+       Call gfc_trans_vla_type_sizes.
+       (gfc_trans_auto_character_variable): Call gfc_trans_vla_type_sizes.
+       (gfc_trans_vla_one_sizepos, gfc_trans_vla_type_sizes_1,
+       gfc_trans_vla_type_sizes): New functions.
+       (gfc_trans_deferred_vars): Adjust gfc_trans_dummy_character
+       callers.  Call gfc_trans_vla_type_sizes on assumed-length
+       character parameters.
+       * trans-array.c (gfc_trans_array_bounds,
+       gfc_trans_auto_array_allocation, gfc_trans_dummy_array_bias): Call
+       gfc_trans_vla_type_sizes.
+       * trans.h (gfc_trans_vla_type_sizes): New prototype.
+
+       * trans-decl.c (gfc_build_qualified_array): For non-assumed-size
+       arrays without constant size, create also an index var for
+       GFC_TYPE_ARRAY_SIZE (type).  If the type is incomplete, complete
+       it as 0..size-1.
+       (gfc_create_string_length): Don't call gfc_defer_symbol_init
+       if just creating DECL_ARGUMENTS.
+       (gfc_get_symbol_decl): Call gfc_finish_var_decl and
+       gfc_defer_symbol_init even if ts.cl->backend_decl is already
+       set to a VAR_DECL that doesn't have DECL_CONTEXT yet.
+       (create_function_arglist): Rework, so that hidden length
+       arguments for CHARACTER parameters are created together with
+       the parameters.  Resolve ts.cl->backend_decl for CHARACTER
+       parameters.  If the argument is a non-constant length array
+       or CHARACTER, ensure PARM_DECL has different type than
+       its DECL_ARG_TYPE.
+       (generate_local_decl): Call gfc_get_symbol_decl even
+       for non-referenced non-constant length CHARACTER parameters
+       after optionally issuing warnings.
+       * trans-array.c (gfc_trans_array_bounds): Set last stride
+       to GFC_TYPE_ARRAY_SIZE (type) to initialize it as well.
+       (gfc_trans_dummy_array_bias): Initialize GFC_TYPE_ARRAY_SIZE (type)
+       variable as well.
+
+       * trans-expr.c (gfc_conv_expr_val): Fix comment typo.
+
+       * trans-stmt.c (gfc_trans_simple_do): Fix comment.
+

 2006-02-04  Roger Sayle  <roger@eyesopen.com>
 
        * dependency.c (gfc_check_dependency): Remove unused vars and nvars
 2006-02-04  Roger Sayle  <roger@eyesopen.com>
 
        * dependency.c (gfc_check_dependency): Remove unused vars and nvars

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index cc8e97e..1edc7b7 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -3255,7 +3255,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
       if (dim + 1 < as->rank)
         stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
       else
       if (dim + 1 < as->rank)
         stride = GFC_TYPE_ARRAY_STRIDE (type, dim + 1);
       else

-        stride = NULL_TREE;
+       stride = GFC_TYPE_ARRAY_SIZE (type);

 
       if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
         {
 
       if (ubound != NULL_TREE && !(stride && INTEGER_CST_P (stride)))
         {


@@ -3273,6 +3273,8 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
       size = stride;
     }
 
       size = stride;
     }
 

+  gfc_trans_vla_type_sizes (sym, pblock);
+

   *poffset = offset;
   return size;
 }
   *poffset = offset;
   return size;
 }


@@ -3309,6 +3311,8 @@ gfc_trans_auto_array_allocation (tree decl, gfc_symbol * sym, tree fnbody)
     {
       gfc_trans_init_string_length (sym->ts.cl, &block);
 
     {
       gfc_trans_init_string_length (sym->ts.cl, &block);
 

+      gfc_trans_vla_type_sizes (sym, &block);
+

       /* Emit a DECL_EXPR for this variable, which will cause the
         gimplifier to allocate storage, and all that good stuff.  */
       tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
       /* Emit a DECL_EXPR for this variable, which will cause the
         gimplifier to allocate storage, and all that good stuff.  */
       tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);


@@ -3661,12 +3665,30 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc, tree body)
               gfc_add_modify_expr (&block, stride, tmp);
             }
         }
               gfc_add_modify_expr (&block, stride, tmp);
             }
         }

+      else
+       {
+         stride = GFC_TYPE_ARRAY_SIZE (type);
+
+         if (stride && !INTEGER_CST_P (stride))
+           {
+             /* Calculate size = stride * (ubound + 1 - lbound).  */
+             tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+                                gfc_index_one_node, lbound);
+             tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
+                                ubound, tmp);
+             tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
+                                GFC_TYPE_ARRAY_STRIDE (type, n), tmp);
+             gfc_add_modify_expr (&block, stride, tmp);
+           }
+       }

     }
 
   /* Set the offset.  */
   if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
     gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
 
     }
 
   /* Set the offset.  */
   if (TREE_CODE (GFC_TYPE_ARRAY_OFFSET (type)) == VAR_DECL)
     gfc_add_modify_expr (&block, GFC_TYPE_ARRAY_OFFSET (type), offset);
 

+  gfc_trans_vla_type_sizes (sym, &block);
+

   stmt = gfc_finish_block (&block);
 
   gfc_start_block (&block);
   stmt = gfc_finish_block (&block);
 
   gfc_start_block (&block);


@@ -4268,7 +4290,10 @@ gfc_trans_deferred_array (gfc_symbol * sym, tree body)
 
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.cl->backend_decl))
 
   if (sym->ts.type == BT_CHARACTER
       && !INTEGER_CST_P (sym->ts.cl->backend_decl))

-    gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+    {
+      gfc_trans_init_string_length (sym->ts.cl, &fnblock);
+      gfc_trans_vla_type_sizes (sym, &fnblock);
+    }

 
   /* Dummy and use associated variables don't need anything special.  */
   if (sym->attr.dummy || sym->attr.use_assoc)
 
   /* Dummy and use associated variables don't need anything special.  */
   if (sym->attr.dummy || sym->attr.use_assoc)

diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 2a92f5d..cdbb999 100644 (file)
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -55,8 +55,8 @@ static GTY(()) tree current_function_return_label;
 
 /* Holds the variable DECLs for the current function.  */
 
 
 /* Holds the variable DECLs for the current function.  */
 

-static GTY(()) tree saved_function_decls = NULL_TREE;
-static GTY(()) tree saved_parent_function_decls = NULL_TREE;
+static GTY(()) tree saved_function_decls;
+static GTY(()) tree saved_parent_function_decls;

 
 
 /* The namespace of the module we're currently generating.  Only used while
 
 
 /* The namespace of the module we're currently generating.  Only used while


@@ -614,6 +614,30 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
       else
        gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
     }
       else
        gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
     }

+
+  if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
+      && sym->as->type != AS_ASSUMED_SIZE)
+    GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+
+  if (POINTER_TYPE_P (type))
+    {
+      gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
+      gcc_assert (TYPE_LANG_SPECIFIC (type)
+                 == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
+      type = TREE_TYPE (type);
+    }
+
+  if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
+    {
+      tree size, range;
+
+      size = build2 (MINUS_EXPR, gfc_array_index_type,
+                    GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
+      range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
+                               size);
+      TYPE_DOMAIN (type) = range;
+      layout_type (type);
+    }

 }
 
 
 }
 
 


@@ -762,7 +786,8 @@ gfc_create_string_length (gfc_symbol * sym)
                           gfc_charlen_type_node);
       DECL_ARTIFICIAL (length) = 1;
       TREE_USED (length) = 1;
                           gfc_charlen_type_node);
       DECL_ARTIFICIAL (length) = 1;
       TREE_USED (length) = 1;

-      gfc_defer_symbol_init (sym);
+      if (sym->ns->proc_name->tlink != NULL)
+       gfc_defer_symbol_init (sym);

       sym->ts.cl->backend_decl = length;
     }
 
       sym->ts.cl->backend_decl = length;
     }
 


@@ -810,9 +835,7 @@ tree
 gfc_get_symbol_decl (gfc_symbol * sym)
 {
   tree decl;
 gfc_get_symbol_decl (gfc_symbol * sym)
 {
   tree decl;

-  tree etype = NULL_TREE;

   tree length = NULL_TREE;
   tree length = NULL_TREE;

-  tree tmp = NULL_TREE;

   int byref;
 
   gcc_assert (sym->attr.referenced);
   int byref;
 
   gcc_assert (sym->attr.referenced);


@@ -843,28 +866,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       if (sym->ts.type == BT_CHARACTER)
        {
          if (sym->ts.cl->backend_decl == NULL_TREE)
       if (sym->ts.type == BT_CHARACTER)
        {
          if (sym->ts.cl->backend_decl == NULL_TREE)

+           length = gfc_create_string_length (sym);
+         else
+           length = sym->ts.cl->backend_decl;
+         if (TREE_CODE (length) == VAR_DECL
+             && DECL_CONTEXT (length) == NULL_TREE)

            {
            {

-             length = gfc_create_string_length (sym);
-             if (TREE_CODE (length) != INTEGER_CST)
-               {
-                 gfc_finish_var_decl (length, sym);
-                 gfc_defer_symbol_init (sym);
-               }
-           }
-
-         /* Set the element size of automatic and assumed character length
-            length, dummy, pointer arrays.  */
-         if (sym->attr.pointer && sym->attr.dummy
-               && sym->attr.dimension)
-           {
-             tmp = build_fold_indirect_ref (sym->backend_decl);
-             etype = gfc_get_element_type (TREE_TYPE (tmp));
-             if (TYPE_SIZE_UNIT (etype) == NULL_TREE)
-               {
-                 tmp = TYPE_SIZE_UNIT (gfc_character1_type_node);
-                 tmp = fold_convert (TREE_TYPE (tmp), sym->ts.cl->backend_decl);
-                 TYPE_SIZE_UNIT (etype) = tmp;
-               }
+             gfc_finish_var_decl (length, sym);
+             gfc_defer_symbol_init (sym);

            }
        }
 
            }
        }
 


@@ -1241,9 +1250,8 @@ create_function_arglist (gfc_symbol * sym)
 {
   tree fndecl;
   gfc_formal_arglist *f;
 {
   tree fndecl;
   gfc_formal_arglist *f;

-  tree typelist;
-  tree arglist;
-  tree length;
+  tree typelist, hidden_typelist;
+  tree arglist, hidden_arglist;

   tree type;
   tree parm;
 
   tree type;
   tree parm;
 


@@ -1252,6 +1260,7 @@ create_function_arglist (gfc_symbol * sym)
   /* Build formal argument list. Make sure that their TREE_CONTEXT is
      the new FUNCTION_DECL node.  */
   arglist = NULL_TREE;
   /* Build formal argument list. Make sure that their TREE_CONTEXT is
      the new FUNCTION_DECL node.  */
   arglist = NULL_TREE;

+  hidden_arglist = NULL_TREE;

   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
 
   if (sym->attr.entry_master)
   typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
 
   if (sym->attr.entry_master)


@@ -1270,131 +1279,186 @@ create_function_arglist (gfc_symbol * sym)
 
   if (gfc_return_by_reference (sym))
     {
 
   if (gfc_return_by_reference (sym))
     {

-      type = TREE_VALUE (typelist);
-      parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
-
-      DECL_CONTEXT (parm) = fndecl;
-      DECL_ARG_TYPE (parm) = type;
-      TREE_READONLY (parm) = 1;
-      DECL_ARTIFICIAL (parm) = 1;
-      gfc_finish_decl (parm, NULL_TREE);
-
-      arglist = chainon (arglist, parm);
-      typelist = TREE_CHAIN (typelist);
+      tree type = TREE_VALUE (typelist), length = NULL;

 
       if (sym->ts.type == BT_CHARACTER)
        {
 
       if (sym->ts.type == BT_CHARACTER)
        {

-         gfc_allocate_lang_decl (parm);
-

          /* Length of character result.  */
          /* Length of character result.  */

-         type = TREE_VALUE (typelist);
-         gcc_assert (type == gfc_charlen_type_node);
+         tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
+         gcc_assert (len_type == gfc_charlen_type_node);

 
          length = build_decl (PARM_DECL,
                               get_identifier (".__result"),
 
          length = build_decl (PARM_DECL,
                               get_identifier (".__result"),

-                              type);
+                              len_type);

          if (!sym->ts.cl->length)
            {
              sym->ts.cl->backend_decl = length;
              TREE_USED (length) = 1;
            }
          gcc_assert (TREE_CODE (length) == PARM_DECL);
          if (!sym->ts.cl->length)
            {
              sym->ts.cl->backend_decl = length;
              TREE_USED (length) = 1;
            }
          gcc_assert (TREE_CODE (length) == PARM_DECL);

-         arglist = chainon (arglist, length);
-         typelist = TREE_CHAIN (typelist);

          DECL_CONTEXT (length) = fndecl;
          DECL_CONTEXT (length) = fndecl;

-         DECL_ARG_TYPE (length) = type;
+         DECL_ARG_TYPE (length) = len_type;

          TREE_READONLY (length) = 1;
          DECL_ARTIFICIAL (length) = 1;
          gfc_finish_decl (length, NULL_TREE);
          TREE_READONLY (length) = 1;
          DECL_ARTIFICIAL (length) = 1;
          gfc_finish_decl (length, NULL_TREE);

-       }
-    }
-
-  for (f = sym->formal; f; f = f->next)
-    {
-      if (f->sym != NULL)      /* ignore alternate returns.  */
-       {
-         length = NULL_TREE;
+         if (sym->ts.cl->backend_decl == NULL
+             || sym->ts.cl->backend_decl == length)
+           {
+             gfc_symbol *arg;
+             tree backend_decl;

 
 

-         type = TREE_VALUE (typelist);
+             if (sym->ts.cl->backend_decl == NULL)
+               {
+                 tree len = build_decl (VAR_DECL,
+                                        get_identifier ("..__result"),
+                                        gfc_charlen_type_node);
+                 DECL_ARTIFICIAL (len) = 1;
+                 TREE_USED (len) = 1;
+                 sym->ts.cl->backend_decl = len;
+               }

 
 

-         /* Build a the argument declaration.  */
-         parm = build_decl (PARM_DECL,
-                            gfc_sym_identifier (f->sym), type);
+             /* Make sure PARM_DECL type doesn't point to incomplete type.  */
+             arg = sym->result ? sym->result : sym;
+             backend_decl = arg->backend_decl;
+             /* Temporary clear it, so that gfc_sym_type creates complete
+                type.  */
+             arg->backend_decl = NULL;
+             type = gfc_sym_type (arg);
+             arg->backend_decl = backend_decl;
+             type = build_reference_type (type);
+           }
+       }

 
 

-         /* Fill in arg stuff.  */
-         DECL_CONTEXT (parm) = fndecl;
-         DECL_ARG_TYPE (parm) = type;
-         /* All implementation args are read-only.  */
-         TREE_READONLY (parm) = 1;
+      parm = build_decl (PARM_DECL, get_identifier ("__result"), type);

 
 

-         gfc_finish_decl (parm, NULL_TREE);
+      DECL_CONTEXT (parm) = fndecl;
+      DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+      TREE_READONLY (parm) = 1;
+      DECL_ARTIFICIAL (parm) = 1;
+      gfc_finish_decl (parm, NULL_TREE);

 
 

-         f->sym->backend_decl = parm;
+      arglist = chainon (arglist, parm);
+      typelist = TREE_CHAIN (typelist);

 
 

-         arglist = chainon (arglist, parm);
+      if (sym->ts.type == BT_CHARACTER)
+       {
+         gfc_allocate_lang_decl (parm);
+         arglist = chainon (arglist, length);

          typelist = TREE_CHAIN (typelist);
        }
     }
 
          typelist = TREE_CHAIN (typelist);
        }
     }
 

-  /* Add the hidden string length parameters.  */
-  parm = arglist;
+  hidden_typelist = typelist;
+  for (f = sym->formal; f; f = f->next)
+    if (f->sym != NULL)        /* Ignore alternate returns.  */
+      hidden_typelist = TREE_CHAIN (hidden_typelist);
+

   for (f = sym->formal; f; f = f->next)
     {
       char name[GFC_MAX_SYMBOL_LEN + 2];
   for (f = sym->formal; f; f = f->next)
     {
       char name[GFC_MAX_SYMBOL_LEN + 2];

+

       /* Ignore alternate returns.  */
       if (f->sym == NULL)
        continue;
 
       /* Ignore alternate returns.  */
       if (f->sym == NULL)
        continue;
 

-      if (f->sym->ts.type != BT_CHARACTER)
-       continue;
-
-      parm = f->sym->backend_decl;

       type = TREE_VALUE (typelist);
       type = TREE_VALUE (typelist);

-      gcc_assert (type == gfc_charlen_type_node);

 
 

-      strcpy (&name[1], f->sym->name);
-      name[0] = '_';
-      length = build_decl (PARM_DECL, get_identifier (name), type);
+      if (f->sym->ts.type == BT_CHARACTER)
+       {
+         tree len_type = TREE_VALUE (hidden_typelist);
+         tree length = NULL_TREE;
+         gcc_assert (len_type == gfc_charlen_type_node);

 
 

-      arglist = chainon (arglist, length);
-      DECL_CONTEXT (length) = fndecl;
-      DECL_ARTIFICIAL (length) = 1;
-      DECL_ARG_TYPE (length) = type;
-      TREE_READONLY (length) = 1;
-      gfc_finish_decl (length, NULL_TREE);
+         strcpy (&name[1], f->sym->name);
+         name[0] = '_';
+         length = build_decl (PARM_DECL, get_identifier (name), len_type);

 
 

-      /* TODO: Check string lengths when -fbounds-check.  */
+         hidden_arglist = chainon (hidden_arglist, length);
+         DECL_CONTEXT (length) = fndecl;
+         DECL_ARTIFICIAL (length) = 1;
+         DECL_ARG_TYPE (length) = len_type;
+         TREE_READONLY (length) = 1;
+         gfc_finish_decl (length, NULL_TREE);

 
 

-      /* Use the passed value for assumed length variables.  */
-      if (!f->sym->ts.cl->length)
-       {
-         TREE_USED (length) = 1;
-         if (!f->sym->ts.cl->backend_decl)
-           f->sym->ts.cl->backend_decl = length;
-         else
+         /* TODO: Check string lengths when -fbounds-check.  */
+
+         /* Use the passed value for assumed length variables.  */
+         if (!f->sym->ts.cl->length)

            {
            {

-             /* there is already another variable using this
-                gfc_charlen node, build a new one for this variable
-                and chain it into the list of gfc_charlens.
-                This happens for e.g. in the case
-                CHARACTER(*)::c1,c2
-                since CHARACTER declarations on the same line share
-                the same gfc_charlen node.  */
-             gfc_charlen *cl;
+             TREE_USED (length) = 1;
+             if (!f->sym->ts.cl->backend_decl)
+               f->sym->ts.cl->backend_decl = length;
+             else
+               {
+                 /* there is already another variable using this
+                    gfc_charlen node, build a new one for this variable
+                    and chain it into the list of gfc_charlens.
+                    This happens for e.g. in the case
+                    CHARACTER(*)::c1,c2
+                    since CHARACTER declarations on the same line share
+                    the same gfc_charlen node.  */
+                 gfc_charlen *cl;

              
              

-             cl = gfc_get_charlen ();
-             cl->backend_decl = length;
-             cl->next = f->sym->ts.cl->next;
-             f->sym->ts.cl->next = cl;
-             f->sym->ts.cl = cl;
+                 cl = gfc_get_charlen ();
+                 cl->backend_decl = length;
+                 cl->next = f->sym->ts.cl->next;
+                 f->sym->ts.cl->next = cl;
+                 f->sym->ts.cl = cl;
+               }
+           }
+
+         hidden_typelist = TREE_CHAIN (hidden_typelist);
+
+         if (f->sym->ts.cl->backend_decl == NULL
+             || f->sym->ts.cl->backend_decl == length)
+           {
+             if (f->sym->ts.cl->backend_decl == NULL)
+               gfc_create_string_length (f->sym);
+
+             /* Make sure PARM_DECL type doesn't point to incomplete type.  */
+             if (f->sym->attr.flavor == FL_PROCEDURE)
+               type = build_pointer_type (gfc_get_function_type (f->sym));
+             else
+               type = gfc_sym_type (f->sym);

            }
        }
 
            }
        }
 

-      parm = TREE_CHAIN (parm);
+      /* For non-constant length array arguments, make sure they use
+        a different type node from TYPE_ARG_TYPES type.  */
+      if (f->sym->attr.dimension
+         && type == TREE_VALUE (typelist)
+         && TREE_CODE (type) == POINTER_TYPE
+         && GFC_ARRAY_TYPE_P (type)
+         && f->sym->as->type != AS_ASSUMED_SIZE
+         && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
+       {
+         if (f->sym->attr.flavor == FL_PROCEDURE)
+           type = build_pointer_type (gfc_get_function_type (f->sym));
+         else
+           type = gfc_sym_type (f->sym);
+       }
+
+      /* Build a the argument declaration.  */
+      parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
+
+      /* Fill in arg stuff.  */
+      DECL_CONTEXT (parm) = fndecl;
+      DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+      /* All implementation args are read-only.  */
+      TREE_READONLY (parm) = 1;
+
+      gfc_finish_decl (parm, NULL_TREE);
+
+      f->sym->backend_decl = parm;
+
+      arglist = chainon (arglist, parm);

       typelist = TREE_CHAIN (typelist);
     }
 
       typelist = TREE_CHAIN (typelist);
     }
 

-  gcc_assert (TREE_VALUE (typelist) == void_type_node);
+  /* Add the hidden string length parameters.  */
+  arglist = chainon (arglist, hidden_arglist);
+
+  gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);

   DECL_ARGUMENTS (fndecl) = arglist;
 }
 
   DECL_ARGUMENTS (fndecl) = arglist;
 }
 


@@ -1658,18 +1722,24 @@ gfc_create_function_decl (gfc_namespace * ns)
 tree
 gfc_get_fake_result_decl (gfc_symbol * sym)
 {
 tree
 gfc_get_fake_result_decl (gfc_symbol * sym)
 {

-  tree decl;
-  tree length;
+  tree decl, length;

 
   char name[GFC_MAX_SYMBOL_LEN + 10];
 
   if (sym
       && sym->ns->proc_name->backend_decl == current_function_decl
 
   char name[GFC_MAX_SYMBOL_LEN + 10];
 
   if (sym
       && sym->ns->proc_name->backend_decl == current_function_decl

-      && sym->ns->proc_name->attr.mixed_entry_master
+      && sym->ns->proc_name->attr.entry_master

       && sym != sym->ns->proc_name)
     {
       && sym != sym->ns->proc_name)
     {

+      tree t = NULL, var;
+      if (current_fake_result_decl != NULL)
+       for (t = TREE_CHAIN (current_fake_result_decl); t; t = TREE_CHAIN (t))
+         if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
+           break;
+      if (t)
+       return TREE_VALUE (t);

       decl = gfc_get_fake_result_decl (sym->ns->proc_name);
       decl = gfc_get_fake_result_decl (sym->ns->proc_name);

-      if (decl)
+      if (decl && sym->ns->proc_name->attr.mixed_entry_master)

        {
          tree field;
 
        {
          tree field;
 


@@ -1683,22 +1753,32 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
          decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
                         NULL_TREE);
        }
          decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
                         NULL_TREE);
        }

-      return decl;
+      var = gfc_create_var (TREE_TYPE (decl), sym->name);
+      SET_DECL_VALUE_EXPR (var, decl);
+      DECL_HAS_VALUE_EXPR_P (var) = 1;
+      TREE_CHAIN (current_fake_result_decl)
+       = tree_cons (get_identifier (sym->name), var,
+                    TREE_CHAIN (current_fake_result_decl));
+      return var;

     }
 
   if (current_fake_result_decl != NULL_TREE)
     }
 
   if (current_fake_result_decl != NULL_TREE)

-    return current_fake_result_decl;
+    return TREE_VALUE (current_fake_result_decl);

 
   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
      sym is NULL.  */
   if (!sym)
     return NULL_TREE;
 
 
   /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
      sym is NULL.  */
   if (!sym)
     return NULL_TREE;
 

-  if (sym->ts.type == BT_CHARACTER
-      && !sym->ts.cl->backend_decl)
+  if (sym->ts.type == BT_CHARACTER)

     {
     {

-      length = gfc_create_string_length (sym);
-      gfc_finish_var_decl (length, sym);
+      if (sym->ts.cl->backend_decl == NULL_TREE)
+       length = gfc_create_string_length (sym);
+      else
+       length = sym->ts.cl->backend_decl;
+      if (TREE_CODE (length) == VAR_DECL
+         && DECL_CONTEXT (length) == NULL_TREE)
+       gfc_finish_var_decl (length, sym);

     }
 
   if (gfc_return_by_reference (sym))
     }
 
   if (gfc_return_by_reference (sym))


@@ -1731,7 +1811,7 @@ gfc_get_fake_result_decl (gfc_symbol * sym)
       gfc_add_decl_to_function (decl);
     }
 
       gfc_add_decl_to_function (decl);
     }
 

-  current_fake_result_decl = decl;
+  current_fake_result_decl = build_tree_list (NULL, decl);

 
   return decl;
 }
 
   return decl;
 }


@@ -2174,7 +2254,7 @@ gfc_build_builtin_function_decls (void)
 /* Evaluate the length of dummy character variables.  */
 
 static tree
 /* Evaluate the length of dummy character variables.  */
 
 static tree

-gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
+gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)

 {
   stmtblock_t body;
 
 {
   stmtblock_t body;
 


@@ -2184,7 +2264,9 @@ gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
 
   /* Evaluate the string length expression.  */
   gfc_trans_init_string_length (cl, &body);
 
   /* Evaluate the string length expression.  */
   gfc_trans_init_string_length (cl, &body);

-  
+
+  gfc_trans_vla_type_sizes (sym, &body);
+

   gfc_add_expr_to_block (&body, fnbody);
   return gfc_finish_block (&body);
 }
   gfc_add_expr_to_block (&body, fnbody);
   return gfc_finish_block (&body);
 }


@@ -2207,6 +2289,8 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
   /* Evaluate the string length expression.  */
   gfc_trans_init_string_length (sym->ts.cl, &body);
 
   /* Evaluate the string length expression.  */
   gfc_trans_init_string_length (sym->ts.cl, &body);
 

+  gfc_trans_vla_type_sizes (sym, &body);
+

   decl = sym->backend_decl;
 
   /* Emit a DECL_EXPR for this variable, which will cause the
   decl = sym->backend_decl;
 
   /* Emit a DECL_EXPR for this variable, which will cause the


@@ -2237,6 +2321,112 @@ gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
   return gfc_finish_block (&body);
 }
 
   return gfc_finish_block (&body);
 }
 

+static void
+gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
+{
+  tree t = *tp, var, val;
+
+  if (t == NULL || t == error_mark_node)
+    return;
+  if (TREE_CONSTANT (t) || DECL_P (t))
+    return;
+
+  if (TREE_CODE (t) == SAVE_EXPR)
+    {
+      if (SAVE_EXPR_RESOLVED_P (t))
+       {
+         *tp = TREE_OPERAND (t, 0);
+         return;
+       }
+      val = TREE_OPERAND (t, 0);
+    }
+  else
+    val = t;
+
+  var = gfc_create_var_np (TREE_TYPE (t), NULL);
+  gfc_add_decl_to_function (var);
+  gfc_add_modify_expr (body, var, val);
+  if (TREE_CODE (t) == SAVE_EXPR)
+    TREE_OPERAND (t, 0) = var;
+  *tp = var;
+}
+
+static void
+gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
+{
+  tree t;
+
+  if (type == NULL || type == error_mark_node)
+    return;
+
+  type = TYPE_MAIN_VARIANT (type);
+
+  if (TREE_CODE (type) == INTEGER_TYPE)
+    {
+      gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
+
+      for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+       {
+         TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
+         TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
+       }
+    }
+  else if (TREE_CODE (type) == ARRAY_TYPE)
+    {
+      gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
+      gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
+      gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
+
+      for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+       {
+         TYPE_SIZE (t) = TYPE_SIZE (type);
+         TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
+       }
+    }
+}
+
+/* Make sure all type sizes and array domains are either constant,
+   or variable or parameter decls.  This is a simplified variant
+   of gimplify_type_sizes, but we can't use it here, as none of the
+   variables in the expressions have been gimplified yet.
+   As type sizes and domains for various variable length arrays
+   contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
+   time, without this routine gimplify_type_sizes in the middle-end
+   could result in the type sizes being gimplified earlier than where
+   those variables are initialized.  */
+
+void
+gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
+{
+  tree type = TREE_TYPE (sym->backend_decl);
+
+  if (TREE_CODE (type) == FUNCTION_TYPE
+      && (sym->attr.function || sym->attr.result || sym->attr.entry))
+    {
+      if (! current_fake_result_decl)
+       return;
+
+      type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
+    }
+
+  while (POINTER_TYPE_P (type))
+    type = TREE_TYPE (type);
+
+  if (GFC_DESCRIPTOR_TYPE_P (type))
+    {
+      tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+
+      while (POINTER_TYPE_P (etype))
+       etype = TREE_TYPE (etype);
+
+      gfc_trans_vla_type_sizes_1 (etype, body);
+    }
+
+  gfc_trans_vla_type_sizes_1 (type, body);
+}
+

 
 /* Generate function entry and exit code, and add it to the function body.
    This includes:
 
 /* Generate function entry and exit code, and add it to the function body.
    This includes:


@@ -2250,6 +2440,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 {
   locus loc;
   gfc_symbol *sym;
 {
   locus loc;
   gfc_symbol *sym;

+  gfc_formal_arglist *f;
+  stmtblock_t body;

 
   /* Deal with implicit return variables.  Explicit return variables will
      already have been added.  */
 
   /* Deal with implicit return variables.  Explicit return variables will
      already have been added.  */


@@ -2269,14 +2461,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
        }
       else if (proc_sym->as)
        {
        }
       else if (proc_sym->as)
        {

-         fnbody = gfc_trans_dummy_array_bias (proc_sym,
-                                              current_fake_result_decl,
-                                              fnbody);
+         tree result = TREE_VALUE (current_fake_result_decl);
+         fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);

        }
       else if (proc_sym->ts.type == BT_CHARACTER)
        {
          if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
        }
       else if (proc_sym->ts.type == BT_CHARACTER)
        {
          if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)

-           fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
+           fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+                                               fnbody);

        }
       else
        gcc_assert (gfc_option.flag_f2c
        }
       else
        gcc_assert (gfc_option.flag_f2c


@@ -2339,7 +2531,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
          gfc_get_backend_locus (&loc);
          gfc_set_backend_locus (&sym->declared_at);
          if (sym->attr.dummy || sym->attr.result)
          gfc_get_backend_locus (&loc);
          gfc_set_backend_locus (&sym->declared_at);
          if (sym->attr.dummy || sym->attr.result)

-           fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
+           fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);

          else
            fnbody = gfc_trans_auto_character_variable (sym, fnbody);
          gfc_set_backend_locus (&loc);
          else
            fnbody = gfc_trans_auto_character_variable (sym, fnbody);
          gfc_set_backend_locus (&loc);


@@ -2355,7 +2547,26 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
        gcc_unreachable ();
     }
 
        gcc_unreachable ();
     }
 

-  return fnbody;
+  gfc_init_block (&body);
+
+  for (f = proc_sym->formal; f; f = f->next)
+    if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+      {
+       gcc_assert (f->sym->ts.cl->backend_decl != NULL);
+       if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
+         gfc_trans_vla_type_sizes (f->sym, &body);
+      }
+
+  if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
+      && current_fake_result_decl != NULL)
+    {
+      gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
+      if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
+       gfc_trans_vla_type_sizes (proc_sym, &body);
+    }
+
+  gfc_add_expr_to_block (&body, fnbody);
+  return gfc_finish_block (&body);

 }
 
 
 }
 
 


@@ -2477,6 +2688,19 @@ generate_local_decl (gfc_symbol * sym)
       else if (warn_unused_variable
               && !(sym->attr.in_common || sym->attr.use_assoc))
        warning (0, "unused variable %qs", sym->name); 
       else if (warn_unused_variable
               && !(sym->attr.in_common || sym->attr.use_assoc))
        warning (0, "unused variable %qs", sym->name); 

+      /* For variable length CHARACTER parameters, the PARM_DECL already
+        references the length variable, so force gfc_get_symbol_decl
+        even when not referenced.  If optimize > 0, it will be optimized
+        away anyway.  But do this only after emitting -Wunused-parameter
+        warning if requested.  */
+      if (sym->attr.dummy && ! sym->attr.referenced
+         && sym->ts.type == BT_CHARACTER
+         && sym->ts.cl->backend_decl != NULL
+         && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+       {
+         sym->attr.referenced = 1;
+         gfc_get_symbol_decl (sym);
+       }

     }
 }
 
     }
 }
 


@@ -2655,7 +2879,10 @@ gfc_generate_function_code (gfc_namespace * ns)
     {
       if (sym->attr.subroutine || sym == sym->result)
        {
     {
       if (sym->attr.subroutine || sym == sym->result)
        {

-         result = current_fake_result_decl;
+         if (current_fake_result_decl != NULL)
+           result = TREE_VALUE (current_fake_result_decl);
+         else
+           result = NULL_TREE;

          current_fake_result_decl = NULL_TREE;
        }
       else
          current_fake_result_decl = NULL_TREE;
        }
       else

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 2322705..2529fb7 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2656,7 +2656,7 @@ gfc_conv_expr_lhs (gfc_se * se, gfc_expr * expr)
 }
 
 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for
 }
 
 /* Like gfc_conv_expr, but the POST block is guaranteed to be empty for

-   numeric expressions.  Used for scalar values whee inserting cleanup code
+   numeric expressions.  Used for scalar values where inserting cleanup code

    is inconvenient.  */
 void
 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)
    is inconvenient.  */
 void
 gfc_conv_expr_val (gfc_se * se, gfc_expr * expr)

diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c
index b44774e..d6aa3d1 100644 (file)
--- a/gcc/fortran/trans-stmt.c
+++ b/gcc/fortran/trans-stmt.c
@@ -701,7 +701,7 @@ gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
    to:
 
    [evaluate loop bounds and step]
    to:
 
    [evaluate loop bounds and step]

-   count = to + step - from;
+   count = (to + step - from) / step;

    dovar = from;
    for (;;)
      {
    dovar = from;
    for (;;)
      {

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index e4f998a..c7c2301 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -320,6 +320,8 @@ tree gfc_conv_string_tmp (gfc_se *, tree, tree);
 tree gfc_get_expr_charlen (gfc_expr *);
 /* Initialize a string length variable.  */
 void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);
 tree gfc_get_expr_charlen (gfc_expr *);
 /* Initialize a string length variable.  */
 void gfc_trans_init_string_length (gfc_charlen *, stmtblock_t *);

+/* Ensure type sizes can be gimplified.  */
+void gfc_trans_vla_type_sizes (gfc_symbol *, stmtblock_t *);

 
 /* Add an expression to the end of a block.  */
 void gfc_add_expr_to_block (stmtblock_t *, tree);
 
 /* Add an expression to the end of a block.  */
 void gfc_add_expr_to_block (stmtblock_t *, tree);