From: Daniel Kraft Date: Thu, 18 Sep 2008 12:02:50 +0000 (+0200) Subject: re PR fortran/37507 (Print location in (DE)ALLOCATION errors) X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=f25a62a5f34a0f33b00238c6c681edac038e1078;p=platform%2Fupstream%2Fgcc.git re PR fortran/37507 (Print location in (DE)ALLOCATION errors) 2008-09-18 Daniel Kraft PR fortran/37507 * trans.h (gfc_trans_runtime_error): New method. (gfc_trans_runtime_error_vararg): New method. (gfc_allocate_array_with_status): New argument `expr' for locus/varname. (gfc_deallocate_array_with_status): Ditto. * trans-array.h (gfc_array_deallocate): Ditto. * trans.c (gfc_trans_runtime_error): New method. (gfc_trans_runtime_error_vararg): New method, moved parts of the code from gfc_trans_runtime_check here. (gfc_trans_runtime_error_check): Moved code partly to new method. (gfc_call_malloc): Fix tab-indentation. (gfc_allocate_array_with_status): New argument `expr' and call gfc_trans_runtime_error for error reporting to include locus. (gfc_deallocate_with_status): Ditto. * trans-stmt.c (gfc_trans_deallocate): Pass expr as new argument. * trans-array.c (gfc_array_allocate): Ditto. (gfc_array_deallocate): New argument `expr', passed on. (gfc_trans_dealloc_allocated): Pass NULL for expr. * trans-openmp.c (gfc_omp_clause_default): Ditto. 2008-09-18 Daniel Kraft PR fortran/37507 * gfortran.dg/allocate_error_1.f90: New test. * gfortran.dg/deallocate_error_1.f90: New test. * gfortran.dg/deallocate_error_2.f90: New test. From-SVN: r140451 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 7342496..d3d3690 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,25 @@ +2008-09-18 Daniel Kraft + + PR fortran/37507 + * trans.h (gfc_trans_runtime_error): New method. + (gfc_trans_runtime_error_vararg): New method. + (gfc_allocate_array_with_status): New argument `expr' for locus/varname. + (gfc_deallocate_array_with_status): Ditto. + * trans-array.h (gfc_array_deallocate): Ditto. + * trans.c (gfc_trans_runtime_error): New method. + (gfc_trans_runtime_error_vararg): New method, moved parts of the code + from gfc_trans_runtime_check here. + (gfc_trans_runtime_error_check): Moved code partly to new method. + (gfc_call_malloc): Fix tab-indentation. + (gfc_allocate_array_with_status): New argument `expr' and call + gfc_trans_runtime_error for error reporting to include locus. + (gfc_deallocate_with_status): Ditto. + * trans-stmt.c (gfc_trans_deallocate): Pass expr as new argument. + * trans-array.c (gfc_array_allocate): Ditto. + (gfc_array_deallocate): New argument `expr', passed on. + (gfc_trans_dealloc_allocated): Pass NULL for expr. + * trans-openmp.c (gfc_omp_clause_default): Ditto. + 2008-09-18 Paul Thomas PR fortran/37274 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 1ab58e1..f4af4f2 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -3796,7 +3796,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) /* The allocate_array variants take the old pointer as first argument. */ if (allocatable_array) - tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat); + tmp = gfc_allocate_array_with_status (&se->pre, pointer, size, pstat, expr); else tmp = gfc_allocate_with_status (&se->pre, size, pstat); tmp = fold_build2 (MODIFY_EXPR, void_type_node, pointer, tmp); @@ -3822,7 +3822,7 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) /*GCC ARRAYS*/ tree -gfc_array_deallocate (tree descriptor, tree pstat) +gfc_array_deallocate (tree descriptor, tree pstat, gfc_expr* expr) { tree var; tree tmp; @@ -3834,7 +3834,7 @@ gfc_array_deallocate (tree descriptor, tree pstat) STRIP_NOPS (var); /* Parameter is the address of the data component. */ - tmp = gfc_deallocate_with_status (var, pstat, false); + tmp = gfc_deallocate_with_status (var, pstat, false, expr); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ @@ -5341,7 +5341,7 @@ gfc_trans_dealloc_allocated (tree descriptor) /* Call array_deallocate with an int * present in the second argument. Although it is ignored here, it's presence ensures that arrays that are already deallocated are ignored. */ - tmp = gfc_deallocate_with_status (var, NULL_TREE, true); + tmp = gfc_deallocate_with_status (var, NULL_TREE, true, NULL); gfc_add_expr_to_block (&block, tmp); /* Zero the data pointer. */ diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 18de51c..2cc9d5c 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -20,7 +20,7 @@ along with GCC; see the file COPYING3. If not see . */ /* Generate code to free an array. */ -tree gfc_array_deallocate (tree, tree); +tree gfc_array_deallocate (tree, tree, gfc_expr*); /* Generate code to initialize an allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 11a1f40..04ec4d4 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -163,7 +163,7 @@ gfc_omp_clause_default_ctor (tree clause, tree decl, tree outer) size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); ptr = gfc_allocate_array_with_status (&cond_block, build_int_cst (pvoid_type_node, 0), - size, NULL); + size, NULL, NULL); gfc_conv_descriptor_data_set (&cond_block, decl, ptr); then_b = gfc_finish_block (&cond_block); @@ -215,7 +215,7 @@ gfc_omp_clause_copy_ctor (tree clause, tree dest, tree src) size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); ptr = gfc_allocate_array_with_status (&block, build_int_cst (pvoid_type_node, 0), - size, NULL); + size, NULL, NULL); gfc_conv_descriptor_data_set (&block, dest, ptr); call = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3, ptr, fold_convert (pvoid_type_node, @@ -619,7 +619,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where) size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); ptr = gfc_allocate_array_with_status (&block, build_int_cst (pvoid_type_node, 0), - size, NULL); + size, NULL, NULL); gfc_conv_descriptor_data_set (&block, decl, ptr); gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false)); stmt = gfc_finish_block (&block); diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 26ea70c..da22752 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -4005,16 +4005,16 @@ gfc_trans_deallocate (gfc_code * code) && !(!last && expr->symtree->n.sym->attr.pointer)) { tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr, - expr->rank); + expr->rank); gfc_add_expr_to_block (&se.pre, tmp); } } if (expr->rank) - tmp = gfc_array_deallocate (se.expr, pstat); + tmp = gfc_array_deallocate (se.expr, pstat, expr); else { - tmp = gfc_deallocate_with_status (se.expr, pstat, false); + tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr); gfc_add_expr_to_block (&se.pre, tmp); tmp = fold_build2 (MODIFY_EXPR, void_type_node, diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 1b115f4..b8f0d2d 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -347,17 +347,24 @@ gfc_build_array_ref (tree base, tree offset, tree decl) } -/* Generate a runtime error if COND is true. */ +/* Generate a call to print a runtime error possibly including multiple + arguments and a locus. */ -void -gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, - locus * where, const char * msgid, ...) +tree +gfc_trans_runtime_error (bool error, locus* where, const char* msgid, ...) { va_list ap; + + va_start (ap, msgid); + return gfc_trans_runtime_error_vararg (error, where, msgid, ap); +} + +tree +gfc_trans_runtime_error_vararg (bool error, locus* where, const char* msgid, + va_list ap) +{ stmtblock_t block; - tree body; tree tmp; - tree tmpvar = NULL; tree arg, arg2; tree *argarray; tree fntype; @@ -365,9 +372,6 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, const char *p; int line, nargs, i; - if (integer_zerop (cond)) - return; - /* Compute the number of extra arguments from the format string. */ for (p = msgid, nargs = 0; *p; p++) if (*p == '%') @@ -377,14 +381,6 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, nargs++; } - if (once) - { - tmpvar = gfc_create_var (boolean_type_node, "print_warning"); - TREE_STATIC (tmpvar) = 1; - DECL_INITIAL (tmpvar) = boolean_true_node; - gfc_add_expr_to_block (pblock, tmpvar); - } - /* The code to generate the error. */ gfc_start_block (&block); @@ -411,9 +407,8 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, argarray = (tree *) alloca (sizeof (tree) * (nargs + 2)); argarray[0] = arg; argarray[1] = arg2; - va_start (ap, msgid); for (i = 0; i < nargs; i++) - argarray[2+i] = va_arg (ap, tree); + argarray[2 + i] = va_arg (ap, tree); va_end (ap); /* Build the function call to runtime_(warning,error)_at; because of the @@ -432,6 +427,41 @@ gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, nargs + 2, argarray); gfc_add_expr_to_block (&block, tmp); + return gfc_finish_block (&block); +} + + +/* Generate a runtime error if COND is true. */ + +void +gfc_trans_runtime_check (bool error, bool once, tree cond, stmtblock_t * pblock, + locus * where, const char * msgid, ...) +{ + va_list ap; + stmtblock_t block; + tree body; + tree tmp; + tree tmpvar = NULL; + + if (integer_zerop (cond)) + return; + + if (once) + { + tmpvar = gfc_create_var (boolean_type_node, "print_warning"); + TREE_STATIC (tmpvar) = 1; + DECL_INITIAL (tmpvar) = boolean_true_node; + gfc_add_expr_to_block (pblock, tmpvar); + } + + gfc_start_block (&block); + + /* The code to generate the error. */ + va_start (ap, msgid); + gfc_add_expr_to_block (&block, + gfc_trans_runtime_error_vararg (error, where, + msgid, ap)); + if (once) gfc_add_modify (&block, tmpvar, boolean_false_node); @@ -524,30 +554,30 @@ gfc_call_malloc (stmtblock_t * block, tree type, tree size) void *newmem; if (stat) - *stat = 0; + *stat = 0; // The only time this can happen is the size wraps around. if (size < 0) { - if (stat) - { - *stat = LIBERROR_ALLOCATION; - newmem = NULL; - } - else - runtime_error ("Attempt to allocate negative amount of memory. " - "Possible integer overflow"); + if (stat) + { + *stat = LIBERROR_ALLOCATION; + newmem = NULL; + } + else + runtime_error ("Attempt to allocate negative amount of memory. " + "Possible integer overflow"); } else { - newmem = malloc (MAX (size, 1)); - if (newmem == NULL) - { - if (stat) - *stat = LIBERROR_ALLOCATION; - else - runtime_error ("Out of memory"); - } + newmem = malloc (MAX (size, 1)); + if (newmem == NULL) + { + if (stat) + *stat = LIBERROR_ALLOCATION; + else + runtime_error ("Out of memory"); + } } return newmem; @@ -668,13 +698,16 @@ gfc_allocate_with_status (stmtblock_t * block, tree size, tree status) } else runtime_error ("Attempting to allocate already allocated array"); - } */ + } + + expr must be set to the original expression being allocated for its locus + and variable name in case a runtime error has to be printed. */ tree gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size, - tree status) + tree status, gfc_expr* expr) { stmtblock_t alloc_block; - tree res, tmp, null_mem, alloc, error, msg; + tree res, tmp, null_mem, alloc, error; tree type = TREE_TYPE (mem); if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) @@ -692,9 +725,23 @@ gfc_allocate_array_with_status (stmtblock_t * block, tree mem, tree size, alloc = gfc_finish_block (&alloc_block); /* Otherwise, we issue a runtime error or set the status variable. */ - msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const - ("Attempting to allocate already allocated array")); - error = build_call_expr (gfor_fndecl_runtime_error, 1, msg); + if (expr) + { + tree varname; + + gcc_assert (expr->expr_type == EXPR_VARIABLE && expr->symtree); + varname = gfc_build_cstring_const (expr->symtree->name); + varname = gfc_build_addr_expr (pchar_type_node, varname); + + error = gfc_trans_runtime_error (true, &expr->where, + "Attempting to allocate already" + " allocated array '%s'", + varname); + } + else + error = gfc_trans_runtime_error (true, NULL, + "Attempting to allocate already allocated" + "array"); if (status != NULL_TREE && !integer_zerop (status)) { @@ -775,12 +822,16 @@ gfc_call_free (tree var) Moreover, if CAN_FAIL is true, then we will not emit a runtime error, even when no status variable is passed to us (this is used for unconditional deallocation generated by the front-end at end of - each procedure). */ + each procedure). + + If a runtime-message is possible, `expr' must point to the original + expression being deallocated for its locus and variable name. */ tree -gfc_deallocate_with_status (tree pointer, tree status, bool can_fail) +gfc_deallocate_with_status (tree pointer, tree status, bool can_fail, + gfc_expr* expr) { stmtblock_t null, non_null; - tree cond, tmp, error, msg; + tree cond, tmp, error; cond = fold_build2 (EQ_EXPR, boolean_type_node, pointer, build_int_cst (TREE_TYPE (pointer), 0)); @@ -790,10 +841,16 @@ gfc_deallocate_with_status (tree pointer, tree status, bool can_fail) gfc_start_block (&null); if (!can_fail) { - msg = gfc_build_addr_expr (pchar_type_node, - gfc_build_localized_cstring_const - ("Attempt to DEALLOCATE unallocated memory.")); - error = build_call_expr (gfor_fndecl_runtime_error, 1, msg); + tree varname; + + gcc_assert (expr && expr->expr_type == EXPR_VARIABLE && expr->symtree); + + varname = gfc_build_cstring_const (expr->symtree->name); + varname = gfc_build_addr_expr (pchar_type_node, varname); + + error = gfc_trans_runtime_error (true, &expr->where, + "Attempt to DEALLOCATE unallocated '%s'", + varname); } else error = build_empty_stmt (); diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 5d729ea..36553ea 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -450,6 +450,10 @@ void gfc_generate_constructors (void); /* Get the string length of an array constructor. */ bool get_array_ctor_strlen (stmtblock_t *, gfc_constructor *, tree *); +/* Generate a runtime error call. */ +tree gfc_trans_runtime_error (bool, locus*, const char*, ...); +tree gfc_trans_runtime_error_vararg (bool, locus*, const char*, va_list); + /* Generate a runtime warning/error check. */ void gfc_trans_runtime_check (bool, bool, tree, stmtblock_t *, locus *, const char *, ...); @@ -461,13 +465,13 @@ tree gfc_call_free (tree); tree gfc_call_malloc (stmtblock_t *, tree, tree); /* Allocate memory for arrays, with optional status variable. */ -tree gfc_allocate_array_with_status (stmtblock_t *, tree, tree, tree); +tree gfc_allocate_array_with_status (stmtblock_t*, tree, tree, tree, gfc_expr*); /* Allocate memory, with optional status variable. */ tree gfc_allocate_with_status (stmtblock_t *, tree, tree); /* Generate code to deallocate an array. */ -tree gfc_deallocate_with_status (tree, tree, bool); +tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*); /* Generate code to call realloc(). */ tree gfc_call_realloc (stmtblock_t *, tree, tree); diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index cebd673..e905405 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2008-09-18 Daniel Kraft + + PR fortran/37507 + * gfortran.dg/allocate_error_1.f90: New test. + * gfortran.dg/deallocate_error_1.f90: New test. + * gfortran.dg/deallocate_error_2.f90: New test. + 2008-09-18 Richard Guenther PR tree-optimization/37456 diff --git a/gcc/testsuite/gfortran.dg/allocate_error_1.f90 b/gcc/testsuite/gfortran.dg/allocate_error_1.f90 new file mode 100644 index 0000000..42a1215 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_error_1.f90 @@ -0,0 +1,14 @@ +! { dg-do run } +! { dg-shouldfail "runtime error" } +! { dg-output "At line 13.*Attempting to allocate .* 'arr'" } + +! PR fortran/37507 +! Check that locus is printed for ALLOCATE errors. + +PROGRAM main + IMPLICIT NONE + INTEGER, ALLOCATABLE :: arr(:) + + ALLOCATE (arr(5)) + ALLOCATE (arr(6)) +END PROGRAM main diff --git a/gcc/testsuite/gfortran.dg/deallocate_error_1.f90 b/gcc/testsuite/gfortran.dg/deallocate_error_1.f90 new file mode 100644 index 0000000..98ffdb3 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deallocate_error_1.f90 @@ -0,0 +1,15 @@ +! { dg-do run } +! { dg-shouldfail "runtime error" } +! { dg-output "At line 14.*Attempt to DEALLOCATE unallocated 'arr'" } + +! PR fortran/37507 +! Check that locus is printed for DEALLOCATE errors. + +PROGRAM main + IMPLICIT NONE + INTEGER, ALLOCATABLE :: arr(:) + + ALLOCATE (arr(5)) + DEALLOCATE (arr) + DEALLOCATE (arr) +END PROGRAM main diff --git a/gcc/testsuite/gfortran.dg/deallocate_error_2.f90 b/gcc/testsuite/gfortran.dg/deallocate_error_2.f90 new file mode 100644 index 0000000..bda1adf --- /dev/null +++ b/gcc/testsuite/gfortran.dg/deallocate_error_2.f90 @@ -0,0 +1,16 @@ +! { dg-do run } +! { dg-shouldfail "runtime error" } +! { dg-output "At line 15.*Attempt to DEALLOCATE unallocated 'ptr'" } + +! PR fortran/37507 +! Check that locus is printed for DEALLOCATE errors. + +PROGRAM main + IMPLICIT NONE + INTEGER, POINTER :: ptr + INTEGER, ALLOCATABLE :: arr(:) + + ALLOCATE (ptr, arr(5)) + DEALLOCATE (ptr) + DEALLOCATE (arr, ptr) +END PROGRAM main