From patchwork Thu Jul 21 15:20:11 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Carrera X-Patchwork-Id: 106083 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 9735DB6F75 for ; Fri, 22 Jul 2011 01:20:39 +1000 (EST) Received: (qmail 4287 invoked by alias); 21 Jul 2011 15:20:38 -0000 Received: (qmail 4269 invoked by uid 22791); 21 Jul 2011 15:20:34 -0000 X-SWARE-Spam-Status: No, hits=-2.5 required=5.0 tests=AWL, BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, TW_TM X-Spam-Check-By: sourceware.org Received: from mail-ey0-f182.google.com (HELO mail-ey0-f182.google.com) (209.85.215.182) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Thu, 21 Jul 2011 15:20:17 +0000 Received: by eyg7 with SMTP id 7so2038444eyg.13 for ; Thu, 21 Jul 2011 08:20:15 -0700 (PDT) Received: by 10.14.8.211 with SMTP id 59mr189201eer.92.1311261615247; Thu, 21 Jul 2011 08:20:15 -0700 (PDT) Received: from [130.235.236.18] (ip236-18.wireless.lu.se [130.235.236.18]) by mx.google.com with ESMTPS id a8sm1191227een.47.2011.07.21.08.20.11 (version=SSLv3 cipher=OTHER); Thu, 21 Jul 2011 08:20:12 -0700 (PDT) Message-ID: <4E2843AB.2090107@gmail.com> Date: Thu, 21 Jul 2011 17:20:11 +0200 From: Daniel Carrera User-Agent: Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.9.2.18) Gecko/20110617 Thunderbird/3.1.11 MIME-Version: 1.0 To: Tobias Burnus CC: gcc patches , gfortran Subject: Re: [Patches, Fortran] ALLOCATE & CAF library. References: <4E280903.4060600@gmail.com> <4E283560.8070701@net-b.de> In-Reply-To: <4E283560.8070701@net-b.de> Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org On 07/21/2011 04:19 PM, Tobias Burnus wrote: > On 07/21/2011 01:09 PM, Daniel Carrera wrote: >> This patch now fixes an existing bug in GFortran whereby the ALLOCATE >> statement only gets error checking if you are allocating a scalar. > > Somehow that does not seem to work. I just tried a vanilla trunk with > just your patch applied. For the following, I do not get a single > "goto". That's different to your dumps, where you get two (though, in > your case, you had a scalar and a scalar coarray). > > integer, allocatable :: A(:), B[:] > integer :: stat > character(len=33) :: str > allocate(A(1), B[*], stat=stat)!, errmsg=str) > end > > Thus, I wonder whether you have send the correct patch, if not, the > question is really why we see those large differences. From what you posted, it looks like I sent the wrong patch. I generated the patch again with a different name just to make sure I'm not mixing it up (attached). I tried you code sample and for me it works perfectly: daniel ~/GCC % cat test2.f90 program test integer, allocatable :: A(:), B[:] integer :: stat character(len=33) :: str allocate(A(1), B[*], stat=stat) end program daniel ~/GCC % mpif90 -fcoarray=lib -fdump-tree-original test2.f90 mpi.o The result is attached. You'll find that the gotos are there, just as they should be: a.data = 0B; b.data = 0B; { .... if ((logical(kind=4)) __builtin_expect (overflow.1 != 0, 0)) { stat.0 = 5014; } else { { ... a.data = D.1539; } } a.offset = -1; if (stat.0 != 0) goto L.1; ... } b.data = D.1542; } if (stat.0 != 0) goto L.2; L.1:; L.2:; stat = stat.0; > That also fits with the code: > - if (!gfc_array_allocate (&se, expr, pstat)) > + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen)) > { > ... > if (code->expr1 || code->expr2) > { > - tmp = build1_v (GOTO_EXPR, error_label); > + /* The coarray library already sets the errmsg. */ > + if (gfc_option.coarray == GFC_FCOARRAY_LIB > + && gfc_expr_attr (expr).codimension) > + tmp = build1_v (GOTO_EXPR, label_finish); > + else > + tmp = build1_v (GOTO_EXPR, label_errmsg); > ... > } > > Where the code is still in the scalar-allocation loop. That's clearly I wrong... I guess I did send the wrong patch. > Can you change the "if ()" into "if(code->expr1)", i.e. only checking > whether STAT= is present? There is no point of generating code for > ERRMSG= if STAT= is not present. Ok. The attached patch includes that change (technically I haven't tested it, but I'll test before committing). >> + /* ERRMSG= */ >> + errmsg = null_pointer_node; >> + errlen = build_int_cst (gfc_charlen_type_node, 0); >> + if (code->expr2) >> + { >> + gfc_init_se (&se, NULL); >> + gfc_conv_expr_lhs (&se, code->expr2); >> + >> + errlen = gfc_get_expr_charlen (code->expr2); >> + errmsg = gfc_build_addr_expr (pchar_type_node, se.expr); >> + } > > As said in previous review: Use: > else > { > > errmsg = null_pointer_node; > errlen = build_int_cst (gfc_charlen_type_node, 0); > > } > > > That avoids evaluating uselessly build_int_cst, which is cheap but > changing the code comes for free. Fixed. Included in the attached patch. Will test before committing. >> - /* STAT block. */ >> - if (code->expr1) >> + /* STAT or ERRMSG. */ >> + if (code->expr1 || code->expr2) > > I believe here applies the same: The code will be unreachable if there > is no STAT=. > >> + /* STAT or ERRMSG. */ >> + if (code->expr1 || code->expr2) > Ditto. Fixed. I also changed the comments to remind ourselves later why we don't check for ERRMSG. Cheers, Daniel. Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (revision 176528) +++ gcc/fortran/trans-array.c (working copy) @@ -4384,3 +4384,4 @@ gfc_array_init_size (tree descriptor, in bool -gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) +gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, + tree errlen) { @@ -4479,18 +4480,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp - if (pstat != NULL_TREE && !integer_zerop (pstat)) - { - /* Set the status variable if it's present. */ + if (status != NULL_TREE) + { + tree status_type = TREE_TYPE (status); stmtblock_t set_status_block; - tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE; gfc_start_block (&set_status_block); - gfc_add_modify (&set_status_block, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, pstat), - build_int_cst (status_type, LIBERROR_ALLOCATION)); - - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - pstat, build_int_cst (TREE_TYPE (pstat), 0)); - error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, - error, gfc_finish_block (&set_status_block)); + gfc_add_modify (&set_status_block, status, + build_int_cst (status_type, LIBERROR_ALLOCATION)); + error = gfc_finish_block (&set_status_block); } @@ -4503,10 +4497,11 @@ gfc_array_allocate (gfc_se * se, gfc_exp - /* The allocate_array variants take the old pointer as first argument. */ + /* The allocatable variant takes the old pointer as first argument. */ if (allocatable) - tmp = gfc_allocate_allocatable_with_status (&elseblock, - pointer, size, pstat, expr); + tmp = gfc_allocate_allocatable (&elseblock, pointer, size, + status, errmsg, errlen, expr); else - tmp = gfc_allocate_with_status (&elseblock, size, pstat, false); - tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer, - tmp); + tmp = gfc_allocate_using_malloc (&elseblock, size, status); + + tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, + pointer, tmp); Index: gcc/fortran/trans-array.h =================================================================== --- gcc/fortran/trans-array.h (revision 176528) +++ gcc/fortran/trans-array.h (working copy) @@ -26,3 +26,3 @@ tree gfc_array_deallocate (tree, tree, g se, which should contain an expression for the array descriptor. */ -bool gfc_array_allocate (gfc_se *, gfc_expr *, tree); +bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree); Index: gcc/fortran/trans-openmp.c =================================================================== --- gcc/fortran/trans-openmp.c (revision 176528) +++ gcc/fortran/trans-openmp.c (working copy) @@ -190,5 +190,5 @@ gfc_omp_clause_default_ctor (tree clause size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block); - ptr = gfc_allocate_allocatable_with_status (&cond_block, - build_int_cst (pvoid_type_node, 0), - size, NULL, NULL); + ptr = gfc_allocate_allocatable (&cond_block, + build_int_cst (pvoid_type_node, 0), + size, NULL_TREE, NULL_TREE, NULL_TREE, NULL); gfc_conv_descriptor_data_set (&cond_block, decl, ptr); @@ -243,5 +243,5 @@ gfc_omp_clause_copy_ctor (tree clause, t size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); - ptr = gfc_allocate_allocatable_with_status (&block, - build_int_cst (pvoid_type_node, 0), - size, NULL, NULL); + ptr = gfc_allocate_allocatable (&block, + build_int_cst (pvoid_type_node, 0), + size, NULL_TREE, NULL_TREE, NULL_TREE, NULL); gfc_conv_descriptor_data_set (&block, dest, ptr); @@ -665,5 +665,5 @@ gfc_trans_omp_array_reduction (tree c, g size = gfc_evaluate_now (fold_convert (size_type_node, size), &block); - ptr = gfc_allocate_allocatable_with_status (&block, - build_int_cst (pvoid_type_node, 0), - size, NULL, NULL); + ptr = gfc_allocate_allocatable (&block, + build_int_cst (pvoid_type_node, 0), + size, NULL_TREE, NULL_TREE, NULL_TREE, NULL); gfc_conv_descriptor_data_set (&block, decl, ptr); Index: gcc/fortran/trans-stmt.c =================================================================== --- gcc/fortran/trans-stmt.c (revision 176528) +++ gcc/fortran/trans-stmt.c (working copy) @@ -4688,4 +4688,6 @@ gfc_trans_allocate (gfc_code * code) tree stat; - tree pstat; - tree error_label; + tree errmsg; + tree errlen; + tree label_errmsg; + tree label_finish; tree memsz; @@ -4701,3 +4703,4 @@ gfc_trans_allocate (gfc_code * code) - pstat = stat = error_label = tmp = memsz = NULL_TREE; + stat = tmp = memsz = NULL_TREE; + label_errmsg = label_finish = errmsg = errlen = NULL_TREE; @@ -4709,9 +4712,23 @@ gfc_trans_allocate (gfc_code * code) { + /* STAT= */ tree gfc_int4_type_node = gfc_get_int_type (4); - stat = gfc_create_var (gfc_int4_type_node, "stat"); - pstat = gfc_build_addr_expr (NULL_TREE, stat); - - error_label = gfc_build_label_decl (NULL_TREE); - TREE_USED (error_label) = 1; + + /* ERRMSG= */ + errmsg = null_pointer_node; + errlen = build_int_cst (gfc_charlen_type_node, 0); + if (code->expr2) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr2); + + errlen = gfc_get_expr_charlen (code->expr2); + errmsg = gfc_build_addr_expr (pchar_type_node, se.expr); + } + + /* GOTO destinations. */ + label_errmsg = gfc_build_label_decl (NULL_TREE); + label_finish = gfc_build_label_decl (NULL_TREE); + TREE_USED (label_errmsg) = 1; + TREE_USED (label_finish) = 1; } @@ -4734,3 +4751,3 @@ gfc_trans_allocate (gfc_code * code) - if (!gfc_array_allocate (&se, expr, pstat)) + if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen)) { @@ -4849,6 +4866,6 @@ gfc_trans_allocate (gfc_code * code) if (gfc_expr_attr (expr).allocatable) - tmp = gfc_allocate_allocatable_with_status (&se.pre, se.expr, memsz, - pstat, expr); + tmp = gfc_allocate_allocatable (&se.pre, se.expr, memsz, + stat, errmsg, errlen, expr); else - tmp = gfc_allocate_with_status (&se.pre, memsz, pstat, false); + tmp = gfc_allocate_using_malloc (&se.pre, memsz, stat); @@ -4861,3 +4878,9 @@ gfc_trans_allocate (gfc_code * code) { - tmp = build1_v (GOTO_EXPR, error_label); + /* The coarray library already sets the errmsg. */ + if (gfc_option.coarray == GFC_FCOARRAY_LIB + && gfc_expr_attr (expr).codimension) + tmp = build1_v (GOTO_EXPR, label_finish); + else + tmp = build1_v (GOTO_EXPR, label_errmsg); + parm = fold_build2_loc (input_location, NE_EXPR, @@ -5007,12 +5030,7 @@ gfc_trans_allocate (gfc_code * code) - /* STAT block. */ - if (code->expr1) + /* STAT or ERRMSG. */ + if (code->expr1 || code->expr2) { - tmp = build1_v (LABEL_EXPR, error_label); + tmp = build1_v (LABEL_EXPR, label_errmsg); gfc_add_expr_to_block (&block, tmp); - - gfc_init_se (&se, NULL); - gfc_conv_expr_lhs (&se, code->expr1); - tmp = convert (TREE_TYPE (se.expr), stat); - gfc_add_modify (&block, se.expr, tmp); } @@ -5024,3 +5042,3 @@ gfc_trans_allocate (gfc_code * code) const char *msg = "Attempt to allocate an allocated object"; - tree errmsg, slen, dlen; + tree slen, dlen; @@ -5052,2 +5070,18 @@ gfc_trans_allocate (gfc_code * code) + /* STAT or ERRMSG. */ + if (code->expr1 || code->expr2) + { + tmp = build1_v (LABEL_EXPR, label_finish); + gfc_add_expr_to_block (&block, tmp); + } + + /* STAT block. */ + if (code->expr1) + { + gfc_init_se (&se, NULL); + gfc_conv_expr_lhs (&se, code->expr1); + tmp = convert (TREE_TYPE (se.expr), stat); + gfc_add_modify (&block, se.expr, tmp); + } + gfc_add_block_to_block (&block, &se.post); Index: gcc/fortran/trans.c =================================================================== --- gcc/fortran/trans.c (revision 176528) +++ gcc/fortran/trans.c (working copy) @@ -567,3 +567,3 @@ gfc_call_malloc (stmtblock_t * block, tr void * - allocate (size_t size, integer_type* stat) + allocate (size_t size, integer_type stat) { @@ -571,4 +571,4 @@ gfc_call_malloc (stmtblock_t * block, tr - if (stat) - *stat = 0; + if (stat requested) + stat = 0; @@ -585,8 +585,7 @@ gfc_call_malloc (stmtblock_t * block, tr tree -gfc_allocate_with_status (stmtblock_t * block, tree size, tree status, - bool coarray_lib) +gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status) { stmtblock_t alloc_block; - tree res, tmp, msg, cond; - tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE; + tree res, tmp, on_error; + tree status_type = status ? TREE_TYPE (status) : NULL_TREE; @@ -601,15 +600,6 @@ gfc_allocate_with_status (stmtblock_t * /* Set the optional status variable to zero. */ - if (status != NULL_TREE && !integer_zerop (status)) - { - tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, 0)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, - fold_build2_loc (input_location, NE_EXPR, - boolean_type_node, status, - build_int_cst (TREE_TYPE (status), 0)), - tmp, build_empty_stmt (input_location)); - gfc_add_expr_to_block (block, tmp); - } + if (status != NULL_TREE) + gfc_add_expr_to_block (block, + fold_build2_loc (input_location, MODIFY_EXPR, status_type, + status, build_int_cst (status_type, 0))); @@ -617,48 +607,19 @@ gfc_allocate_with_status (stmtblock_t * gfc_start_block (&alloc_block); - if (coarray_lib) - { - gfc_add_modify (&alloc_block, res, - fold_convert (prvoid_type_node, - build_call_expr_loc (input_location, - gfor_fndecl_caf_register, 6, - fold_build2_loc (input_location, - MAX_EXPR, size_type_node, size, - build_int_cst (size_type_node, 1)), - build_int_cst (integer_type_node, - GFC_CAF_COARRAY_ALLOC), - null_pointer_node, /* token */ - null_pointer_node, /* stat */ - null_pointer_node, /* errmsg, errmsg_len */ - build_int_cst (integer_type_node, 0)))); - } + gfc_add_modify (&alloc_block, res, + fold_convert (prvoid_type_node, + build_call_expr_loc (input_location, + built_in_decls[BUILT_IN_MALLOC], 1, + fold_build2_loc (input_location, + MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, 1))))); + + /* What to do in case of error. */ + if (status != NULL_TREE) + on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type, + status, build_int_cst (status_type, LIBERROR_ALLOCATION)); else - { - gfc_add_modify (&alloc_block, res, - fold_convert (prvoid_type_node, - build_call_expr_loc (input_location, - built_in_decls[BUILT_IN_MALLOC], 1, - fold_build2_loc (input_location, - MAX_EXPR, size_type_node, size, - build_int_cst (size_type_node, 1))))); - } - - msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const - ("Allocation would exceed memory limit")); - tmp = build_call_expr_loc (input_location, - gfor_fndecl_os_error, 1, msg); - - if (status != NULL_TREE && !integer_zerop (status)) - { - /* Set the status variable if it's present. */ - tree tmp2; - - cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - status, build_int_cst (TREE_TYPE (status), 0)); - tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, LIBERROR_ALLOCATION)); - tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, - tmp, tmp2); - } + on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1, + gfc_build_addr_expr (pchar_type_node, + gfc_build_localized_cstring_const + ("Allocation would exceed memory limit"))); @@ -668,3 +629,4 @@ gfc_allocate_with_status (stmtblock_t * build_int_cst (prvoid_type_node, 0)), - tmp, build_empty_stmt (input_location)); + on_error, build_empty_stmt (input_location)); + gfc_add_expr_to_block (&alloc_block, tmp); @@ -676,2 +638,72 @@ gfc_allocate_with_status (stmtblock_t * +/* Allocate memory, using an optional status argument. + + This function follows the following pseudo-code: + + void * + allocate (size_t size, integer_type stat) + { + void *newmem; + + if (stat requested) + stat = 0; + + newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL); + if (newmem == NULL) + { + if (!stat requested) + runtime_error ("Allocation would exceed memory limit"); + } + return newmem; + } */ +tree +gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status, + tree errmsg, tree errlen) +{ + tree res, pstat; + tree status_type = status ? TREE_TYPE (status) : NULL_TREE; + + /* Evaluate size only once, and make sure it has the right type. */ + size = gfc_evaluate_now (size, block); + if (TREE_TYPE (size) != TREE_TYPE (size_type_node)) + size = fold_convert (size_type_node, size); + + /* Create a variable to hold the result. */ + res = gfc_create_var (prvoid_type_node, NULL); + + /* Set the optional status variable to zero. */ + if (status != NULL_TREE) + gfc_add_expr_to_block (block, + fold_build2_loc (input_location, MODIFY_EXPR, status_type, + status, build_int_cst (status_type, 0))); + + /* The allocation itself. */ + if (status == NULL_TREE) + pstat = null_pointer_node; + else + pstat = gfc_build_addr_expr (NULL_TREE, status); + + if (errmsg == NULL_TREE) + { + gcc_assert(errlen == NULL_TREE); + errmsg = null_pointer_node; + errlen = build_int_cst (integer_type_node, 0); + } + + gfc_add_modify (block, res, + fold_convert (prvoid_type_node, + build_call_expr_loc (input_location, + gfor_fndecl_caf_register, 6, + fold_build2_loc (input_location, + MAX_EXPR, size_type_node, size, + build_int_cst (size_type_node, 1)), + build_int_cst (integer_type_node, + GFC_CAF_COARRAY_ALLOC), + null_pointer_node, /* token */ + pstat, errmsg, errlen))); + + return res; +} + + /* Generate code for an ALLOCATE statement when the argument is an @@ -683,3 +715,3 @@ gfc_allocate_with_status (stmtblock_t * void * - allocate_allocatable (void *mem, size_t size, integer_type *stat) + allocate_allocatable (void *mem, size_t size, integer_type stat) { @@ -693,3 +725,3 @@ gfc_allocate_with_status (stmtblock_t * mem = allocate (size, stat); - *stat = LIBERROR_ALLOCATION; + stat = LIBERROR_ALLOCATION; return mem; @@ -704,4 +736,4 @@ gfc_allocate_with_status (stmtblock_t * tree -gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size, - tree status, gfc_expr* expr) +gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status, + tree errmsg, tree errlen, gfc_expr* expr) { @@ -720,7 +752,12 @@ gfc_allocate_allocatable_with_status (st - /* If mem is NULL, we call gfc_allocate_with_status. */ + /* If mem is NULL, we call gfc_allocate_using_malloc or + gfc_allocate_using_lib. */ gfc_start_block (&alloc_block); - tmp = gfc_allocate_with_status (&alloc_block, size, status, - gfc_option.coarray == GFC_FCOARRAY_LIB - && gfc_expr_attr (expr).codimension); + + if (gfc_option.coarray == GFC_FCOARRAY_LIB + && gfc_expr_attr (expr).codimension) + tmp = gfc_allocate_using_lib (&alloc_block, size, status, + errmsg, errlen); + else + tmp = gfc_allocate_using_malloc (&alloc_block, size, status); @@ -749,5 +786,5 @@ gfc_allocate_allocatable_with_status (st - if (status != NULL_TREE && !integer_zerop (status)) + if (status != NULL_TREE) { - tree status_type = TREE_TYPE (TREE_TYPE (status)); + tree status_type = TREE_TYPE (status); stmtblock_t set_status_block; @@ -760,14 +797,8 @@ gfc_allocate_allocatable_with_status (st - tmp = gfc_allocate_with_status (&set_status_block, size, status, false); + tmp = gfc_allocate_using_malloc (&set_status_block, size, status); gfc_add_modify (&set_status_block, res, fold_convert (type, tmp)); - gfc_add_modify (&set_status_block, - fold_build1_loc (input_location, INDIRECT_REF, - status_type, status), - build_int_cst (status_type, LIBERROR_ALLOCATION)); - - tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, - status, build_int_cst (status_type, 0)); - error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp, - error, gfc_finish_block (&set_status_block)); + gfc_add_modify (&set_status_block, status, + build_int_cst (status_type, LIBERROR_ALLOCATION)); + error = gfc_finish_block (&set_status_block); } Index: gcc/fortran/trans.h =================================================================== --- gcc/fortran/trans.h (revision 176528) +++ gcc/fortran/trans.h (working copy) @@ -543,7 +543,8 @@ tree gfc_build_memcpy_call (tree, tree, /* Allocate memory for allocatable variables, with optional status variable. */ -tree gfc_allocate_allocatable_with_status (stmtblock_t*, - tree, tree, tree, gfc_expr*); +tree gfc_allocate_allocatable (stmtblock_t*, tree, tree, + tree, tree, tree, gfc_expr*); /* Allocate memory, with optional status variable. */ -tree gfc_allocate_with_status (stmtblock_t *, tree, tree, bool); +tree gfc_allocate_using_malloc (stmtblock_t *, tree, tree); +tree gfc_allocate_using_lib (stmtblock_t *, tree, tree, tree, tree);