re PR fortran/38536 (ICE with C_LOC in resolve.c due to not properly going through expr->ref)

2013-03-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/38536
        PR fortran/38813
        PR fortran/38894
        PR fortran/39288
        PR fortran/40963
        PR fortran/45824
        PR fortran/47023
        PR fortran/47034
        PR fortran/49023
        PR fortran/50269
        PR fortran/50612
        PR fortran/52426
        PR fortran/54263
        PR fortran/55343
        PR fortran/55444
        PR fortran/55574
        PR fortran/56079
        PR fortran/56378
        * check.c (gfc_var_strlen): Properly handle 0-sized string.
        (gfc_check_c_sizeof): Use is_c_interoperable, add checks.
        (is_c_interoperable, gfc_check_c_associated, gfc_check_c_f_pointer,
        gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc): New
        functions.
        * expr.c (check_inquiry): Add c_sizeof, compiler_version and
        compiler_options.
        (gfc_check_pointer_assign): Refine function result check.
        gfortran.h (gfc_isym_id): Add GFC_ISYM_C_ASSOCIATED,
        GFC_ISYM_C_F_POINTER, GFC_ISYM_C_F_PROCPOINTER, GFC_ISYM_C_FUNLOC,
        GFC_ISYM_C_LOC.
        (iso_fortran_env_symbol, iso_c_binding_symbol): Handle
        NAMED_SUBROUTINE.
        (generate_isocbinding_symbol): Update prototype.
        (get_iso_c_sym): Remove.
        (gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New prototypes.
        * intrinsic.c (gfc_intrinsic_subroutine_by_id): New function.
        (gfc_intrinsic_sub_interface): Use it.
        (add_functions, add_subroutines): Add missing C-binding intrinsics.
        (gfc_intrinsic_func_interface): Add special case for c_loc.
        gfc_isym_id_by_intmod, gfc_isym_id_by_intmod_sym): New functions.
        (gfc_intrinsic_func_interface, gfc_intrinsic_sub_interface): Use them.
        * intrinsic.h (gfc_check_c_associated, gfc_check_c_f_pointer,
        gfc_check_c_f_procpointer, gfc_check_c_funloc, gfc_check_c_loc,
        gfc_resolve_c_loc, gfc_resolve_c_funloc): New prototypes.
        * iresolve.c (gfc_resolve_c_loc, gfc_resolve_c_funloc): New
        functions.
        * iso-c-binding.def: Split PROCEDURE into NAMED_SUBROUTINE and
        NAMED_FUNCTION.
        * iso-fortran-env.def: Add NAMED_SUBROUTINE for completeness.
        * module.c (create_intrinsic_function): Support subroutines and
        derived-type results.
        (use_iso_fortran_env_module): Update calls.
        (import_iso_c_binding_module): Ditto; update calls to
        generate_isocbinding_symbol.
        * resolve.c (find_arglists): Skip for intrinsic symbols.
        (gfc_resolve_intrinsic): Find intrinsic subs via id.
        (is_scalar_expr_ptr, gfc_iso_c_func_interface,
        set_name_and_label, gfc_iso_c_sub_interface): Remove.
        (resolve_function, resolve_specific_s0): Remove calls to those.
        (resolve_structure_cons): Fix handling.
        * symbol.c (gen_special_c_interop_ptr): Update c_ptr/c_funptr
        generation.
        (gen_cptr_param, gen_fptr_param, gen_shape_param,
        build_formal_args, get_iso_c_sym): Remove.
        (std_for_isocbinding_symbol): Handle NAMED_SUBROUTINE.
        (generate_isocbinding_symbol): Support hidden symbols and
        using c_ptr/c_funptr symtrees for nullptr defs.
        * target-memory.c (gfc_target_encode_expr): Fix handling
        of c_ptr/c_funptr.
        * trans-expr.c (conv_isocbinding_procedure): Remove.
        (gfc_conv_procedure_call): Remove call to it.
        (gfc_trans_subcomponent_assign, gfc_conv_expr): Update handling
        of c_ptr/c_funptr.
        * trans-intrinsic.c (conv_isocbinding_function,
        conv_isocbinding_subroutine): New.
        (gfc_conv_intrinsic_function, gfc_conv_intrinsic_subroutine):
        Call them.
        * trans-io.c (transfer_expr): Fix handling of c_ptr/c_funptr.
        * trans-types.c (gfc_typenode_for_spec,
        gfc_get_derived_type): Ditto.
        (gfc_init_c_interop_kinds): Handle NAMED_SUBROUTINE.

2013-03-25  Tobias Burnus  <burnus@net-b.de>

        PR fortran/38536
        PR fortran/38813
        PR fortran/38894
        PR fortran/39288
        PR fortran/40963
        PR fortran/45824
        PR fortran/47023
        PR fortran/47034
        PR fortran/49023
        PR fortran/50269
        PR fortran/50612
        PR fortran/52426
        PR fortran/54263
        PR fortran/55343
        PR fortran/55444
        PR fortran/55574
        PR fortran/56079
        PR fortran/56378
        * gfortran.dg/c_assoc_2.f03: Update dg-error wording.
        * gfortran.dg/c_f_pointer_shape_test.f90: Ditto.
        * gfortran.dg/c_f_pointer_shape_tests_3.f03: Ditto.
        * gfortran.dg/c_f_pointer_tests_5.f90: Ditto.
        * gfortran.dg/c_funloc_tests_2.f03: Ditto.
        * gfortran.dg/c_funloc_tests_5.f03: Ditto.
        * gfortran.dg/c_funloc_tests_6.f90: Ditto.
        * gfortran.dg/c_loc_tests_10.f03: Add -std=f2008.
        * gfortran.dg/c_loc_tests_11.f03: Ditto, update dg-error.
        * gfortran.dg/c_loc_tests_16.f90: Ditto.
        * gfortran.dg/c_loc_tests_4.f03: Ditto.
        * gfortran.dg/c_loc_tests_15.f90: Update dg-error wording.
        * gfortran.dg/c_loc_tests_3.f03: Valid since F2003 TC5.
        * gfortran.dg/c_loc_tests_8.f03: Ditto.
        * gfortran.dg/c_ptr_tests_14.f90: Update scan-tree-dump-times.
        * gfortran.dg/c_ptr_tests_15.f90: Ditto.
        * gfortran.dg/c_sizeof_1.f90: Fix invalid code.
        * gfortran.dg/iso_c_binding_init_expr.f03: Update dg-error wording.
        * gfortran.dg/pr32601_1.f03: Ditto.
        * gfortran.dg/storage_size_2.f08: Remove dg-error.
        * gfortran.dg/blockdata_7.f90: New.
        * gfortran.dg/c_assoc_4.f90: New.
        * gfortran.dg/c_f_pointer_tests_6.f90: New.
        * gfortran.dg/c_f_pointer_tests_7.f90: New.
        * gfortran.dg/c_funloc_tests_8.f90: New.
        * gfortran.dg/c_loc_test_17.f90: New.
        * gfortran.dg/c_loc_test_18.f90: New.
        * gfortran.dg/c_loc_test_19.f90: New.
        * gfortran.dg/c_loc_test_20.f90: New.
        * gfortran.dg/c_sizeof_5.f90: New.
        * gfortran.dg/iso_c_binding_rename_3.f90: New.
        * gfortran.dg/transfer_resolve_2.f90: New.
        * gfortran.dg/transfer_resolve_3.f90: New.
        * gfortran.dg/transfer_resolve_4.f90: New.
        * gfortran.dg/pr32601.f03: Update dg-error.
        * gfortran.dg/c_ptr_tests_13.f03: Update dg-error.
        * gfortran.dg/c_ptr_tests_9.f03: Fix test case.

From-SVN: r197053

1 files changed, 154 insertions, 52 deletions

diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c
index 1b38555..ee09291 100644
--- a/gcc/fortran/module.c
+++ b/gcc/fortran/module.c
@@ -5570,8 +5570,9 @@ gfc_dump_module (const char *name, int dump_flag)
 
 
 static void
-create_intrinsic_function (const char *name, gfc_isym_id id,
-			   const char *modname, intmod_id module)
+create_intrinsic_function (const char *name, int id,
+			   const char *modname, intmod_id module,
+			   bool subroutine, gfc_symbol *result_type)
 {
   gfc_intrinsic_sym *isym;
   gfc_symtree *tmp_symtree;
@@ -5588,7 +5589,30 @@ create_intrinsic_function (const char *name, gfc_isym_id id,
   gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
   sym = tmp_symtree->n.sym;
 
-  isym = gfc_intrinsic_function_by_id (id);
+  if (subroutine)
+    {
+      gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
+      isym = gfc_intrinsic_subroutine_by_id (isym_id);
+      sym->attr.subroutine = 1;
+    }
+  else
+    {
+      gfc_isym_id isym_id = gfc_isym_id_by_intmod (module, id);
+      isym = gfc_intrinsic_function_by_id (isym_id);
+
+      sym->attr.function = 1;
+      if (result_type)
+	{
+	  sym->ts.type = BT_DERIVED;
+	  sym->ts.u.derived = result_type;
+	  sym->ts.is_c_interop = 1;
+	  isym->ts.f90_type = BT_VOID;
+	  isym->ts.type = BT_DERIVED;
+	  isym->ts.f90_type = BT_VOID;
+	  isym->ts.u.derived = result_type;
+	  isym->ts.is_c_interop = 1;
+	}
+    }
   gcc_assert (isym);
 
   sym->attr.flavor = FL_PROCEDURE;
@@ -5609,11 +5633,13 @@ create_intrinsic_function (const char *name, gfc_isym_id id,
 static void
 import_iso_c_binding_module (void)
 {
-  gfc_symbol *mod_sym = NULL;
-  gfc_symtree *mod_symtree = NULL;
+  gfc_symbol *mod_sym = NULL, *return_type;
+  gfc_symtree *mod_symtree = NULL, *tmp_symtree;
+  gfc_symtree *c_ptr = NULL, *c_funptr = NULL;
   const char *iso_c_module_name = "__iso_c_binding";
   gfc_use_rename *u;
   int i;
+  bool want_c_ptr = false, want_c_funptr = false;
 
   /* Look only in the current namespace.  */
   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, iso_c_module_name);
@@ -5636,6 +5662,57 @@ import_iso_c_binding_module (void)
       mod_sym->from_intmod = INTMOD_ISO_C_BINDING;
     }
 
+  /* Check whether C_PTR or C_FUNPTR are in the include list, if so, load it;
+     check also whether C_NULL_(FUN)PTR or C_(FUN)LOC are requested, which
+     need C_(FUN)PTR.  */
+  for (u = gfc_rename_list; u; u = u->next)
+    {
+      if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_PTR].name,
+		  u->use_name) == 0)
+        want_c_ptr = true;
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_LOC].name,
+		       u->use_name) == 0)
+        want_c_ptr = true;
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_NULL_FUNPTR].name,
+		       u->use_name) == 0)
+        want_c_funptr = true;
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNLOC].name,
+		       u->use_name) == 0)
+        want_c_funptr = true;
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_PTR].name,
+                       u->use_name) == 0)
+	{
+	  c_ptr = generate_isocbinding_symbol (iso_c_module_name,
+                                               (iso_c_binding_symbol)
+							ISOCBINDING_PTR,
+                                               u->local_name[0] ? u->local_name
+                                                                : u->use_name,
+                                               NULL, false);
+	}
+      else if (strcmp (c_interop_kinds_table[ISOCBINDING_FUNPTR].name,
+                       u->use_name) == 0)
+	{
+	  c_funptr
+	     = generate_isocbinding_symbol (iso_c_module_name,
+					    (iso_c_binding_symbol)
+							ISOCBINDING_FUNPTR,
+					     u->local_name[0] ? u->local_name
+							      : u->use_name,
+					     NULL, false);
+	}
+    }
+
+  if ((want_c_ptr || !only_flag) && !c_ptr)
+    c_ptr = generate_isocbinding_symbol (iso_c_module_name,
+					 (iso_c_binding_symbol)
+							ISOCBINDING_PTR,
+					 NULL, NULL, only_flag);
+  if ((want_c_funptr || !only_flag) && !c_funptr)
+    c_funptr = generate_isocbinding_symbol (iso_c_module_name,
+					    (iso_c_binding_symbol)
+							ISOCBINDING_FUNPTR,
+					    NULL, NULL, only_flag);
+
   /* Generate the symbols for the named constants representing
      the kinds for intrinsic data types.  */
   for (i = 0; i < ISOCBINDING_NUMBER; i++)
@@ -5656,29 +5733,27 @@ import_iso_c_binding_module (void)
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
 		  name = b; \
 		  break;
-#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
+#define NAMED_SUBROUTINE(a,b,c,d) \
+	        case a: \
+		  not_in_std = (gfc_option.allow_std & d) == 0; \
+		  name = b; \
+		  break;
 #define NAMED_INTCST(a,b,c,d) \
 	        case a: \
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
 		  name = b; \
 		  break;
-#include "iso-c-binding.def"
-#undef NAMED_INTCST
 #define NAMED_REALCST(a,b,c,d) \
 	        case a: \
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
 		  name = b; \
 		  break;
-#include "iso-c-binding.def"
-#undef NAMED_REALCST
 #define NAMED_CMPXCST(a,b,c,d) \
 	        case a: \
 		  not_in_std = (gfc_option.allow_std & d) == 0; \
 		  name = b; \
 		  break;
 #include "iso-c-binding.def"
-#undef NAMED_CMPXCST
 		default:
 		  not_in_std = false;
 		  name = "";
@@ -5695,20 +5770,43 @@ import_iso_c_binding_module (void)
 	      {
 #define NAMED_FUNCTION(a,b,c,d) \
 	        case a: \
+		  if (a == ISOCBINDING_LOC) \
+		    return_type = c_ptr->n.sym; \
+		  else if (a == ISOCBINDING_FUNLOC) \
+		    return_type = c_funptr->n.sym; \
+		  else \
+		    return_type = NULL; \
+		  create_intrinsic_function (u->local_name[0] \
+					     ? u->local_name : u->use_name, \
+					     a, iso_c_module_name, \
+					     INTMOD_ISO_C_BINDING, false, \
+					     return_type); \
+		  break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+	        case a: \
 		  create_intrinsic_function (u->local_name[0] ? u->local_name \
 							      : u->use_name, \
-					     (gfc_isym_id) c, \
-                                             iso_c_module_name, \
-                                             INTMOD_ISO_C_BINDING); \
+                                             a, iso_c_module_name, \
+                                             INTMOD_ISO_C_BINDING, true, NULL); \
 		  break;
 #include "iso-c-binding.def"
-#undef NAMED_FUNCTION
 
+		case ISOCBINDING_PTR:
+		case ISOCBINDING_FUNPTR:
+		  /* Already handled above.  */
+		  break;
 		default:
+		  if (i == ISOCBINDING_NULL_PTR)
+		    tmp_symtree = c_ptr;
+		  else if (i == ISOCBINDING_NULL_FUNPTR)
+		    tmp_symtree = c_funptr;
+		  else
+		    tmp_symtree = NULL;
 		  generate_isocbinding_symbol (iso_c_module_name,
 					       (iso_c_binding_symbol) i,
-					       u->local_name[0] ? u->local_name
-								: u->use_name);
+					       u->local_name[0]
+					       ? u->local_name : u->use_name,
+					       tmp_symtree, false);
 	      }
 	  }
 
@@ -5722,30 +5820,27 @@ import_iso_c_binding_module (void)
 		if ((gfc_option.allow_std & d) == 0) \
 		  continue; \
 		break;
-#include "iso-c-binding.def"
-#undef NAMED_FUNCTION
-
+#define NAMED_SUBROUTINE(a,b,c,d) \
+	      case a: \
+		if ((gfc_option.allow_std & d) == 0) \
+		  continue; \
+		break;
 #define NAMED_INTCST(a,b,c,d) \
 	      case a: \
 		if ((gfc_option.allow_std & d) == 0) \
 		  continue; \
 		break;
-#include "iso-c-binding.def"
-#undef NAMED_INTCST
 #define NAMED_REALCST(a,b,c,d) \
 	      case a: \
 		if ((gfc_option.allow_std & d) == 0) \
 		  continue; \
 		break;
-#include "iso-c-binding.def"
-#undef NAMED_REALCST
 #define NAMED_CMPXCST(a,b,c,d) \
 	      case a: \
 		if ((gfc_option.allow_std & d) == 0) \
 		  continue; \
 		break;
 #include "iso-c-binding.def"
-#undef NAMED_CMPXCST
 	      default:
 		; /* Not GFC_STD_* versioned. */
 	    }
@@ -5754,16 +5849,37 @@ import_iso_c_binding_module (void)
 	    {
 #define NAMED_FUNCTION(a,b,c,d) \
 	      case a: \
-		create_intrinsic_function (b, (gfc_isym_id) c, \
-					   iso_c_module_name, \
-					   INTMOD_ISO_C_BINDING); \
+		if (a == ISOCBINDING_LOC) \
+		  return_type = c_ptr->n.sym; \
+		else if (a == ISOCBINDING_FUNLOC) \
+		  return_type = c_funptr->n.sym; \
+		else \
+		  return_type = NULL; \
+		create_intrinsic_function (b, a, iso_c_module_name, \
+					   INTMOD_ISO_C_BINDING, false, \
+					   return_type); \
+		break;
+#define NAMED_SUBROUTINE(a,b,c,d) \
+	      case a: \
+		create_intrinsic_function (b, a, iso_c_module_name, \
+					   INTMOD_ISO_C_BINDING, true, NULL); \
 		  break;
 #include "iso-c-binding.def"
-#undef NAMED_FUNCTION
 
+	      case ISOCBINDING_PTR:
+	      case ISOCBINDING_FUNPTR:
+		/* Already handled above.  */
+		break;
 	      default:
+		if (i == ISOCBINDING_NULL_PTR)
+		  tmp_symtree = c_ptr;
+		else if (i == ISOCBINDING_NULL_FUNPTR)
+		  tmp_symtree = c_funptr;
+		else
+		  tmp_symtree = NULL;
 		generate_isocbinding_symbol (iso_c_module_name,
-					     (iso_c_binding_symbol) i, NULL);
+					     (iso_c_binding_symbol) i, NULL,
+					     tmp_symtree, false);
 	    }
 	}
    }
@@ -5917,23 +6033,16 @@ use_iso_fortran_env_module (void)
 
   intmod_sym symbol[] = {
 #define NAMED_INTCST(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_INTCST
 #define NAMED_KINDARRAY(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
 #define NAMED_DERIVED_TYPE(a,b,c,d) { a, b, 0, d },
-#include "iso-fortran-env.def"
-#undef NAMED_DERIVED_TYPE
 #define NAMED_FUNCTION(a,b,c,d) { a, b, c, d },
+#define NAMED_SUBROUTINE(a,b,c,d) { a, b, c, d },
 #include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
     { ISOFORTRANENV_INVALID, NULL, -1234, 0 } };
 
   i = 0;
 #define NAMED_INTCST(a,b,c,d) symbol[i++].value = c;
 #include "iso-fortran-env.def"
-#undef NAMED_INTCST
 
   /* Generate the symbol for the module itself.  */
   mod_symtree = gfc_find_symtree (gfc_current_ns->sym_root, mod);
@@ -5985,7 +6094,6 @@ use_iso_fortran_env_module (void)
 #define NAMED_INTCST(a,b,c,d) \
 		case a:
 #include "iso-fortran-env.def"
-#undef NAMED_INTCST
 		  create_int_parameter (u->local_name[0] ? u->local_name
 							 : u->use_name,
 					symbol[i].value, mod,
@@ -6008,7 +6116,6 @@ use_iso_fortran_env_module (void)
 					      symbol[i].id); \
 		  break;
 #include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
 
 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
 		case a:
@@ -6018,16 +6125,15 @@ use_iso_fortran_env_module (void)
 				       mod, INTMOD_ISO_FORTRAN_ENV,
 				       symbol[i].id);
 		  break;
-#undef NAMED_DERIVED_TYPE
 
 #define NAMED_FUNCTION(a,b,c,d) \
 		case a:
 #include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
 		  create_intrinsic_function (u->local_name[0] ? u->local_name
 							      : u->use_name,
-					     (gfc_isym_id) symbol[i].value, mod,
-					     INTMOD_ISO_FORTRAN_ENV);
+					     symbol[i].id, mod,
+					     INTMOD_ISO_FORTRAN_ENV, false,
+					     NULL);
 		  break;
 
 		default:
@@ -6054,7 +6160,6 @@ use_iso_fortran_env_module (void)
 #define NAMED_INTCST(a,b,c,d) \
 	    case a:
 #include "iso-fortran-env.def"
-#undef NAMED_INTCST
 	      create_int_parameter (symbol[i].name, symbol[i].value, mod,
 				    INTMOD_ISO_FORTRAN_ENV, symbol[i].id);
 	      break;
@@ -6071,7 +6176,6 @@ use_iso_fortran_env_module (void)
                                         INTMOD_ISO_FORTRAN_ENV, symbol[i].id);\
             break;
 #include "iso-fortran-env.def"
-#undef NAMED_KINDARRAY
 
 #define NAMED_DERIVED_TYPE(a,b,TYPE,STD) \
 	  case a:
@@ -6079,15 +6183,13 @@ use_iso_fortran_env_module (void)
 	    create_derived_type (symbol[i].name, mod, INTMOD_ISO_FORTRAN_ENV,
 				 symbol[i].id);
 	    break;
-#undef NAMED_DERIVED_TYPE
 
 #define NAMED_FUNCTION(a,b,c,d) \
 		case a:
 #include "iso-fortran-env.def"
-#undef NAMED_FUNCTION
-		  create_intrinsic_function (symbol[i].name,
-					     (gfc_isym_id) symbol[i].value, mod,
-					     INTMOD_ISO_FORTRAN_ENV);
+		  create_intrinsic_function (symbol[i].name, symbol[i].id, mod,
+					     INTMOD_ISO_FORTRAN_ENV, false,
+					     NULL);
 		  break;
 
 	  default: