re PR fortran/32599 ([ISO C Binding] Accepts character with len /= 1)

2007-07-12  Christopher D. Rickett  <crickett@lanl.gov>

	PR fortran/32599
	* decl.c (verify_c_interop_param): Require character string dummy
	args to BIND(C) procedures to have length 1.
	* resolve.c (resolve_fl_procedure): Modify parameter checking for
	BIND(C) procedures.

	PR fortran/32601
	* resolve.c (gfc_iso_c_func_interface): Verify that a valid
	expression is given as an argument to C_LOC and C_ASSOCIATED.
	* trans-io.c (transfer_expr): Add argument for code block.  Add
	standards check to determine if an error message should be
	reported for printing C_PTR or C_FUNPTR.
	(transfer_array_component): Update arguments to transfer_expr.
	(gfc_trans_transfer): Ditto.

	* symbol.c (gen_cptr_param): Fix whitespace.


2007-07-12  Christopher D. Rickett  <crickett@lanl.gov>

	PR fortran/32599
	* gfortran.dg/32599.f03: New test case.

	PR fortran/32601
	* gfortran.dg/32601.f03: New test case.
	* gfortran.dg/32601_1.f03: Ditto.
	* gfortran.dg/c_ptr_tests_9.f03: Updated dg-options.
	* gfortran.dg/c_ptr_tests_10.f03: Ditto.

From-SVN: r126598

5 files changed, 88 insertions, 22 deletions

diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index ef75186..151b7d9 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,22 @@
+2007-07-12  Christopher D. Rickett  <crickett@lanl.gov>
+
+	PR fortran/32599
+	* decl.c (verify_c_interop_param): Require character string dummy
+	args to BIND(C) procedures to have length 1.
+	* resolve.c (resolve_fl_procedure): Modify parameter checking for
+	BIND(C) procedures.
+
+	PR fortran/32601
+	* resolve.c (gfc_iso_c_func_interface): Verify that a valid
+	expression is given as an argument to C_LOC and C_ASSOCIATED.
+	* trans-io.c (transfer_expr): Add argument for code block.  Add
+	standards check to determine if an error message should be
+	reported for printing C_PTR or C_FUNPTR.
+	(transfer_array_component): Update arguments to transfer_expr.
+	(gfc_trans_transfer): Ditto.
+
+	* symbol.c (gen_cptr_param): Fix whitespace.
+
 2007-07-12  Jakub Jelinek  <jakub@redhat.com>
 
 	PR fortran/32550
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index 67e8ef7..00241b8 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -838,7 +838,24 @@ verify_c_interop_param (gfc_symbol *sym)
 			     sym->name, &(sym->declared_at),
 			     sym->ns->proc_name->name);
 	    }
- 
+
+          /* Character strings are only C interoperable if they have a
+             length of 1.  */
+          if (sym->ts.type == BT_CHARACTER)
+	    {
+	      gfc_charlen *cl = sym->ts.cl;
+	      if (!cl || !cl->length || cl->length->expr_type != EXPR_CONSTANT
+                  || mpz_cmp_si (cl->length->value.integer, 1) != 0)
+		{
+		  gfc_error ("Character argument '%s' at %L "
+			     "must be length 1 because "
+                             "procedure '%s' is BIND(C)",
+			     sym->name, &sym->declared_at,
+                             sym->ns->proc_name->name);
+		  retval = FAILURE;
+		}
+	    }
+
 	  /* We have to make sure that any param to a bind(c) routine does
 	     not have the allocatable, pointer, or optional attributes,
 	     according to J3/04-007, section 5.1.  */
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 911d5ec..f12cbd4 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -1717,6 +1717,15 @@ gfc_iso_c_func_interface (gfc_symbol *sym, gfc_actual_arglist *args,
   try retval = SUCCESS;
   gfc_symbol *args_sym;
 
+  if (args->expr->expr_type == EXPR_CONSTANT
+      || args->expr->expr_type == EXPR_OP
+      || args->expr->expr_type == EXPR_NULL)
+    {
+      gfc_error ("Argument to '%s' at %L is not a variable",
+		 sym->name, &(args->expr->where));
+      return FAILURE;
+    }
+
   args_sym = args->expr->symtree->n.sym;
    
   if (sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)
@@ -6798,6 +6807,7 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
   if (sym->attr.is_bind_c && sym->attr.is_c_interop != 1)
     {
       gfc_formal_arglist *curr_arg;
+      int has_non_interop_arg = 0;
 
       if (verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
                              sym->common_block) == FAILURE)
@@ -6819,18 +6829,25 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
       while (curr_arg != NULL)
         {
           /* Skip implicitly typed dummy args here.  */
-          if (curr_arg->sym->attr.implicit_type == 0
-	      && verify_c_interop_param (curr_arg->sym) == FAILURE)
-            {
-              /* If something is found to fail, mark the symbol for the
-                 procedure as not being BIND(C) to try and prevent multiple
-                 errors being reported.  */
-              sym->attr.is_c_interop = 0;
-              sym->ts.is_c_interop = 0;
-              sym->attr.is_bind_c = 0;
-            }
+	  if (curr_arg->sym->attr.implicit_type == 0)
+	    if (verify_c_interop_param (curr_arg->sym) == FAILURE)
+	      /* If something is found to fail, record the fact so we
+		 can mark the symbol for the procedure as not being
+		 BIND(C) to try and prevent multiple errors being
+		 reported.  */
+	      has_non_interop_arg = 1;
+          
           curr_arg = curr_arg->next;
         }
+
+      /* See if any of the arguments were not interoperable and if so, clear
+	 the procedure symbol to prevent duplicate error messages.  */
+      if (has_non_interop_arg != 0)
+	{
+	  sym->attr.is_c_interop = 0;
+	  sym->ts.is_c_interop = 0;
+	  sym->attr.is_bind_c = 0;
+	}
     }
   
   return SUCCESS;
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 5e76fe2..e83c190 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -3290,7 +3290,6 @@ gen_cptr_param (gfc_formal_arglist **head,
 
   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
     c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
-
   else
     c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
 
@@ -3321,7 +3320,7 @@ gen_cptr_param (gfc_formal_arglist **head,
   if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
     c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
   else
-  c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
+    c_ptr_sym = get_iso_c_binding_dt (ISOCBINDING_PTR);
   if (c_ptr_sym == NULL)
     {
       /* This can happen if the user did not define c_ptr but they are
@@ -3330,7 +3329,7 @@ gen_cptr_param (gfc_formal_arglist **head,
 	generate_isocbinding_symbol (module_name, ISOCBINDING_FUNPTR,
 				     (char *)c_ptr_type);
       else
-      generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
+	generate_isocbinding_symbol (module_name, ISOCBINDING_PTR,
 				     (char *)c_ptr_type);
 
       gfc_get_ha_symbol (c_ptr_type, &(c_ptr_sym));
diff --git a/gcc/fortran/trans-io.c b/gcc/fortran/trans-io.c
index 4d7695e..4b70871 100644
--- a/gcc/fortran/trans-io.c
+++ b/gcc/fortran/trans-io.c
@@ -1712,7 +1712,7 @@ gfc_trans_dt_end (gfc_code * code)
 }
 
 static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr);
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code);
 
 /* Given an array field in a derived type variable, generate the code
    for the loop that iterates over array elements, and the code that
@@ -1780,7 +1780,7 @@ transfer_array_component (tree expr, gfc_component * cm)
   /* Now se.expr contains an element of the array.  Take the address and pass
      it to the IO routines.  */
   tmp = build_fold_addr_expr (se.expr);
-  transfer_expr (&se, &cm->ts, tmp);
+  transfer_expr (&se, &cm->ts, tmp, NULL);
 
   /* We are done now with the loop body.  Wrap up the scalarizer and
      return.  */
@@ -1805,7 +1805,7 @@ transfer_array_component (tree expr, gfc_component * cm)
 /* Generate the call for a scalar transfer node.  */
 
 static void
-transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
+transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr, gfc_code * code)
 {
   tree tmp, function, arg2, field, expr;
   gfc_component *c;
@@ -1814,9 +1814,23 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
   /* It is possible to get a C_NULL_PTR or C_NULL_FUNPTR expression here if
      the user says something like: print *, 'c_null_ptr: ', c_null_ptr
      We need to translate the expression to a constant if it's either
-     C_NULL_PTR or C_NULL_FUNPTR.  */
-  if (ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
+     C_NULL_PTR or C_NULL_FUNPTR.  We could also get a user variable of
+     type C_PTR or C_FUNPTR, in which case the ts->type may no longer be
+     BT_DERIVED (could have been changed by gfc_conv_expr).  */
+  if ((ts->type == BT_DERIVED && ts->is_iso_c == 1 && ts->derived != NULL)
+      || (ts->derived != NULL && ts->derived->ts.is_iso_c == 1))
     {
+      /* C_PTR and C_FUNPTR have private components which means they can not
+         be printed.  However, if -std=gnu and not -pedantic, allow
+         the component to be printed to help debugging.  */
+      if (gfc_notification_std (GFC_STD_GNU) != SILENT)
+	{
+	  gfc_error_now ("Derived type '%s' at %L has PRIVATE components",
+			 ts->derived->name, code != NULL ? &(code->loc) : 
+			 &gfc_current_locus);
+	  return;
+	}
+
       ts->type = ts->derived->ts.type;
       ts->kind = ts->derived->ts.kind;
       ts->f90_type = ts->derived->ts.f90_type;
@@ -1883,7 +1897,7 @@ transfer_expr (gfc_se * se, gfc_typespec * ts, tree addr_expr)
             {
               if (!c->pointer)
                 tmp = build_fold_addr_expr (tmp);
-              transfer_expr (se, &c->ts, tmp);
+              transfer_expr (se, &c->ts, tmp, code);
             }
 	}
       return;
@@ -1949,7 +1963,7 @@ gfc_trans_transfer (gfc_code * code)
     {
       /* Transfer a scalar value.  */
       gfc_conv_expr_reference (&se, expr);
-      transfer_expr (&se, &expr->ts, se.expr);
+      transfer_expr (&se, &expr->ts, se.expr, code);
     }
   else
     {
@@ -1988,7 +2002,7 @@ gfc_trans_transfer (gfc_code * code)
       se.ss = ss;
 
       gfc_conv_expr_reference (&se, expr);
-      transfer_expr (&se, &expr->ts, se.expr);
+      transfer_expr (&se, &expr->ts, se.expr, code);
     }
 
  finish_block_label: