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

1 files changed, 22 insertions, 8 deletions

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: