From aa5e22f00044aff47df0997d9f5d794e91cba2dd Mon Sep 17 00:00:00 2001 From: "Christopher D. Rickett" Date: Thu, 12 Jul 2007 19:52:03 +0000 Subject: re PR fortran/32599 ([ISO C Binding] Accepts character with len /= 1) 2007-07-12 Christopher D. Rickett 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 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 --- gcc/fortran/trans-io.c | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) (limited to 'gcc/fortran/trans-io.c') 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: -- cgit v1.1