[gcc] GCC 4.5.0=>4.5.1

gcc/gcc/fortran/trans-decl.c

 /* Backend function setup
-   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+   Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
    Free Software Foundation, Inc.
    Contributed by Paul Brook
 
 This file is part of GCC.
 
 GCC is free software; you can redistribute it and/or modify it under
 the terms of the GNU General Public License as published by the Free
 Software Foundation; either version 3, or (at your option) any later
 version.
 
@@ skipping 17 matching lines @@
 #include "ggc.h"
 #include "toplev.h"
 #include "tm.h"
 #include "rtl.h"
 #include "target.h"
 #include "function.h"
 #include "flags.h"
 #include "cgraph.h"
 #include "debug.h"
 #include "gfortran.h"
+#include "pointer-set.h"
 #include "trans.h"
 #include "trans-types.h"
 #include "trans-array.h"
 #include "trans-const.h"
 /* Only for gfc_trans_code.  Shouldn't need to include this.  */
 #include "trans-stmt.h"
 
 #define MAX_LABEL_VALUE 99999
 
 
 /* Holds the result of the function if no result variable specified.  */
 
 static GTY(()) tree current_fake_result_decl;
 static GTY(()) tree parent_fake_result_decl;
 
 static GTY(()) tree current_function_return_label;
 
 
 /* Holds the variable DECLs for the current function.  */
 
 static GTY(()) tree saved_function_decls;
 static GTY(()) tree saved_parent_function_decls;
 
+static struct pointer_set_t *nonlocal_dummy_decl_pset;
+static GTY(()) tree nonlocal_dummy_decls;
+
+/* Holds the variable DECLs that are locals.  */
+
+static GTY(()) tree saved_local_decls;
 
 /* The namespace of the module we're currently generating.  Only used while
    outputting decls for module variables.  Do not rely on this being set.  */
 
 static gfc_namespace *module_namespace;
 
 
 /* List of static constructor functions.  */
 
 tree gfc_static_ctors;
 
 
 /* Function declarations for builtin library functions.  */
 
 tree gfor_fndecl_pause_numeric;
 tree gfor_fndecl_pause_string;
 tree gfor_fndecl_stop_numeric;
 tree gfor_fndecl_stop_string;
 tree gfor_fndecl_runtime_error;
 tree gfor_fndecl_runtime_error_at;
 tree gfor_fndecl_runtime_warning_at;
 tree gfor_fndecl_os_error;
 tree gfor_fndecl_generate_error;
+tree gfor_fndecl_set_args;
 tree gfor_fndecl_set_fpe;
 tree gfor_fndecl_set_options;
 tree gfor_fndecl_set_convert;
 tree gfor_fndecl_set_record_marker;
 tree gfor_fndecl_set_max_subrecord_length;
 tree gfor_fndecl_ctime;
 tree gfor_fndecl_fdate;
 tree gfor_fndecl_ttynam;
 tree gfor_fndecl_in_pack;
 tree gfor_fndecl_in_unpack;
@@ skipping 73 matching lines @@
 void
 gfc_add_decl_to_function (tree decl)
 {
   gcc_assert (decl);
   TREE_USED (decl) = 1;
   DECL_CONTEXT (decl) = current_function_decl;
   TREE_CHAIN (decl) = saved_function_decls;
   saved_function_decls = decl;
 }
 
+static void
+add_decl_as_local (tree decl)
+{
+  gcc_assert (decl);
+  TREE_USED (decl) = 1;
+  DECL_CONTEXT (decl) = current_function_decl;
+  TREE_CHAIN (decl) = saved_local_decls;
+  saved_local_decls = decl;
+}
+
 
 /* Build a  backend label declaration.  Set TREE_USED for named labels.
    The context of the label is always the current_function_decl.  All
    labels are marked artificial.  */
 
 tree
 gfc_build_label_decl (tree label_id)
 {
   /* 2^32 temporaries should be enough.  */
   static unsigned int tmp_num = 1;
   tree label_decl;
   char *label_name;
 
   if (label_id == NULL_TREE)
     {
       /* Build an internal label name.  */
       ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
       label_id = get_identifier (label_name);
     }
   else
     label_name = NULL;
 
   /* Build the LABEL_DECL node. Labels have no type.  */
-  label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
+  label_decl = build_decl (input_location,
+                           LABEL_DECL, label_id, void_type_node);
   DECL_CONTEXT (label_decl) = current_function_decl;
   DECL_MODE (label_decl) = VOIDmode;
 
   /* We always define the label as used, even if the original source
      file never references the label.  We don't want all kinds of
      spurious warnings for old-style Fortran code with too many
      labels.  */
   TREE_USED (label_decl) = 1;
 
   DECL_ARTIFICIAL (label_decl) = 1;
@@ skipping 65 matching lines @@
       return label_decl;
     }
 }
 
 
 /* Convert a gfc_symbol to an identifier of the same name.  */
 
 static tree
 gfc_sym_identifier (gfc_symbol * sym)
 {
-  return (get_identifier (sym->name));
+  if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)
+    return (get_identifier ("MAIN__"));
+  else
+    return (get_identifier (sym->name));
 }
 
 
 /* Construct mangled name from symbol name.  */
 
 static tree
 gfc_sym_mangled_identifier (gfc_symbol * sym)
 {
   char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
 
@@ skipping 54 matching lines @@
         return get_identifier (sym->name);
     }
   else
     {
       snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
       return get_identifier (name);
     }
 }
 
 
+void
+gfc_set_decl_assembler_name (tree decl, tree name)
+{
+  tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);
+  SET_DECL_ASSEMBLER_NAME (decl, target_mangled);
+}
+
+
 /* Returns true if a variable of specified size should go on the stack.  */
 
 int
 gfc_can_put_var_on_stack (tree size)
 {
   unsigned HOST_WIDE_INT low;
 
   if (!INTEGER_CST_P (size))
     return 0;
 
@@ skipping 20 matching lines @@
    indirection.  */
 
 static void
 gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
 {
   tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
   tree value;
 
   /* Parameters need to be dereferenced.  */
   if (sym->cp_pointer->attr.dummy) 
-    ptr_decl = build_fold_indirect_ref (ptr_decl);
+    ptr_decl = build_fold_indirect_ref_loc (input_location,
+                                        ptr_decl);
 
   /* Check to see if we're dealing with a variable-sized array.  */
   if (sym->attr.dimension
       && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE) 
     {  
       /* These decls will be dereferenced later, so we don't dereference
          them here.  */
       value = convert (TREE_TYPE (decl), ptr_decl);
     }
   else
     {
       ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
                           ptr_decl);
-      value = build_fold_indirect_ref (ptr_decl);
+      value = build_fold_indirect_ref_loc (input_location,
+                                       ptr_decl);
     }
 
   SET_DECL_VALUE_EXPR (decl, value);
   DECL_HAS_VALUE_EXPR_P (decl) = 1;
   GFC_DECL_CRAY_POINTEE (decl) = 1;
   /* This is a fake variable just for debugging purposes.  */
   TREE_ASM_WRITTEN (decl) = 1;
 }
 
 
@@ skipping 51 matching lines @@
     TREE_ADDRESSABLE (decl) = 1;
   /* If it wasn't used we wouldn't be getting it.  */
   TREE_USED (decl) = 1;
 
   /* Chain this decl to the pending declarations.  Don't do pushdecl()
      because this would add them to the current scope rather than the
      function scope.  */
   if (current_function_decl != NULL_TREE)
     {
       if (sym->ns->proc_name->backend_decl == current_function_decl
-          || sym->result == sym)
+          || sym->result == sym)
         gfc_add_decl_to_function (decl);
+      else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
+        /* This is a BLOCK construct.  */
+        add_decl_as_local (decl);
       else
         gfc_add_decl_to_parent_function (decl);
     }
 
   if (sym->attr.cray_pointee)
     return;
 
   if(sym->attr.is_bind_c == 1)
     {
       /* We need to put variables that are bind(c) into the common
          segment of the object file, because this is what C would do.
          gfortran would typically put them in either the BSS or
          initialized data segments, and only mark them as common if
          they were part of common blocks.  However, if they are not put
-         into common space, then C cannot initialize global fortran
+         into common space, then C cannot initialize global Fortran
          variables that it interoperates with and the draft says that
          either Fortran or C should be able to initialize it (but not
          both, of course.) (J3/04-007, section 15.3).  */
       TREE_PUBLIC(decl) = 1;
       DECL_COMMON(decl) = 1;
     }
   
   /* If a variable is USE associated, it's always external.  */
   if (sym->attr.use_assoc)
     {
@@ skipping 37 matching lines @@
           || sym->as->type != AS_EXPLICIT
           || sym->attr.pointer
           || sym->attr.allocatable)
       && !DECL_ARTIFICIAL (decl))
     TREE_STATIC (decl) = 1;
 
   /* Handle threadprivate variables.  */
   if (sym->attr.threadprivate
       && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
     DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
+
+  if (!sym->attr.target
+      && !sym->attr.pointer
+      && !sym->attr.cray_pointee
+      && !sym->attr.proc_pointer)
+    DECL_RESTRICTED_P (decl) = 1;
 }
 
 
 /* Allocate the lang-specific part of a decl.  */
 
 void
 gfc_allocate_lang_decl (tree decl)
 {
   DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
     ggc_alloc_cleared (sizeof (struct lang_decl));
@@ skipping 126 matching lines @@
       tree size, range;
 
       size = fold_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);
     }
 
-  if (write_symbols == NO_DEBUG)
-    return;
-
   if (TYPE_NAME (type) != NULL_TREE
       && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
       && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
     {
       tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
 
       for (dim = 0; dim < sym->as->rank - 1; dim++)
         {
           gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
           gtype = TREE_TYPE (gtype);
@@ skipping 17 matching lines @@
           if (!optimize)
             {
               if (GFC_TYPE_ARRAY_LBOUND (type, dim)
                   && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
                 DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
               if (GFC_TYPE_ARRAY_UBOUND (type, dim)
                   && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
                 DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
             }
         }
-      TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
+      TYPE_NAME (type) = type_decl = build_decl (input_location,
+                                                 TYPE_DECL, NULL, gtype);
       DECL_ORIGINAL_TYPE (type_decl) = gtype;
     }
 }
 
 
 /* For some dummy arguments we don't use the actual argument directly.
    Instead we create a local decl and use that.  This allows us to perform
    initialization, and construct full type information.  */
 
 static tree
@@ skipping 13 matching lines @@
   /* Add to list of variables if not a fake result variable.  */
   if (sym->attr.result || sym->attr.dummy)
     gfc_defer_symbol_init (sym);
 
   type = TREE_TYPE (dummy);
   gcc_assert (TREE_CODE (dummy) == PARM_DECL
           && POINTER_TYPE_P (type));
 
   /* Do we know the element size?  */
   known_size = sym->ts.type != BT_CHARACTER
-          || INTEGER_CST_P (sym->ts.cl->backend_decl);
+          || INTEGER_CST_P (sym->ts.u.cl->backend_decl);
   
   if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
     {
       /* For descriptorless arrays with known element size the actual
          argument is sufficient.  */
       gcc_assert (GFC_ARRAY_TYPE_P (type));
       gfc_build_qualified_array (dummy, sym);
       return dummy;
     }
 
@@ skipping 23 matching lines @@
                         && as->upper[n]->expr_type == EXPR_CONSTANT
                         && as->lower[n]->expr_type == EXPR_CONSTANT))
                     packed = PACKED_PARTIAL;
                 }
             }
           else
             packed = PACKED_PARTIAL;
         }
 
       type = gfc_typenode_for_spec (&sym->ts);
-      type = gfc_get_nodesc_array_type (type, sym->as, packed);
+      type = gfc_get_nodesc_array_type (type, sym->as, packed,
+                                        !sym->attr.target);
     }
   else
     {
       /* We now have an expression for the element size, so create a fully
          qualified type.  Reset sym->backend decl or this will just return the
          old type.  */
       DECL_ARTIFICIAL (sym->backend_decl) = 1;
       sym->backend_decl = NULL_TREE;
       type = gfc_sym_type (sym);
       packed = PACKED_FULL;
     }
 
   ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
-  decl = build_decl (VAR_DECL, get_identifier (name), type);
+  decl = build_decl (input_location,
+                     VAR_DECL, get_identifier (name), type);
 
   DECL_ARTIFICIAL (decl) = 1;
   TREE_PUBLIC (decl) = 0;
   TREE_STATIC (decl) = 0;
   DECL_EXTERNAL (decl) = 0;
 
   /* We should never get deferred shape arrays here.  We used to because of
      frontend bugs.  */
   gcc_assert (sym->as->type != AS_DEFERRED);
 
@@ skipping 13 matching lines @@
 
   if (sym->ns->proc_name->backend_decl == current_function_decl
       || sym->attr.contained)
     gfc_add_decl_to_function (decl);
   else
     gfc_add_decl_to_parent_function (decl);
 
   return decl;
 }
 
+/* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained
+   function add a VAR_DECL to the current function with DECL_VALUE_EXPR
+   pointing to the artificial variable for debug info purposes.  */
+
+static void
+gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)
+{
+  tree decl, dummy;
+
+  if (! nonlocal_dummy_decl_pset)
+    nonlocal_dummy_decl_pset = pointer_set_create ();
+
+  if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))
+    return;
+
+  dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);
+  decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),
+                     TREE_TYPE (sym->backend_decl));
+  DECL_ARTIFICIAL (decl) = 0;
+  TREE_USED (decl) = 1;
+  TREE_PUBLIC (decl) = 0;
+  TREE_STATIC (decl) = 0;
+  DECL_EXTERNAL (decl) = 0;
+  if (DECL_BY_REFERENCE (dummy))
+    DECL_BY_REFERENCE (decl) = 1;
+  DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);
+  SET_DECL_VALUE_EXPR (decl, sym->backend_decl);
+  DECL_HAS_VALUE_EXPR_P (decl) = 1;
+  DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);
+  TREE_CHAIN (decl) = nonlocal_dummy_decls;
+  nonlocal_dummy_decls = decl;
+}
 
 /* Return a constant or a variable to use as a string length.  Does not
    add the decl to the current scope.  */
 
 static tree
 gfc_create_string_length (gfc_symbol * sym)
 {
-  tree length;
+  gcc_assert (sym->ts.u.cl);
+  gfc_conv_const_charlen (sym->ts.u.cl);
 
-  gcc_assert (sym->ts.cl);
-  gfc_conv_const_charlen (sym->ts.cl);
-  
-  if (sym->ts.cl->backend_decl == NULL_TREE)
+  if (sym->ts.u.cl->backend_decl == NULL_TREE)
     {
+      tree length;
       char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 
       /* Also prefix the mangled name.  */
       strcpy (&name[1], sym->name);
       name[0] = '.';
-      length = build_decl (VAR_DECL, get_identifier (name),
+      length = build_decl (input_location,
+                           VAR_DECL, get_identifier (name),
                            gfc_charlen_type_node);
       DECL_ARTIFICIAL (length) = 1;
       TREE_USED (length) = 1;
       if (sym->ns->proc_name->tlink != NULL)
         gfc_defer_symbol_init (sym);
-      sym->ts.cl->backend_decl = length;
+
+      sym->ts.u.cl->backend_decl = length;
     }
 
-  return sym->ts.cl->backend_decl;
+  gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);
+  return sym->ts.u.cl->backend_decl;
 }
 
 /* If a variable is assigned a label, we add another two auxiliary
    variables.  */
 
 static void
 gfc_add_assign_aux_vars (gfc_symbol * sym)
 {
   tree addr;
   tree length;
   tree decl;
 
   gcc_assert (sym->backend_decl);
 
   decl = sym->backend_decl;
   gfc_allocate_lang_decl (decl);
   GFC_DECL_ASSIGN (decl) = 1;
-  length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
+  length = build_decl (input_location,
+                       VAR_DECL, create_tmp_var_name (sym->name),
                        gfc_charlen_type_node);
-  addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
+  addr = build_decl (input_location,
+                     VAR_DECL, create_tmp_var_name (sym->name),
                      pvoid_type_node);
   gfc_finish_var_decl (length, sym);
   gfc_finish_var_decl (addr, sym);
   /*  STRING_LENGTH is also used as flag. Less than -1 means that
       ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
       target label's address. Otherwise, value is the length of a format string
       and ASSIGN_ADDR is its address.  */
   if (TREE_STATIC (length))
     DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
   else
     gfc_defer_symbol_init (sym);
 
   GFC_DECL_STRING_LEN (decl) = length;
   GFC_DECL_ASSIGN_ADDR (decl) = addr;
 }
 
+
+static tree
+add_attributes_to_decl (symbol_attribute sym_attr, tree list)
+{
+  unsigned id;
+  tree attr;
+
+  for (id = 0; id < EXT_ATTR_NUM; id++)
+    if (sym_attr.ext_attr & (1 << id))
+      {
+        attr = build_tree_list (
+                 get_identifier (ext_attr_list[id].middle_end_name),
+                                 NULL_TREE);
+        list = chainon (list, attr);
+      }
+
+  return list;
+}
+
+
 /* Return the decl for a gfc_symbol, create it if it doesn't already
    exist.  */
 
 tree
 gfc_get_symbol_decl (gfc_symbol * sym)
 {
   tree decl;
   tree length = NULL_TREE;
+  tree attributes;
   int byref;
 
   gcc_assert (sym->attr.referenced
                 || sym->attr.use_assoc
                 || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
 
-  if (sym->ns && sym->ns->proc_name->attr.function)
+  if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)
     byref = gfc_return_by_reference (sym->ns->proc_name);
   else
     byref = 0;
 
   if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
     {
       /* Return via extra parameter.  */
       if (sym->attr.result && byref
           && !sym->backend_decl)
         {
           sym->backend_decl =
             DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
           /* For entry master function skip over the __entry
              argument.  */
           if (sym->ns->proc_name->attr.entry_master)
             sym->backend_decl = TREE_CHAIN (sym->backend_decl);
         }
 
       /* Dummy variables should already have been created.  */
       gcc_assert (sym->backend_decl);
 
       /* Create a character length variable.  */
       if (sym->ts.type == BT_CHARACTER)
         {
-          if (sym->ts.cl->backend_decl == NULL_TREE)
+          if (sym->ts.u.cl->backend_decl == NULL_TREE)
             length = gfc_create_string_length (sym);
           else
-            length = sym->ts.cl->backend_decl;
+            length = sym->ts.u.cl->backend_decl;
           if (TREE_CODE (length) == VAR_DECL
               && DECL_CONTEXT (length) == NULL_TREE)
             {
               /* Add the string length to the same context as the symbol.  */
               if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
                 gfc_add_decl_to_function (length);
               else
                 gfc_add_decl_to_parent_function (length);
 
               gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
@@ skipping 11 matching lines @@
           if (sym->backend_decl != NULL && decl != sym->backend_decl)
             DECL_ARTIFICIAL (sym->backend_decl) = 1;
           sym->backend_decl = decl;
         }
 
       TREE_USED (sym->backend_decl) = 1;
       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
         {
           gfc_add_assign_aux_vars (sym);
         }
+
+      if (sym->attr.dimension
+          && DECL_LANG_SPECIFIC (sym->backend_decl)
+          && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)
+          && DECL_CONTEXT (sym->backend_decl) != current_function_decl)
+        gfc_nonlocal_dummy_array_decl (sym);
+
       return sym->backend_decl;
     }
 
   if (sym->backend_decl)
     return sym->backend_decl;
 
+  /* If use associated and whole file compilation, use the module
+     declaration.  This is only needed for intrinsic types because
+     they are substituted for one another during optimization.  */
+  if (gfc_option.flag_whole_file
+        && sym->attr.flavor == FL_VARIABLE
+        && sym->ts.type != BT_DERIVED
+        && sym->attr.use_assoc
+        && sym->module)
+    {
+      gfc_gsymbol *gsym;
+
+      gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
+      if (gsym && gsym->ns && gsym->type == GSYM_MODULE)
+        {
+          gfc_symbol *s;
+          s = NULL;
+          gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+          if (s && s->backend_decl)
+            {
+              if (sym->ts.type == BT_CHARACTER)
+                sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;
+              return s->backend_decl;
+            }
+        }
+    }
+
   /* Catch function declarations.  Only used for actual parameters and
      procedure pointers.  */
   if (sym->attr.flavor == FL_PROCEDURE)
     {
       decl = gfc_get_extern_function_decl (sym);
       gfc_set_decl_location (decl, &sym->declared_at);
       return decl;
     }
 
   if (sym->attr.intrinsic)
     internal_error ("intrinsic variable which isn't a procedure");
 
   /* Create string length decl first so that they can be used in the
      type declaration.  */
   if (sym->ts.type == BT_CHARACTER)
     length = gfc_create_string_length (sym);
 
   /* Create the decl for the variable.  */
-  decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
+  decl = build_decl (sym->declared_at.lb->location,
+                     VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
 
-  gfc_set_decl_location (decl, &sym->declared_at);
+  /* Add attributes to variables.  Functions are handled elsewhere.  */
+  attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+  decl_attributes (&decl, attributes, 0);
 
   /* Symbols from modules should have their assembler names mangled.
      This is done here rather than in gfc_finish_var_decl because it
      is different for string length variables.  */
   if (sym->module)
     {
-      SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
+      gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
       if (sym->attr.use_assoc)
         DECL_IGNORED_P (decl) = 1;
     }
 
   if (sym->attr.dimension)
     {
       /* Create variables to hold the non-constant bits of array info.  */
       gfc_build_qualified_array (decl, sym);
 
-      /* Remember this variable for allocation/cleanup.  */
-      gfc_defer_symbol_init (sym);
-
       if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
         GFC_DECL_PACKED_ARRAY (decl) = 1;
     }
 
-  if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
-    gfc_defer_symbol_init (sym);
-  /* This applies a derived type default initializer.  */
-  else if (sym->ts.type == BT_DERIVED
-             && sym->attr.save == SAVE_NONE
-             && !sym->attr.data
-             && !sym->attr.allocatable
-             && (sym->value && !sym->ns->proc_name->attr.is_main_program)
-             && !sym->attr.use_assoc)
+  /* Remember this variable for allocation/cleanup.  */
+  if (sym->attr.dimension || sym->attr.allocatable
+      || (sym->ts.type == BT_CLASS &&
+          (sym->ts.u.derived->components->attr.dimension
+           || sym->ts.u.derived->components->attr.allocatable))
+      || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
+      /* This applies a derived type default initializer.  */
+      || (sym->ts.type == BT_DERIVED
+          && sym->attr.save == SAVE_NONE
+          && !sym->attr.data
+          && !sym->attr.allocatable
+          && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+          && !sym->attr.use_assoc))
     gfc_defer_symbol_init (sym);
 
   gfc_finish_var_decl (decl, sym);
 
   if (sym->ts.type == BT_CHARACTER)
     {
       /* Character variables need special handling.  */
       gfc_allocate_lang_decl (decl);
 
       if (TREE_CODE (length) != INTEGER_CST)
         {
           char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
 
           if (sym->module)
             {
               /* Also prefix the mangled name for symbols from modules.  */
               strcpy (&name[1], sym->name);
               name[0] = '.';
               strcpy (&name[1],
                       IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
-              SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
+              gfc_set_decl_assembler_name (decl, get_identifier (name));
             }
           gfc_finish_var_decl (length, sym);
           gcc_assert (!sym->value);
         }
     }
   else if (sym->attr.subref_array_pointer)
     {
       /* We need the span for these beasts.  */
       gfc_allocate_lang_decl (decl);
     }
 
   if (sym->attr.subref_array_pointer)
     {
       tree span;
       GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
-      span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
+      span = build_decl (input_location,
+                         VAR_DECL, create_tmp_var_name ("span"),
                          gfc_array_index_type);
       gfc_finish_var_decl (span, sym);
       TREE_STATIC (span) = TREE_STATIC (decl);
       DECL_ARTIFICIAL (span) = 1;
       DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
 
       GFC_DECL_SPAN (decl) = span;
       GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
     }
 
   sym->backend_decl = decl;
 
   if (sym->attr.assign)
     gfc_add_assign_aux_vars (sym);
 
   if (TREE_STATIC (decl) && !sym->attr.use_assoc)
     {
       /* Add static initializer.  */
       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
           TREE_TYPE (decl), sym->attr.dimension,
           sym->attr.pointer || sym->attr.allocatable);
     }
 
+  if (!TREE_STATIC (decl)
+      && POINTER_TYPE_P (TREE_TYPE (decl))
+      && !sym->attr.pointer
+      && !sym->attr.allocatable
+      && !sym->attr.proc_pointer)
+    DECL_BY_REFERENCE (decl) = 1;
+
   return decl;
 }
 
 
 /* Substitute a temporary variable in place of the real one.  */
 
 void
 gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
 {
   save->attr = sym->attr;
@@ skipping 16 matching lines @@
   sym->backend_decl = save->decl;
 }
 
 
 /* Declare a procedure pointer.  */
 
 static tree
 get_proc_pointer_decl (gfc_symbol *sym)
 {
   tree decl;
+  tree attributes;
 
   decl = sym->backend_decl;
   if (decl)
     return decl;
 
-  decl = build_decl (VAR_DECL, get_identifier (sym->name),
+  decl = build_decl (input_location,
+                     VAR_DECL, get_identifier (sym->name),
                      build_pointer_type (gfc_get_function_type (sym)));
 
   if ((sym->ns->proc_name
       && sym->ns->proc_name->backend_decl == current_function_decl)
       || sym->attr.contained)
     gfc_add_decl_to_function (decl);
   else if (sym->ns->proc_name->attr.flavor != FL_MODULE)
     gfc_add_decl_to_parent_function (decl);
 
   sym->backend_decl = decl;
@@ skipping 13 matching lines @@
 
   if (!sym->attr.use_assoc
         && (sym->attr.save != SAVE_NONE || sym->attr.data
               || (sym->value && sym->ns->proc_name->attr.is_main_program)))
     TREE_STATIC (decl) = 1;
 
   if (TREE_STATIC (decl) && sym->value)
     {
       /* Add static initializer.  */
       DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
-          TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
+          TREE_TYPE (decl),
+          sym->attr.proc_pointer ? false : sym->attr.dimension,
+          sym->attr.proc_pointer);
     }
 
+  attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+  decl_attributes (&decl, attributes, 0);
+
   return decl;
 }
 
 
 /* Get a basic decl for an external function.  */
 
 tree
 gfc_get_extern_function_decl (gfc_symbol * sym)
 {
   tree type;
   tree fndecl;
+  tree attributes;
   gfc_expr e;
   gfc_intrinsic_sym *isym;
   gfc_expr argexpr;
   char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'.  */
   tree name;
   tree mangled_name;
+  gfc_gsymbol *gsym;
 
   if (sym->backend_decl)
     return sym->backend_decl;
 
   /* We should never be creating external decls for alternate entry points.
      The procedure may be an alternate entry point, but we don't want/need
      to know that.  */
   gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
 
   if (sym->attr.proc_pointer)
     return get_proc_pointer_decl (sym);
 
+  /* See if this is an external procedure from the same file.  If so,
+     return the backend_decl.  */
+  gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->name);
+
+  if (gfc_option.flag_whole_file
+        && !sym->attr.use_assoc
+        && !sym->backend_decl
+        && gsym && gsym->ns
+        && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
+        && gsym->ns->proc_name->backend_decl)
+    {
+      /* If the namespace has entries, the proc_name is the
+         entry master.  Find the entry and use its backend_decl.
+         otherwise, use the proc_name backend_decl.  */
+      if (gsym->ns->entries)
+        {
+          gfc_entry_list *entry = gsym->ns->entries;
+
+          for (; entry; entry = entry->next)
+            {
+              if (strcmp (gsym->name, entry->sym->name) == 0)
+                {
+                  sym->backend_decl = entry->sym->backend_decl;
+                  break;
+                }
+            }
+        }
+      else
+        {
+          sym->backend_decl = gsym->ns->proc_name->backend_decl;
+        }
+
+      if (sym->backend_decl)
+        return sym->backend_decl;
+    }
+
+  /* See if this is a module procedure from the same file.  If so,
+     return the backend_decl.  */
+  if (sym->module)
+    gsym =  gfc_find_gsymbol (gfc_gsym_root, sym->module);
+
+  if (gfc_option.flag_whole_file
+        && gsym && gsym->ns
+        && gsym->type == GSYM_MODULE)
+    {
+      gfc_symbol *s;
+
+      s = NULL;
+      gfc_find_symbol (sym->name, gsym->ns, 0, &s);
+      if (s && s->backend_decl)
+        {
+          sym->backend_decl = s->backend_decl;
+          return sym->backend_decl;
+        }
+    }
+
   if (sym->attr.intrinsic)
     {
       /* Call the resolution function to get the actual name.  This is
          a nasty hack which relies on the resolution functions only looking
          at the first argument.  We pass NULL for the second argument
          otherwise things like AINT get confused.  */
       isym = gfc_find_function (sym->name);
       gcc_assert (isym->resolve.f0 != NULL);
 
       memset (&e, 0, sizeof (e));
@@ skipping 36 matching lines @@
       name = get_identifier (s);
       mangled_name = name;
     }
   else
     {
       name = gfc_sym_identifier (sym);
       mangled_name = gfc_sym_mangled_function_id (sym);
     }
 
   type = gfc_get_function_type (sym);
-  fndecl = build_decl (FUNCTION_DECL, name, type);
+  fndecl = build_decl (input_location,
+                       FUNCTION_DECL, name, type);
 
-  SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
-  /* If the return type is a pointer, avoid alias issues by setting
-     DECL_IS_MALLOC to nonzero. This means that the function should be
-     treated as if it were a malloc, meaning it returns a pointer that
-     is not an alias.  */
-  if (POINTER_TYPE_P (type))
-    DECL_IS_MALLOC (fndecl) = 1;
+  attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
+  decl_attributes (&fndecl, attributes, 0);
+
+  gfc_set_decl_assembler_name (fndecl, mangled_name);
 
   /* Set the context of this decl.  */
   if (0 && sym->ns && sym->ns->proc_name)
     {
       /* TODO: Add external decls to the appropriate scope.  */
       DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
     }
   else
     {
       /* Global declaration, e.g. intrinsic subroutine.  */
@@ skipping 33 matching lines @@
 }
 
 
 /* Create a declaration for a procedure.  For external functions (in the C
    sense) use gfc_get_extern_function_decl.  HAS_ENTRIES is true if this is
    a master function with alternate entry points.  */
 
 static void
 build_function_decl (gfc_symbol * sym)
 {
-  tree fndecl, type;
+  tree fndecl, type, attributes;
   symbol_attribute attr;
   tree result_decl;
   gfc_formal_arglist *f;
 
   gcc_assert (!sym->backend_decl);
   gcc_assert (!sym->attr.external);
 
   /* Set the line and filename.  sym->declared_at seems to point to the
      last statement for subroutines, but it'll do for now.  */
   gfc_set_backend_locus (&sym->declared_at);
 
   /* Allow only one nesting level.  Allow public declarations.  */
   gcc_assert (current_function_decl == NULL_TREE
               || DECL_CONTEXT (current_function_decl) == NULL_TREE
               || TREE_CODE (DECL_CONTEXT (current_function_decl))
                  == NAMESPACE_DECL);
 
   type = gfc_get_function_type (sym);
-  fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
+  fndecl = build_decl (input_location,
+                       FUNCTION_DECL, gfc_sym_identifier (sym), type);
+
+  attr = sym->attr;
+
+  attributes = add_attributes_to_decl (attr, NULL_TREE);
+  decl_attributes (&fndecl, attributes, 0);
 
   /* Perform name mangling if this is a top level or module procedure.  */
   if (current_function_decl == NULL_TREE)
-    SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
+    gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
 
   /* Figure out the return type of the declared function, and build a
      RESULT_DECL for it.  If this is a subroutine with alternate
      returns, build a RESULT_DECL for it.  */
-  attr = sym->attr;
-
   result_decl = NULL_TREE;
   /* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)).  */
   if (attr.function)
     {
       if (gfc_return_by_reference (sym))
         type = void_type_node;
       else
         {
           if (sym->result != sym)
             result_decl = gfc_sym_identifier (sym->result);
@@ skipping 13 matching lines @@
               break;
             }
         }
 
       if (has_alternate_returns)
         type = integer_type_node;
       else
         type = void_type_node;
     }
 
-  result_decl = build_decl (RESULT_DECL, result_decl, type);
+  result_decl = build_decl (input_location,
+                            RESULT_DECL, result_decl, type);
   DECL_ARTIFICIAL (result_decl) = 1;
   DECL_IGNORED_P (result_decl) = 1;
   DECL_CONTEXT (result_decl) = fndecl;
   DECL_RESULT (fndecl) = result_decl;
 
   /* Don't call layout_decl for a RESULT_DECL.
      layout_decl (result_decl, 0);  */
 
-  /* If the return type is a pointer, avoid alias issues by setting
-     DECL_IS_MALLOC to nonzero. This means that the function should be
-     treated as if it were a malloc, meaning it returns a pointer that
-     is not an alias.  */
-  if (POINTER_TYPE_P (type))
-    DECL_IS_MALLOC (fndecl) = 1;
-
   /* Set up all attributes for the function.  */
   DECL_CONTEXT (fndecl) = current_function_decl;
   DECL_EXTERNAL (fndecl) = 0;
 
   /* This specifies if a function is globally visible, i.e. it is
      the opposite of declaring static in C.  */
   if (DECL_CONTEXT (fndecl) == NULL_TREE
-      && !sym->attr.entry_master)
+      && !sym->attr.entry_master && !sym->attr.is_main_program)
     TREE_PUBLIC (fndecl) = 1;
 
   /* TREE_STATIC means the function body is defined here.  */
   TREE_STATIC (fndecl) = 1;
 
   /* Set attributes for PURE functions. A call to a PURE function in the
      Fortran 95 sense is both pure and without side effects in the C
      sense.  */
   if (attr.pure || attr.elemental)
     {
       /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
          including an alternate return. In that case it can also be
          marked as PURE. See also in gfc_get_extern_function_decl().  */
       if (attr.function && !gfc_return_by_reference (sym))
         DECL_PURE_P (fndecl) = 1;
       TREE_SIDE_EFFECTS (fndecl) = 0;
     }
 
-  /* For -fwhole-program to work well, the main program needs to have the
-     "externally_visible" attribute.  */
-  if (attr.is_main_program)
-    DECL_ATTRIBUTES (fndecl)
-      = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
 
   /* Layout the function declaration and put it in the binding level
      of the current function.  */
   pushdecl (fndecl);
 
   sym->backend_decl = fndecl;
 }
 
 
 /* Create the DECL_ARGUMENTS for a procedure.  */
@@ skipping 12 matching lines @@
 
   /* 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)
     {
       type = TREE_VALUE (typelist);
-      parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
+      parm = build_decl (input_location,
+                         PARM_DECL, get_identifier ("__entry"), type);
       
       DECL_CONTEXT (parm) = fndecl;
       DECL_ARG_TYPE (parm) = type;
       TREE_READONLY (parm) = 1;
       gfc_finish_decl (parm);
       DECL_ARTIFICIAL (parm) = 1;
 
       arglist = chainon (arglist, parm);
       typelist = TREE_CHAIN (typelist);
     }
 
   if (gfc_return_by_reference (sym))
     {
       tree type = TREE_VALUE (typelist), length = NULL;
 
       if (sym->ts.type == BT_CHARACTER)
         {
           /* Length of character result.  */
           tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
           gcc_assert (len_type == gfc_charlen_type_node);
 
-          length = build_decl (PARM_DECL,
+          length = build_decl (input_location,
+                               PARM_DECL,
                                get_identifier (".__result"),
                                len_type);
-          if (!sym->ts.cl->length)
+          if (!sym->ts.u.cl->length)
             {
-              sym->ts.cl->backend_decl = length;
+              sym->ts.u.cl->backend_decl = length;
               TREE_USED (length) = 1;
             }
           gcc_assert (TREE_CODE (length) == PARM_DECL);
           DECL_CONTEXT (length) = fndecl;
           DECL_ARG_TYPE (length) = len_type;
           TREE_READONLY (length) = 1;
           DECL_ARTIFICIAL (length) = 1;
           gfc_finish_decl (length);
-          if (sym->ts.cl->backend_decl == NULL
-              || sym->ts.cl->backend_decl == length)
+          if (sym->ts.u.cl->backend_decl == NULL
+              || sym->ts.u.cl->backend_decl == length)
             {
               gfc_symbol *arg;
               tree backend_decl;
 
-              if (sym->ts.cl->backend_decl == NULL)
+              if (sym->ts.u.cl->backend_decl == NULL)
                 {
-                  tree len = build_decl (VAR_DECL,
+                  tree len = build_decl (input_location,
+                                         VAR_DECL,
                                          get_identifier ("..__result"),
                                          gfc_charlen_type_node);
                   DECL_ARTIFICIAL (len) = 1;
                   TREE_USED (len) = 1;
-                  sym->ts.cl->backend_decl = len;
+                  sym->ts.u.cl->backend_decl = len;
                 }
 
               /* 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);
             }
         }
 
-      parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
+      parm = build_decl (input_location,
+                         PARM_DECL, get_identifier ("__result"), type);
 
       DECL_CONTEXT (parm) = fndecl;
       DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
       TREE_READONLY (parm) = 1;
       DECL_ARTIFICIAL (parm) = 1;
       gfc_finish_decl (parm);
 
       arglist = chainon (arglist, parm);
       typelist = TREE_CHAIN (typelist);
 
@@ skipping 13 matching lines @@
   for (f = sym->formal; f; f = f->next)
     {
       char name[GFC_MAX_SYMBOL_LEN + 2];
 
       /* Ignore alternate returns.  */
       if (f->sym == NULL)
         continue;
 
       type = TREE_VALUE (typelist);
 
-      if (f->sym->ts.type == BT_CHARACTER)
+      if (f->sym->ts.type == BT_CHARACTER
+          && (!sym->attr.is_bind_c || sym->attr.entry_master))
         {
           tree len_type = TREE_VALUE (hidden_typelist);
           tree length = NULL_TREE;
           gcc_assert (len_type == gfc_charlen_type_node);
 
           strcpy (&name[1], f->sym->name);
           name[0] = '_';
-          length = build_decl (PARM_DECL, get_identifier (name), len_type);
+          length = build_decl (input_location,
+                               PARM_DECL, get_identifier (name), len_type);
 
           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);
 
-          /* TODO: Check string lengths when -fbounds-check.  */
+          /* Remember the passed value.  */
+          if (f->sym->ts.u.cl->passed_length != NULL)
+            {
+              /* This can happen if the same type is used for multiple
+                 arguments. We need to copy cl as otherwise
+                 cl->passed_length gets overwritten.  */
+              f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);
+            }
+          f->sym->ts.u.cl->passed_length = length;
 
           /* Use the passed value for assumed length variables.  */
-          if (!f->sym->ts.cl->length)
+          if (!f->sym->ts.u.cl->length)
             {
               TREE_USED (length) = 1;
-              gcc_assert (!f->sym->ts.cl->backend_decl);
-              f->sym->ts.cl->backend_decl = length;
+              gcc_assert (!f->sym->ts.u.cl->backend_decl);
+              f->sym->ts.u.cl->backend_decl = length;
             }
 
           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.u.cl->backend_decl == NULL
+              || f->sym->ts.u.cl->backend_decl == length)
             {
-              if (f->sym->ts.cl->backend_decl == NULL)
+              if (f->sym->ts.u.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);
             }
         }
 
       /* 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);
         }
 
       if (f->sym->attr.proc_pointer)
         type = build_pointer_type (type);
 
       /* Build the argument declaration.  */
-      parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
+      parm = build_decl (input_location,
+                         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;
       if (POINTER_TYPE_P (type)
           && (!f->sym->attr.proc_pointer
               && f->sym->attr.flavor != FL_PROCEDURE))
         DECL_BY_REFERENCE (parm) = 1;
 
       gfc_finish_decl (parm);
 
       f->sym->backend_decl = parm;
 
       arglist = chainon (arglist, parm);
       typelist = TREE_CHAIN (typelist);
     }
 
   /* Add the hidden string length parameters, unless the procedure
      is bind(C).  */
   if (!sym->attr.is_bind_c)
     arglist = chainon (arglist, hidden_arglist);
 
   gcc_assert (hidden_typelist == NULL_TREE
               || TREE_VALUE (hidden_typelist) == void_type_node);
   DECL_ARGUMENTS (fndecl) = arglist;
 }
 
-/* Convert FNDECL's code to GIMPLE and handle any nested functions.  */
-
-static void
-gfc_gimplify_function (tree fndecl)
-{
-  struct cgraph_node *cgn;
-
-  gimplify_function_tree (fndecl);
-  dump_function (TDI_generic, fndecl);
-
-  /* Generate errors for structured block violations.  */
-  /* ??? Could be done as part of resolve_labels.  */
-  if (flag_openmp)
-    diagnose_omp_structured_block_errors (fndecl);
-
-  /* Convert all nested functions to GIMPLE now.  We do things in this order
-     so that items like VLA sizes are expanded properly in the context of the
-     correct function.  */
-  cgn = cgraph_node (fndecl);
-  for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
-    gfc_gimplify_function (cgn->decl);
-}
-
-
 /* Do the setup necessary before generating the body of a function.  */
 
 static void
 trans_function_start (gfc_symbol * sym)
 {
   tree fndecl;
 
   fndecl = sym->backend_decl;
 
   /* Let GCC know the current scope is this function.  */
@@ skipping 90 matching lines @@
             }
 
           if (thunk_formal)
             {
               /* Pass the argument.  */
               DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
               args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
                                 args);
               if (formal->sym->ts.type == BT_CHARACTER)
                 {
-                  tmp = thunk_formal->sym->ts.cl->backend_decl;
+                  tmp = thunk_formal->sym->ts.u.cl->backend_decl;
                   string_args = tree_cons (NULL_TREE, tmp, string_args);
                 }
             }
           else
             {
               /* Pass NULL for a missing argument.  */
               args = tree_cons (NULL_TREE, null_pointer_node, args);
               if (formal->sym->ts.type == BT_CHARACTER)
                 {
                   tmp = build_int_cst (gfc_charlen_type_node, 0);
                   string_args = tree_cons (NULL_TREE, tmp, string_args);
                 }
             }
         }
 
       /* Call the master function.  */
       args = nreverse (args);
       args = chainon (args, nreverse (string_args));
       tmp = ns->proc_name->backend_decl;
-      tmp = build_function_call_expr (tmp, args);
+      tmp = build_function_call_expr (input_location, tmp, args);
       if (ns->proc_name->attr.mixed_entry_master)
         {
           tree union_decl, field;
           tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
 
-          union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
+          union_decl = build_decl (input_location,
+                                   VAR_DECL, get_identifier ("__result"),
                                    TREE_TYPE (master_type));
           DECL_ARTIFICIAL (union_decl) = 1;
           DECL_EXTERNAL (union_decl) = 0;
           TREE_PUBLIC (union_decl) = 0;
           TREE_USED (union_decl) = 1;
           layout_decl (union_decl, 0);
           pushdecl (union_decl);
 
           DECL_CONTEXT (union_decl) = current_function_decl;
           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
@@ skipping 39 matching lines @@
          info for the epilogue.  */
       cfun->function_end_locus = input_location;
 
       /* We're leaving the context of this function, so zap cfun.
          It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
          tree_rest_of_compilation.  */
       set_cfun (NULL);
 
       current_function_decl = NULL_TREE;
 
-      gfc_gimplify_function (thunk_fndecl);
-      cgraph_finalize_function (thunk_fndecl, false);
+      cgraph_finalize_function (thunk_fndecl, true);
 
       /* We share the symbols in the formal argument list with other entry
          points and the master function.  Clear them so that they are
          recreated for each function.  */
       for (formal = thunk_sym->formal; formal; formal = formal->next)
         if (formal->sym != NULL)  /* Ignore alternate returns.  */
           {
             formal->sym->backend_decl = NULL_TREE;
             if (formal->sym->ts.type == BT_CHARACTER)
-              formal->sym->ts.cl->backend_decl = NULL_TREE;
+              formal->sym->ts.u.cl->backend_decl = NULL_TREE;
           }
 
       if (thunk_sym->attr.function)
         {
           if (thunk_sym->ts.type == BT_CHARACTER)
-            thunk_sym->ts.cl->backend_decl = NULL_TREE;
+            thunk_sym->ts.u.cl->backend_decl = NULL_TREE;
           if (thunk_sym->result->ts.type == BT_CHARACTER)
-            thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
+            thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;
         }
     }
 
   gfc_set_backend_locus (&old_loc);
 }
 
 
 /* Create a decl for a function, and create any thunks for alternate entry
    points.  */
 
@@ skipping 88 matching lines @@
   if (this_fake_result_decl != NULL_TREE)
     return TREE_VALUE (this_fake_result_decl);
 
   /* 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)
     {
-      if (sym->ts.cl->backend_decl == NULL_TREE)
+      if (sym->ts.u.cl->backend_decl == NULL_TREE)
         length = gfc_create_string_length (sym);
       else
-        length = sym->ts.cl->backend_decl;
+        length = sym->ts.u.cl->backend_decl;
       if (TREE_CODE (length) == VAR_DECL
           && DECL_CONTEXT (length) == NULL_TREE)
         gfc_add_decl_to_function (length);
     }
 
   if (gfc_return_by_reference (sym))
     {
       decl = DECL_ARGUMENTS (this_function_decl);
 
       if (sym->ns->proc_name->backend_decl == this_function_decl
           && sym->ns->proc_name->attr.entry_master)
         decl = TREE_CHAIN (decl);
 
       TREE_USED (decl) = 1;
       if (sym->as)
         decl = gfc_build_dummy_array_decl (sym, decl);
     }
   else
     {
       sprintf (name, "__result_%.20s",
                IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
 
       if (!sym->attr.mixed_entry_master && sym->attr.function)
-        decl = build_decl (VAR_DECL, get_identifier (name),
+        decl = build_decl (input_location,
+                           VAR_DECL, get_identifier (name),
                            gfc_sym_type (sym));
       else
-        decl = build_decl (VAR_DECL, get_identifier (name),
+        decl = build_decl (input_location,
+                           VAR_DECL, get_identifier (name),
                            TREE_TYPE (TREE_TYPE (this_function_decl)));
       DECL_ARTIFICIAL (decl) = 1;
       DECL_EXTERNAL (decl) = 0;
       TREE_PUBLIC (decl) = 0;
       TREE_USED (decl) = 1;
       GFC_DECL_RESULT (decl) = 1;
       TREE_ADDRESSABLE (decl) = 1;
 
       layout_decl (decl, 0);
 
@@ skipping 39 matching lines @@
     }
 
   if (nargs >= 0)
     {
       /* Terminate the list.  */
       arglist = gfc_chainon_list (arglist, void_type_node);
     }
 
   /* Build the function type and decl.  */
   fntype = build_function_type (rettype, arglist);
-  fndecl = build_decl (FUNCTION_DECL, name, fntype);
+  fndecl = build_decl (input_location,
+                       FUNCTION_DECL, name, fntype);
 
   /* Mark this decl as external.  */
   DECL_EXTERNAL (fndecl) = 1;
   TREE_PUBLIC (fndecl) = 1;
 
   va_end (p);
 
   pushdecl (fndecl);
 
   rest_of_decl_compilation (fndecl, 1, 0);
@@ skipping 417 matching lines @@
     gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
                                      void_type_node, 3, pvoid_type_node,
                                      integer_type_node, pchar_type_node);
 
   gfor_fndecl_os_error =
     gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
                                      void_type_node, 1, pchar_type_node);
   /* The runtime_error function does not return.  */
   TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;
 
+  gfor_fndecl_set_args =
+    gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),
+                                     void_type_node, 2, integer_type_node,
+                                     build_pointer_type (pchar_type_node));
+
   gfor_fndecl_set_fpe =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
                                     void_type_node, 1, integer_type_node);
 
   /* Keep the array dimension in sync with the call, later in this file.  */
   gfor_fndecl_set_options =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
                                     void_type_node, 2, integer_type_node,
-                                    pvoid_type_node);
+                                    build_pointer_type (integer_type_node));
 
   gfor_fndecl_set_convert =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
                                      void_type_node, 1, integer_type_node);
 
   gfor_fndecl_set_record_marker =
     gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
                                      void_type_node, 1, integer_type_node);
 
   gfor_fndecl_set_max_subrecord_length =
@@ skipping 44 matching lines @@
 /* Allocate and cleanup an automatic character variable.  */
 
 static tree
 gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
 {
   stmtblock_t body;
   tree decl;
   tree tmp;
 
   gcc_assert (sym->backend_decl);
-  gcc_assert (sym->ts.cl && sym->ts.cl->length);
+  gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
 
   gfc_start_block (&body);
 
   /* Evaluate the string length expression.  */
-  gfc_conv_string_length (sym->ts.cl, NULL, &body);
+  gfc_conv_string_length (sym->ts.u.cl, NULL, &body);
 
   gfc_trans_vla_type_sizes (sym, &body);
 
   decl = sym->backend_decl;
 
   /* Emit a DECL_EXPR for this variable, which will cause the
      gimplifier to allocate storage, and all that good stuff.  */
   tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
   gfc_add_expr_to_block (&body, tmp);
 
@@ skipping 135 matching lines @@
   stmtblock_t fnblock;
   gfc_expr *e;
   tree tmp;
   tree present;
 
   gfc_init_block (&fnblock);
   gcc_assert (!sym->attr.allocatable);
   gfc_set_sym_referenced (sym);
   e = gfc_lval_expr_from_sym (sym);
   tmp = gfc_trans_assignment (e, sym->value, false);
-  if (sym->attr.dummy)
+  if (sym->attr.dummy && (sym->attr.optional
+                          || sym->ns->proc_name->attr.entry_master))
     {
       present = gfc_conv_expr_present (sym);
       tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
-                    tmp, build_empty_stmt ());
+                    tmp, build_empty_stmt (input_location));
     }
   gfc_add_expr_to_block (&fnblock, tmp);
   gfc_free_expr (e);
   if (body)
     gfc_add_expr_to_block (&fnblock, body);
   return gfc_finish_block (&fnblock);
 }
 
 
 /* Initialize INTENT(OUT) derived type dummies.  As well as giving
    them their default initializer, if they do not have allocatable
    components, they have their allocatable components deallocated. */
 
 static tree
 init_intent_out_dt (gfc_symbol * proc_sym, tree body)
 {
   stmtblock_t fnblock;
   gfc_formal_arglist *f;
   tree tmp;
   tree present;
 
   gfc_init_block (&fnblock);
   for (f = proc_sym->formal; f; f = f->next)
     if (f->sym && f->sym->attr.intent == INTENT_OUT
         && !f->sym->attr.pointer
         && f->sym->ts.type == BT_DERIVED)
       {
-        if (f->sym->ts.derived->attr.alloc_comp && !f->sym->value)
+        if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
           {
-            tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,
+            tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
                                              f->sym->backend_decl,
                                              f->sym->as ? f->sym->as->rank : 0);
 
-            present = gfc_conv_expr_present (f->sym);
-            tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
-                          tmp, build_empty_stmt ());
+            if (f->sym->attr.optional
+                || f->sym->ns->proc_name->attr.entry_master)
+              {
+                present = gfc_conv_expr_present (f->sym);
+                tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+                              tmp, build_empty_stmt (input_location));
+              }
 
             gfc_add_expr_to_block (&fnblock, tmp);
           }
-        else if (f->sym->value)
+       else if (f->sym->value)
           body = gfc_init_default_dt (f->sym, body);
       }
 
   gfc_add_expr_to_block (&fnblock, body);
   return gfc_finish_block (&fnblock);
 }
 
 
 /* Generate function entry and exit code, and add it to the function body.
    This includes:
     Allocation and initialization of array variables.
     Allocation of character string variables.
     Initialization and possibly repacking of dummy arrays.
-    Initialization of ASSIGN statement auxiliary variable.  */
+    Initialization of ASSIGN statement auxiliary variable.
+    Automatic deallocation.  */
 
-static tree
+tree
 gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
 {
   locus loc;
   gfc_symbol *sym;
   gfc_formal_arglist *f;
   stmtblock_t body;
   bool seen_trans_deferred_array = false;
 
   /* Deal with implicit return variables.  Explicit return variables will
      already have been added.  */
@@ skipping 13 matching lines @@
             gfc_warning ("Return value of function '%s' at %L not set",
                          proc_sym->name, &proc_sym->declared_at);
         }
       else if (proc_sym->as)
         {
           tree result = TREE_VALUE (current_fake_result_decl);
           fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
 
           /* An automatic character length, pointer array result.  */
           if (proc_sym->ts.type == BT_CHARACTER
-                && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
-            fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+                && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+            fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
                                                 fnbody);
         }
       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, proc_sym->ts.cl,
+          if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)
+            fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,
                                                 fnbody);
         }
       else
         gcc_assert (gfc_option.flag_f2c
                     && proc_sym->ts.type == BT_COMPLEX);
     }
 
   /* Initialize the INTENT(OUT) derived type dummy arguments.  This
      should be done here so that the offsets and lbounds of arrays
      are available.  */
   fnbody = init_intent_out_dt (proc_sym, fnbody);
 
   for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
     {
       bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
-                                   && sym->ts.derived->attr.alloc_comp;
+                                   && sym->ts.u.derived->attr.alloc_comp;
       if (sym->attr.dimension)
         {
           switch (sym->as->type)
             {
             case AS_EXPLICIT:
               if (sym->attr.dummy || sym->attr.result)
                 fnbody =
                   gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
               else if (sym->attr.pointer || sym->attr.allocatable)
                 {
@@ skipping 21 matching lines @@
                   gfc_get_backend_locus (&loc);
                   gfc_set_backend_locus (&sym->declared_at);
                   fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
                       sym, fnbody);
                   gfc_set_backend_locus (&loc);
                 }
               break;
 
             case AS_ASSUMED_SIZE:
               /* Must be a dummy parameter.  */
-              gcc_assert (sym->attr.dummy);
+              gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);
 
               /* We should always pass assumed size arrays the g77 way.  */
-              fnbody = gfc_trans_g77_array (sym, fnbody);
+              if (sym->attr.dummy)
+                fnbody = gfc_trans_g77_array (sym, fnbody);
               break;
 
             case AS_ASSUMED_SHAPE:
               /* Must be a dummy parameter.  */
               gcc_assert (sym->attr.dummy);
 
               fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
                                                    fnbody);
               break;
 
             case AS_DEFERRED:
               seen_trans_deferred_array = true;
               fnbody = gfc_trans_deferred_array (sym, fnbody);
               break;
 
             default:
               gcc_unreachable ();
             }
           if (sym_has_alloc_comp && !seen_trans_deferred_array)
             fnbody = gfc_trans_deferred_array (sym, fnbody);
         }
       else if (sym_has_alloc_comp)
         fnbody = gfc_trans_deferred_array (sym, fnbody);
+      else if (sym->attr.allocatable
+               || (sym->ts.type == BT_CLASS
+                   && sym->ts.u.derived->components->attr.allocatable))
+        {
+          if (!sym->attr.save)
+            {
+              /* Nullify and automatic deallocation of allocatable
+                 scalars.  */
+              tree tmp;
+              gfc_expr *e;
+              gfc_se se;
+              stmtblock_t block;
+
+              e = gfc_lval_expr_from_sym (sym);
+              if (sym->ts.type == BT_CLASS)
+                gfc_add_component_ref (e, "$data");
+
+              gfc_init_se (&se, NULL);
+              se.want_pointer = 1;
+              gfc_conv_expr (&se, e);
+              gfc_free_expr (e);
+
+              /* Nullify when entering the scope.  */
+              gfc_start_block (&block);
+              gfc_add_modify (&block, se.expr,
+                              fold_convert (TREE_TYPE (se.expr),
+                                            null_pointer_node));
+              gfc_add_expr_to_block (&block, fnbody);
+
+              /* Deallocate when leaving the scope. Nullifying is not
+                 needed.  */
+              tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
+                                                NULL);
+              gfc_add_expr_to_block (&block, tmp);
+              fnbody = gfc_finish_block (&block);
+            }
+        }
       else if (sym->ts.type == BT_CHARACTER)
         {
           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, sym->ts.cl, fnbody);
+            fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);
           else
             fnbody = gfc_trans_auto_character_variable (sym, fnbody);
           gfc_set_backend_locus (&loc);
         }
       else if (sym->attr.assign)
         {
           gfc_get_backend_locus (&loc);
           gfc_set_backend_locus (&sym->declared_at);
           fnbody = gfc_trans_assign_aux_var (sym, fnbody);
           gfc_set_backend_locus (&loc);
         }
       else if (sym->ts.type == BT_DERIVED
                  && sym->value
                  && !sym->attr.data
                  && sym->attr.save == SAVE_NONE)
         fnbody = gfc_init_default_dt (sym, fnbody);
       else
         gcc_unreachable ();
     }
 
   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)
+          gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);
+          if (TREE_CODE (f->sym->ts.u.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)
+      gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);
+      if (TREE_CODE (proc_sym->ts.u.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);
 }
 
 static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
 
 /* Hash and equality functions for module_htab.  */
@@ skipping 94 matching lines @@
   if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
       && sym->ts.type == BT_DERIVED)
     sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
 
   if (sym->attr.flavor == FL_DERIVED
       && sym->backend_decl
       && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
     {
       decl = sym->backend_decl;
       gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
-      gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
-                  || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
-      gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
-                  || DECL_CONTEXT (TYPE_STUB_DECL (decl))
-                     == sym->ns->proc_name->backend_decl);
+
+      /* -fwhole-file mixes up the contexts so these asserts are unnecessary.  */
+      if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))
+        {
+          gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
+                      || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
+          gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
+                      || DECL_CONTEXT (TYPE_STUB_DECL (decl))
+                           == sym->ns->proc_name->backend_decl);
+        }
       TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
       DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
       gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
     }
 
   /* Only output variables, procedure pointers and array valued,
      or derived type, parameters.  */
   if (sym->attr.flavor != FL_VARIABLE
         && !(sym->attr.flavor == FL_PARAMETER
                && (sym->attr.dimension || sym->ts.type == BT_DERIVED))
@@ skipping 12 matching lines @@
   /* Don't generate variables from other modules. Variables from
      COMMONs will already have been generated.  */
   if (sym->attr.use_assoc || sym->attr.in_common)
     return;
 
   /* Equivalenced variables arrive here after creation.  */
   if (sym->backend_decl
       && (sym->equiv_built || sym->attr.in_equivalence))
     return;
 
-  if (sym->backend_decl)
+  if (sym->backend_decl && !sym->attr.vtab)
     internal_error ("backend decl for module variable %s already exists",
                     sym->name);
 
   /* We always want module variables to be created.  */
   sym->attr.referenced = 1;
   /* Create the decl.  */
   decl = gfc_get_symbol_decl (sym);
 
   /* Create the variable.  */
   pushdecl (decl);
   gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
   gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
   rest_of_decl_compilation (decl, 1, 0);
   gfc_module_add_decl (cur_module, decl);
 
   /* Also add length of strings.  */
   if (sym->ts.type == BT_CHARACTER)
     {
       tree length;
 
-      length = sym->ts.cl->backend_decl;
-      if (!INTEGER_CST_P (length))
+      length = sym->ts.u.cl->backend_decl;
+      gcc_assert (length || sym->attr.proc_pointer);
+      if (length && !INTEGER_CST_P (length))
         {
           pushdecl (length);
           rest_of_decl_compilation (length, 1, 0);
         }
     }
 }
 
 /* Emit debug information for USE statements.  */
 
 static void
 gfc_trans_use_stmts (gfc_namespace * ns)
 {
   gfc_use_list *use_stmt;
   for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
     {
       struct module_htab_entry *entry
         = gfc_find_module (use_stmt->module_name);
       gfc_use_rename *rent;
 
       if (entry->namespace_decl == NULL)
         {
           entry->namespace_decl
-            = build_decl (NAMESPACE_DECL,
+            = build_decl (input_location,
+                          NAMESPACE_DECL,
                           get_identifier (use_stmt->module_name),
                           void_type_node);
           DECL_EXTERNAL (entry->namespace_decl) = 1;
         }
       gfc_set_backend_locus (&use_stmt->where);
       if (!use_stmt->only_flag)
         (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
                                                  NULL_TREE,
                                                  ns->proc_name->backend_decl,
                                                  false);
@@ skipping 10 matching lines @@
                                            INSERT);
           if (*slot == NULL)
             {
               gfc_symtree *st;
 
               st = gfc_find_symtree (ns->sym_root,
                                      rent->local_name[0]
                                      ? rent->local_name : rent->use_name);
               gcc_assert (st);
 
-              /* Fixing-up doubly contained symbols, sometimes results in
-                 ambiguity, which is caught here.  */
+              /* Sometimes, generic interfaces wind up being over-ruled by a
+                 local symbol (see PR41062).  */
               if (!st->n.sym->attr.use_assoc)
                 continue;
 
               if (st->n.sym->backend_decl
                   && DECL_P (st->n.sym->backend_decl)
                   && st->n.sym->module
                   && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
                 {
                   gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
                               || (TREE_CODE (st->n.sym->backend_decl)
@@ skipping 58 matching lines @@
           else if (c->expr->expr_type != EXPR_CONSTANT)
             return false;
         }
       return true;
     }
   else switch (ts->type)
     {
     case BT_DERIVED:
       if (expr->expr_type != EXPR_STRUCTURE)
         return false;
-      cm = expr->ts.derived->components;
+      cm = expr->ts.u.derived->components;
       for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
         {
           if (!c->expr || cm->attr.allocatable)
             continue;
           if (!check_constant_initializer (c->expr, &cm->ts,
                                            cm->attr.dimension,
                                            cm->attr.pointer))
             return false;
         }
       return true;
@@ skipping 25 matching lines @@
       || sym->attr.allocatable
       || sym->attr.cray_pointee
       || sym->attr.threadprivate
       || sym->attr.is_bind_c
       || sym->attr.subref_array_pointer
       || sym->attr.assign)
     return;
 
   if (sym->ts.type == BT_CHARACTER)
     {
-      gfc_conv_const_charlen (sym->ts.cl);
-      if (sym->ts.cl->backend_decl == NULL
-          || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
+      gfc_conv_const_charlen (sym->ts.u.cl);
+      if (sym->ts.u.cl->backend_decl == NULL
+          || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)
         return;
     }
-  else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+  else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
     return;
 
   if (sym->as)
     {
       int n;
 
       if (sym->as->type != AS_EXPLICIT)
         return;
       for (n = 0; n < sym->as->rank; n++)
         if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
             || sym->as->upper[n] == NULL
             || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
           return;
     }
 
   if (!check_constant_initializer (sym->value, &sym->ts,
                                    sym->attr.dimension, false))
     return;
 
   /* Create the decl for the variable or constant.  */
-  decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
+  decl = build_decl (input_location,
+                     sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
                      gfc_sym_identifier (sym), gfc_sym_type (sym));
   if (sym->attr.flavor == FL_PARAMETER)
     TREE_READONLY (decl) = 1;
   gfc_set_decl_location (decl, &sym->declared_at);
   if (sym->attr.dimension)
     GFC_DECL_PACKED_ARRAY (decl) = 1;
   DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
   TREE_STATIC (decl) = 1;
   TREE_USED (decl) = 1;
   if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
@@ skipping 85 matching lines @@
 
 
 /* Check for dependencies in the character length and array spec.  */
 
 static void
 generate_dependency_declarations (gfc_symbol *sym)
 {
   int i;
 
   if (sym->ts.type == BT_CHARACTER
-      && sym->ts.cl
-      && sym->ts.cl->length
-      && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
-    generate_expr_decls (sym, sym->ts.cl->length);
+      && sym->ts.u.cl
+      && sym->ts.u.cl->length
+      && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)
+    generate_expr_decls (sym, sym->ts.u.cl->length);
 
   if (sym->as && sym->as->rank)
     {
       for (i = 0; i < sym->as->rank; i++)
         {
           generate_expr_decls (sym, sym->as->lower[i]);
           generate_expr_decls (sym, sym->as->upper[i]);
         }
     }
 }
@@ skipping 10 matching lines @@
     {
       if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
         generate_dependency_declarations (sym);
 
       if (sym->attr.referenced)
         gfc_get_symbol_decl (sym);
       /* INTENT(out) dummy arguments are likely meant to be set.  */
       else if (warn_unused_variable
                && sym->attr.dummy
                && sym->attr.intent == INTENT_OUT)
-        gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
-                     sym->name, &sym->declared_at);
+        {
+          if (!(sym->ts.type == BT_DERIVED
+                && sym->ts.u.derived->components->initializer))
+            gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
+                         "but was not set",  sym->name, &sym->declared_at);
+        }
       /* Specific warning for unused dummy arguments. */
       else if (warn_unused_variable && sym->attr.dummy)
         gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
                      &sym->declared_at);
       /* Warn for unused variables, but not if they're inside a common
          block or are use-associated.  */
       else if (warn_unused_variable
                && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
         gfc_warning ("Unused variable '%s' declared at %L", sym->name,
                      &sym->declared_at);
 
       /* 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->ts.u.cl->backend_decl != NULL
+            && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)
         {
           sym->attr.referenced = 1;
           gfc_get_symbol_decl (sym);
         }
 
-      /* INTENT(out) dummy arguments with allocatable components are reset
-         by default and need to be set referenced to generate the code for
-         automatic lengths.  */
-      if (sym->attr.dummy && !sym->attr.referenced
+      /* INTENT(out) dummy arguments and result variables with allocatable
+         components are reset by default and need to be set referenced to
+         generate the code for nullification and automatic lengths.  */
+      if (!sym->attr.referenced
             && sym->ts.type == BT_DERIVED
+            && sym->ts.u.derived->attr.alloc_comp
             && !sym->attr.pointer
-            && sym->ts.derived->attr.alloc_comp
-            && sym->attr.intent == INTENT_OUT)
+            && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)
+                  ||
+                (sym->attr.result && sym != sym->result)))
         {
           sym->attr.referenced = 1;
           gfc_get_symbol_decl (sym);
         }
 
-
       /* Check for dependencies in the array specification and string
         length, adding the necessary declarations to the function.  We
         mark the symbol now, as well as in traverse_ns, to prevent
         getting stuck in a circular dependency.  */
       sym->mark = 1;
 
       /* We do not want the middle-end to warn about unused parameters
          as this was already done above.  */
       if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
           TREE_NO_WARNING(sym->backend_decl) = 1;
@@ skipping 82 matching lines @@
       el->label = label;
     }
   tmp = gfc_finish_block (&block);
   /* The first argument selects the entry point.  */
   val = DECL_ARGUMENTS (current_function_decl);
   tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
   return tmp;
 }
 
 
+/* Add code to string lengths of actual arguments passed to a function against
+   the expected lengths of the dummy arguments.  */
+
+static void
+add_argument_checking (stmtblock_t *block, gfc_symbol *sym)
+{
+  gfc_formal_arglist *formal;
+
+  for (formal = sym->formal; formal; formal = formal->next)
+    if (formal->sym && formal->sym->ts.type == BT_CHARACTER)
+      {
+        enum tree_code comparison;
+        tree cond;
+        tree argname;
+        gfc_symbol *fsym;
+        gfc_charlen *cl;
+        const char *message;
+
+        fsym = formal->sym;
+        cl = fsym->ts.u.cl;
+
+        gcc_assert (cl);
+        gcc_assert (cl->passed_length != NULL_TREE);
+        gcc_assert (cl->backend_decl != NULL_TREE);
+
+        /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the
+           string lengths must match exactly.  Otherwise, it is only required
+           that the actual string length is *at least* the expected one.
+           Sequence association allows for a mismatch of the string length
+           if the actual argument is (part of) an array, but only if the
+           dummy argument is an array. (See "Sequence association" in
+           Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.)  */
+        if (fsym->attr.pointer || fsym->attr.allocatable
+            || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))
+          {
+            comparison = NE_EXPR;
+            message = _("Actual string length does not match the declared one"
+                        " for dummy argument '%s' (%ld/%ld)");
+          }
+        else if (fsym->as && fsym->as->rank != 0)
+          continue;
+        else
+          {
+            comparison = LT_EXPR;
+            message = _("Actual string length is shorter than the declared one"
+                        " for dummy argument '%s' (%ld/%ld)");
+          }
+
+        /* Build the condition.  For optional arguments, an actual length
+           of 0 is also acceptable if the associated string is NULL, which
+           means the argument was not passed.  */
+        cond = fold_build2 (comparison, boolean_type_node,
+                            cl->passed_length, cl->backend_decl);
+        if (fsym->attr.optional)
+          {
+            tree not_absent;
+            tree not_0length;
+            tree absent_failed;
+
+            not_0length = fold_build2 (NE_EXPR, boolean_type_node,
+                                       cl->passed_length,
+                                       fold_convert (gfc_charlen_type_node,
+                                                     integer_zero_node));
+            /* The symbol needs to be referenced for gfc_get_symbol_decl.  */
+            fsym->attr.referenced = 1;
+            not_absent = gfc_conv_expr_present (fsym);
+
+            absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
+                                         not_0length, not_absent);
+
+            cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
+                                cond, absent_failed);
+          }
+
+        /* Build the runtime check.  */
+        argname = gfc_build_cstring_const (fsym->name);
+        argname = gfc_build_addr_expr (pchar_type_node, argname);
+        gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,
+                                 message, argname,
+                                 fold_convert (long_integer_type_node,
+                                               cl->passed_length),
+                                 fold_convert (long_integer_type_node,
+                                               cl->backend_decl));
+      }
+}
+
+
+static void
+create_main_function (tree fndecl)
+{
+  tree old_context;
+  tree ftn_main;
+  tree tmp, decl, result_decl, argc, argv, typelist, arglist;
+  stmtblock_t body;
+
+  old_context = current_function_decl;
+
+  if (old_context)
+    {
+      push_function_context ();
+      saved_parent_function_decls = saved_function_decls;
+      saved_function_decls = NULL_TREE;
+    }
+
+  /* main() function must be declared with global scope.  */
+  gcc_assert (current_function_decl == NULL_TREE);
+
+  /* Declare the function.  */
+  tmp =  build_function_type_list (integer_type_node, integer_type_node,
+                                   build_pointer_type (pchar_type_node),
+                                   NULL_TREE);
+  main_identifier_node = get_identifier ("main");
+  ftn_main = build_decl (input_location, FUNCTION_DECL,
+                         main_identifier_node, tmp);
+  DECL_EXTERNAL (ftn_main) = 0;
+  TREE_PUBLIC (ftn_main) = 1;
+  TREE_STATIC (ftn_main) = 1;
+  DECL_ATTRIBUTES (ftn_main)
+      = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
+
+  /* Setup the result declaration (for "return 0").  */
+  result_decl = build_decl (input_location,
+                            RESULT_DECL, NULL_TREE, integer_type_node);
+  DECL_ARTIFICIAL (result_decl) = 1;
+  DECL_IGNORED_P (result_decl) = 1;
+  DECL_CONTEXT (result_decl) = ftn_main;
+  DECL_RESULT (ftn_main) = result_decl;
+
+  pushdecl (ftn_main);
+
+  /* Get the arguments.  */
+
+  arglist = NULL_TREE;
+  typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));
+
+  tmp = TREE_VALUE (typelist);
+  argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);
+  DECL_CONTEXT (argc) = ftn_main;
+  DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);
+  TREE_READONLY (argc) = 1;
+  gfc_finish_decl (argc);
+  arglist = chainon (arglist, argc);
+
+  typelist = TREE_CHAIN (typelist);
+  tmp = TREE_VALUE (typelist);
+  argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);
+  DECL_CONTEXT (argv) = ftn_main;
+  DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);
+  TREE_READONLY (argv) = 1;
+  DECL_BY_REFERENCE (argv) = 1;
+  gfc_finish_decl (argv);
+  arglist = chainon (arglist, argv);
+
+  DECL_ARGUMENTS (ftn_main) = arglist;
+  current_function_decl = ftn_main;
+  announce_function (ftn_main);
+
+  rest_of_decl_compilation (ftn_main, 1, 0);
+  make_decl_rtl (ftn_main);
+  init_function_start (ftn_main);
+  pushlevel (0);
+
+  gfc_init_block (&body);
+
+  /* Call some libgfortran initialization routines, call then MAIN__(). */
+
+  /* Call _gfortran_set_args (argc, argv).  */
+  TREE_USED (argc) = 1;
+  TREE_USED (argv) = 1;
+  tmp = build_call_expr_loc (input_location,
+                         gfor_fndecl_set_args, 2, argc, argv);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Add a call to set_options to set up the runtime library Fortran
+     language standard parameters.  */
+  {
+    tree array_type, array, var;
+
+    /* Passing a new option to the library requires four modifications:
+     + add it to the tree_cons list below
+          + change the array size in the call to build_array_type
+          + change the first argument to the library call
+            gfor_fndecl_set_options
+          + modify the library (runtime/compile_options.c)!  */
+
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                       gfc_option.warn_std), NULL_TREE);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                       gfc_option.allow_std), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),
+                       array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                       gfc_option.flag_dump_core), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                       gfc_option.flag_backtrace), array);
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                       gfc_option.flag_sign_zero), array);
+
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                       (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);
+
+    array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,
+                       gfc_option.flag_range_check), array);
+
+    array_type = build_array_type (integer_type_node,
+                       build_index_type (build_int_cst (NULL_TREE, 7)));
+    array = build_constructor_from_list (array_type, nreverse (array));
+    TREE_CONSTANT (array) = 1;
+    TREE_STATIC (array) = 1;
+
+    /* Create a static variable to hold the jump table.  */
+    var = gfc_create_var (array_type, "options");
+    TREE_CONSTANT (var) = 1;
+    TREE_STATIC (var) = 1;
+    TREE_READONLY (var) = 1;
+    DECL_INITIAL (var) = array;
+    var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);
+
+    tmp = build_call_expr_loc (input_location,
+                           gfor_fndecl_set_options, 2,
+                           build_int_cst (integer_type_node, 8), var);
+    gfc_add_expr_to_block (&body, tmp);
+  }
+
+  /* If -ffpe-trap option was provided, add a call to set_fpe so that
+     the library will raise a FPE when needed.  */
+  if (gfc_option.fpe != 0)
+    {
+      tmp = build_call_expr_loc (input_location,
+                             gfor_fndecl_set_fpe, 1,
+                             build_int_cst (integer_type_node,
+                                            gfc_option.fpe));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* If this is the main program and an -fconvert option was provided,
+     add a call to set_convert.  */
+
+  if (gfc_option.convert != GFC_CONVERT_NATIVE)
+    {
+      tmp = build_call_expr_loc (input_location,
+                             gfor_fndecl_set_convert, 1,
+                             build_int_cst (integer_type_node,
+                                            gfc_option.convert));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* If this is the main program and an -frecord-marker option was provided,
+     add a call to set_record_marker.  */
+
+  if (gfc_option.record_marker != 0)
+    {
+      tmp = build_call_expr_loc (input_location,
+                             gfor_fndecl_set_record_marker, 1,
+                             build_int_cst (integer_type_node,
+                                            gfc_option.record_marker));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  if (gfc_option.max_subrecord_length != 0)
+    {
+      tmp = build_call_expr_loc (input_location,
+                             gfor_fndecl_set_max_subrecord_length, 1,
+                             build_int_cst (integer_type_node,
+                                            gfc_option.max_subrecord_length));
+      gfc_add_expr_to_block (&body, tmp);
+    }
+
+  /* Call MAIN__().  */
+  tmp = build_call_expr_loc (input_location,
+                         fndecl, 0);
+  gfc_add_expr_to_block (&body, tmp);
+
+  /* Mark MAIN__ as used.  */
+  TREE_USED (fndecl) = 1;
+
+  /* "return 0".  */
+  tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
+                     build_int_cst (integer_type_node, 0));
+  tmp = build1_v (RETURN_EXPR, tmp);
+  gfc_add_expr_to_block (&body, tmp);
+
+
+  DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);
+  decl = getdecls ();
+
+  /* Finish off this function and send it for code generation.  */
+  poplevel (1, 0, 1);
+  BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;
+
+  DECL_SAVED_TREE (ftn_main)
+    = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),
+                DECL_INITIAL (ftn_main));
+
+  /* Output the GENERIC tree.  */
+  dump_function (TDI_original, ftn_main);
+
+  cgraph_finalize_function (ftn_main, true);
+
+  if (old_context)
+    {
+      pop_function_context ();
+      saved_function_decls = saved_parent_function_decls;
+    }
+  current_function_decl = old_context;
+}
+
+
 /* Generate code for a function.  */
 
 void
 gfc_generate_function_code (gfc_namespace * ns)
 {
   tree fndecl;
   tree old_context;
   tree decl;
   tree tmp;
   tree tmp2;
   stmtblock_t block;
   stmtblock_t body;
   tree result;
+  tree recurcheckvar = NULL_TREE;
   gfc_symbol *sym;
   int rank;
+  bool is_recursive;
 
   sym = ns->proc_name;
 
   /* Check that the frontend isn't still using this.  */
   gcc_assert (sym->tlink == NULL);
   sym->tlink = sym;
 
   /* Create the declaration for functions with global scope.  */
   if (!sym->backend_decl)
     gfc_create_function_decl (ns);
@@ skipping 12 matching lines @@
 
   gfc_init_block (&block);
 
   if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
     {
       /* Copy length backend_decls to all entry point result
          symbols.  */
       gfc_entry_list *el;
       tree backend_decl;
 
-      gfc_conv_const_charlen (ns->proc_name->ts.cl);
-      backend_decl = ns->proc_name->result->ts.cl->backend_decl;
+      gfc_conv_const_charlen (ns->proc_name->ts.u.cl);
+      backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;
       for (el = ns->entries; el; el = el->next)
-        el->sym->result->ts.cl->backend_decl = backend_decl;
+        el->sym->result->ts.u.cl->backend_decl = backend_decl;
     }
 
   /* Translate COMMON blocks.  */
   gfc_trans_common (ns);
 
   /* Null the parent fake result declaration if this namespace is
      a module function or an external procedures.  */
   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
         || ns->parent == NULL)
     parent_fake_result_decl = NULL_TREE;
 
   gfc_generate_contained_functions (ns);
 
+  nonlocal_dummy_decls = NULL;
+  nonlocal_dummy_decl_pset = NULL;
+
   generate_local_vars (ns);
 
   /* Keep the parent fake result declaration in module functions
      or external procedures.  */
   if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
         || ns->parent == NULL)
     current_fake_result_decl = parent_fake_result_decl;
   else
     current_fake_result_decl = NULL_TREE;
 
   current_function_return_label = NULL;
 
   /* Now generate the code for the body of this function.  */
   gfc_init_block (&body);
 
-  /* If this is the main program, add a call to set_options to set up the
-     runtime library Fortran language standard parameters.  */
-  if (sym->attr.is_main_program)
-    {
-      tree array_type, array, var;
+   is_recursive = sym->attr.recursive
+                  || (sym->attr.entry_master
+                      && sym->ns->entries->sym->attr.recursive);
+   if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+          && !is_recursive
+          && !gfc_option.flag_recursive)
+     {
+       char * msg;
 
-      /* Passing a new option to the library requires four modifications:
-           + add it to the tree_cons list below
-           + change the array size in the call to build_array_type
-           + change the first argument to the library call
-             gfor_fndecl_set_options
-           + modify the library (runtime/compile_options.c)!  */
-      array = tree_cons (NULL_TREE,
-                         build_int_cst (integer_type_node,
-                                        gfc_option.warn_std), NULL_TREE);
-      array = tree_cons (NULL_TREE,
-                         build_int_cst (integer_type_node,
-                                        gfc_option.allow_std), array);
-      array = tree_cons (NULL_TREE,
-                         build_int_cst (integer_type_node, pedantic), array);
-      array = tree_cons (NULL_TREE,
-                         build_int_cst (integer_type_node,
-                                        gfc_option.flag_dump_core), array);
-      array = tree_cons (NULL_TREE,
-                         build_int_cst (integer_type_node,
-                                        gfc_option.flag_backtrace), array);
-      array = tree_cons (NULL_TREE,
-                         build_int_cst (integer_type_node,
-                                        gfc_option.flag_sign_zero), array);
-
-      array = tree_cons (NULL_TREE,
-                         build_int_cst (integer_type_node,
-                                        flag_bounds_check), array);
-
-      array = tree_cons (NULL_TREE,
-                         build_int_cst (integer_type_node,
-                                        gfc_option.flag_range_check), array);
-
-      array_type = build_array_type (integer_type_node,
-                                     build_index_type (build_int_cst (NULL_TREE,
-                                                                      7)));
-      array = build_constructor_from_list (array_type, nreverse (array));
-      TREE_CONSTANT (array) = 1;
-      TREE_STATIC (array) = 1;
-
-      /* Create a static variable to hold the jump table.  */
-      var = gfc_create_var (array_type, "options");
-      TREE_CONSTANT (var) = 1;
-      TREE_STATIC (var) = 1;
-      TREE_READONLY (var) = 1;
-      DECL_INITIAL (var) = array;
-      var = gfc_build_addr_expr (pvoid_type_node, var);
-
-      tmp = build_call_expr (gfor_fndecl_set_options, 2,
-                             build_int_cst (integer_type_node, 8), var);
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  /* If this is the main program and a -ffpe-trap option was provided,
-     add a call to set_fpe so that the library will raise a FPE when
-     needed.  */
-  if (sym->attr.is_main_program && gfc_option.fpe != 0)
-    {
-      tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
-                             build_int_cst (integer_type_node,
-                                            gfc_option.fpe));
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  /* If this is the main program and an -fconvert option was provided,
-     add a call to set_convert.  */
-
-  if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
-    {
-      tmp = build_call_expr (gfor_fndecl_set_convert, 1,
-                             build_int_cst (integer_type_node,
-                                            gfc_option.convert));
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  /* If this is the main program and an -frecord-marker option was provided,
-     add a call to set_record_marker.  */
-
-  if (sym->attr.is_main_program && gfc_option.record_marker != 0)
-    {
-      tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
-                             build_int_cst (integer_type_node,
-                                            gfc_option.record_marker));
-      gfc_add_expr_to_block (&body, tmp);
-    }
-
-  if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
-    {
-      tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
-                             1,
-                             build_int_cst (integer_type_node,
-                                            gfc_option.max_subrecord_length));
-      gfc_add_expr_to_block (&body, tmp);
+       asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",
+                 sym->name);
+       recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");
+       TREE_STATIC (recurcheckvar) = 1;
+       DECL_INITIAL (recurcheckvar) = boolean_false_node;
+       gfc_add_expr_to_block (&block, recurcheckvar);
+       gfc_trans_runtime_check (true, false, recurcheckvar, &block,
+                                &sym->declared_at, msg);
+       gfc_add_modify (&block, recurcheckvar, boolean_true_node);
+       gfc_free (msg);
     }
 
   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
-      && sym->attr.subroutine)
+        && sym->attr.subroutine)
     {
       tree alternate_return;
       alternate_return = gfc_get_fake_result_decl (sym, 0);
       gfc_add_modify (&body, alternate_return, integer_zero_node);
     }
 
   if (ns->entries)
     {
       /* Jump to the correct entry point.  */
       tmp = gfc_trans_entry_master_switch (ns->entries);
       gfc_add_expr_to_block (&body, tmp);
     }
 
+  /* If bounds-checking is enabled, generate code to check passed in actual
+     arguments against the expected dummy argument attributes (e.g. string
+     lengths).  */
+  if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)
+    add_argument_checking (&body, sym);
+
   tmp = gfc_trans_code (ns->code);
   gfc_add_expr_to_block (&body, tmp);
 
   /* Add a return label if needed.  */
   if (current_function_return_label)
     {
       tmp = build1_v (LABEL_EXPR, current_function_return_label);
       gfc_add_expr_to_block (&body, tmp);
     }
 
   tmp = gfc_finish_block (&body);
   /* Add code to create and cleanup arrays.  */
   tmp = gfc_trans_deferred_vars (sym, tmp);
 
   if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
     {
       if (sym->attr.subroutine || sym == sym->result)
         {
           if (current_fake_result_decl != NULL)
             result = TREE_VALUE (current_fake_result_decl);
           else
             result = NULL_TREE;
           current_fake_result_decl = NULL_TREE;
         }
       else
         result = sym->result->backend_decl;
 
-      if (result != NULL_TREE && sym->attr.function
-            && sym->ts.type == BT_DERIVED
-            && sym->ts.derived->attr.alloc_comp
+      if (result != NULL_TREE
+            && sym->attr.function
             && !sym->attr.pointer)
         {
-          rank = sym->as ? sym->as->rank : 0;
-          tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
-          gfc_add_expr_to_block (&block, tmp2);
+          if (sym->ts.type == BT_DERIVED
+              && sym->ts.u.derived->attr.alloc_comp)
+            {
+              rank = sym->as ? sym->as->rank : 0;
+              tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
+              gfc_add_expr_to_block (&block, tmp2);
+            }
+          else if (sym->attr.allocatable && sym->attr.dimension == 0)
+            gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
+                                                          null_pointer_node));
         }
 
       gfc_add_expr_to_block (&block, tmp);
 
+      /* Reset recursion-check variable.  */
+      if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+             && !is_recursive
+             && !gfc_option.flag_openmp
+             && recurcheckvar != NULL_TREE)
+        {
+          gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+          recurcheckvar = NULL;
+        }
+
       if (result == NULL_TREE)
         {
           /* TODO: move to the appropriate place in resolve.c.  */
           if (warn_return_type && !sym->attr.referenced && sym == sym->result)
             gfc_warning ("Return value of function '%s' at %L not set",
                          sym->name, &sym->declared_at);
 
           TREE_NO_WARNING(sym->backend_decl) = 1;
         }
       else
         {
           /* Set the return value to the dummy result variable.  The
              types may be different for scalar default REAL functions
              with -ff2c, therefore we have to convert.  */
           tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
           tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
                              DECL_RESULT (fndecl), tmp);
           tmp = build1_v (RETURN_EXPR, tmp);
           gfc_add_expr_to_block (&block, tmp);
         }
     }
   else
-    gfc_add_expr_to_block (&block, tmp);
+    {
+      gfc_add_expr_to_block (&block, tmp);
+      /* Reset recursion-check variable.  */
+      if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
+             && !is_recursive
+             && !gfc_option.flag_openmp
+             && recurcheckvar != NULL_TREE)
+        {
+          gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+          recurcheckvar = NULL_TREE;
+        }
+    }
 
 
   /* Add all the decls we created during processing.  */
   decl = saved_function_decls;
   while (decl)
     {
       tree next;
 
       next = TREE_CHAIN (decl);
       TREE_CHAIN (decl) = NULL_TREE;
       pushdecl (decl);
       decl = next;
     }
   saved_function_decls = NULL_TREE;
 
   DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
   decl = getdecls ();
 
   /* Finish off this function and send it for code generation.  */
   poplevel (1, 0, 1);
   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
 
   DECL_SAVED_TREE (fndecl)
     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
                 DECL_INITIAL (fndecl));
 
+  if (nonlocal_dummy_decls)
+    {
+      BLOCK_VARS (DECL_INITIAL (fndecl))
+        = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);
+      pointer_set_destroy (nonlocal_dummy_decl_pset);
+      nonlocal_dummy_decls = NULL;
+      nonlocal_dummy_decl_pset = NULL;
+    }
+
   /* Output the GENERIC tree.  */
   dump_function (TDI_original, fndecl);
 
   /* Store the end of the function, so that we get good line number
      info for the epilogue.  */
   cfun->function_end_locus = input_location;
 
   /* We're leaving the context of this function, so zap cfun.
      It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
      tree_rest_of_compilation.  */
   set_cfun (NULL);
 
   if (old_context)
     {
       pop_function_context ();
       saved_function_decls = saved_parent_function_decls;
     }
   current_function_decl = old_context;
 
   if (decl_function_context (fndecl))
     /* Register this function with cgraph just far enough to get it
        added to our parent's nested function list.  */
     (void) cgraph_node (fndecl);
   else
-    {
-      gfc_gimplify_function (fndecl);
-      cgraph_finalize_function (fndecl, false);
-    }
+    cgraph_finalize_function (fndecl, true);
 
   gfc_trans_use_stmts (ns);
   gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
+
+  if (sym->attr.is_main_program)
+    create_main_function (fndecl);
 }
 
+
 void
 gfc_generate_constructors (void)
 {
   gcc_assert (gfc_static_ctors == NULL_TREE);
 #if 0
   tree fnname;
   tree type;
   tree fndecl;
   tree decl;
   tree tmp;
 
   if (gfc_static_ctors == NULL_TREE)
     return;
 
   fnname = get_file_function_name ("I");
   type = build_function_type (void_type_node,
                               gfc_chainon_list (NULL_TREE, void_type_node));
 
-  fndecl = build_decl (FUNCTION_DECL, fnname, type);
+  fndecl = build_decl (input_location,
+                       FUNCTION_DECL, fnname, type);
   TREE_PUBLIC (fndecl) = 1;
 
-  decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
+  decl = build_decl (input_location,
+                     RESULT_DECL, NULL_TREE, void_type_node);
   DECL_ARTIFICIAL (decl) = 1;
   DECL_IGNORED_P (decl) = 1;
   DECL_CONTEXT (decl) = fndecl;
   DECL_RESULT (fndecl) = decl;
 
   pushdecl (fndecl);
 
   current_function_decl = fndecl;
 
   rest_of_decl_compilation (fndecl, 1, 0);
 
   make_decl_rtl (fndecl);
 
   init_function_start (fndecl);
 
   pushlevel (0);
 
   for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
     {
-      tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
-      DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
+      tmp = build_call_expr_loc (input_location,
+                             TREE_VALUE (gfc_static_ctors), 0);
+      DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);
     }
 
   decl = getdecls ();
   poplevel (1, 0, 1);
 
   BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
   DECL_SAVED_TREE (fndecl)
     = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),
                 DECL_INITIAL (fndecl));
 
@@ skipping 27 matching lines @@
   gfc_trans_common (ns);
 
   /* Create a global symbol with the mane of the block data.  This is to
      generate linker errors if the same name is used twice.  It is never
      really used.  */
   if (ns->proc_name)
     id = gfc_sym_mangled_function_id (ns->proc_name);
   else
     id = get_identifier ("__BLOCK_DATA__");
 
-  decl = build_decl (VAR_DECL, id, gfc_array_index_type);
+  decl = build_decl (input_location,
+                     VAR_DECL, id, gfc_array_index_type);
   TREE_PUBLIC (decl) = 1;
   TREE_STATIC (decl) = 1;
   DECL_IGNORED_P (decl) = 1;
 
   pushdecl (decl);
   rest_of_decl_compilation (decl, 1, 0);
 }
 
 
+/* Process the local variables of a BLOCK construct.  */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+  tree decl;
+
+  gcc_assert (saved_local_decls == NULL_TREE);
+  generate_local_vars (ns);
+
+  decl = saved_local_decls;
+  while (decl)
+    {
+      tree next;
+
+      next = TREE_CHAIN (decl);
+      TREE_CHAIN (decl) = NULL_TREE;
+      pushdecl (decl);
+      decl = next;
+    }
+  saved_local_decls = NULL_TREE;
+}
+
+
 #include "gt-fortran-trans-decl.h"