From 20460eb94863954cf7ebdc7bf2193038ac0b781a Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Mon, 29 Jun 2009 23:02:17 +0200 Subject: re PR fortran/40580 (Add -fcheck=pointer with runtime check for using an unallocated argument) 2009-06-29 Tobias Burnus PR fortran/40580 * trans-expr.c (gfc_conv_procedure_call): Add -fcheck=pointer * check. * libgfortran.h: Add GFC_RTCHECK_POINTER. * invoke.texi (-fcheck): Document new pointer option. * options.c (gfc_handle_runtime_check_option): Handle pointer * option. * gfortran.texi (C Binding): Improve wording. * iso-c-binding.def: Remove obsolete comment. 2009-06-29 Tobias Burnus PR fortran/40580 * pointer_check_1.f90: New test. * pointer_check_2.f90: New test. * pointer_check_3.f90: New test. * pointer_check_4.f90: New test. * pointer_check_5.f90: New test. From-SVN: r149063 --- gcc/fortran/trans-expr.c | 42 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) (limited to 'gcc/fortran/trans-expr.c') diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6a38f10..19ac139 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -2772,6 +2772,48 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym, gfc_add_expr_to_block (&se->post, tmp); } + /* Add argument checking of passing an unallocated/NULL actual to + a nonallocatable/nonpointer dummy. */ + + if (gfc_option.rtcheck & GFC_RTCHECK_POINTER) + { + gfc_symbol *sym; + char *msg; + tree cond; + + if (e->expr_type == EXPR_VARIABLE) + sym = e->symtree->n.sym; + else if (e->expr_type == EXPR_FUNCTION) + sym = e->symtree->n.sym->result; + else + goto end_pointer_check; + + if (sym->attr.allocatable + && (fsym == NULL || !fsym->attr.allocatable)) + asprintf (&msg, "Allocatable actual argument '%s' is not " + "allocated", sym->name); + else if (sym->attr.pointer + && (fsym == NULL || !fsym->attr.pointer)) + asprintf (&msg, "Pointer actual argument '%s' is not " + "associated", sym->name); + else if (sym->attr.proc_pointer + && (fsym == NULL || !fsym->attr.proc_pointer)) + asprintf (&msg, "Proc-pointer actual argument '%s' is not " + "associated", sym->name); + else + goto end_pointer_check; + + cond = fold_build2 (EQ_EXPR, boolean_type_node, parmse.expr, + fold_convert (TREE_TYPE (parmse.expr), + null_pointer_node)); + + gfc_trans_runtime_check (true, false, cond, &se->pre, &e->where, + msg); + gfc_free (msg); + } + end_pointer_check: + + /* Character strings are passed as two parameters, a length and a pointer - except for Bind(c) which only passes the pointer. */ if (parmse.string_length != NULL_TREE && !sym->attr.is_bind_c) -- cgit v1.1