From patchwork Mon Jan 19 05:10:24 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry DeLisle X-Patchwork-Id: 430295 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 0DA951402AD for ; Mon, 19 Jan 2015 16:10:52 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; q= dns; s=default; b=Xrq9odqo/8exhJH2zNtE8IJK/WAdIaJ0t7TwlhAO0ddgjV aIB2UNr2MuvAA13/5qVm/3Poj9/PbZxf5uX6ahqHWUapf494entqpQpeWgOmzp1J YLdwi5ToI04H3K+0o+Ri43ratU1cQ+r9IcnXuAF6sB7advLqwqoxqTqFKuVaU= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :message-id:date:from:mime-version:to:subject:content-type; s= default; bh=RC1Stv1Tqvo5+EB3Zxykk/NZNCk=; b=ORaEhz5/fWRxaoB0msvx 2lJTa7s6t2UIWD9WGhLUipPMmbHPH+YjeM7n38xrmB1vg2Y1ooLNgzBg0MG1TMTM /ojNE/YrqG54pP1nxh4rnCDh9kgUcnDp8XQxDj/VMJWP7ZHIhfAjWLS3nx08z90W HBeuN6t5vXgo1wnA7QiDDQw= Received: (qmail 7871 invoked by alias); 19 Jan 2015 05:10:42 -0000 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 Received: (qmail 7831 invoked by uid 89); 19 Jan 2015 05:10:36 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=BAYES_00, RCVD_IN_DNSWL_NONE, SPF_PASS, T_RP_MATCHES_RCVD autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mta21.charter.net Received: from mta21.charter.net (HELO mta21.charter.net) (216.33.127.81) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Mon, 19 Jan 2015 05:10:28 +0000 Received: from imp09 ([10.20.200.9]) by mta21.charter.net (InterMail vM.8.01.05.09 201-2260-151-124-20120717) with ESMTP id <20150119051026.ZIOH23400.mta21.charter.net@imp09>; Mon, 19 Jan 2015 00:10:26 -0500 Received: from mtaout006.msg.strl.va.charter.net ([68.114.190.31]) by imp09 with smtp.charter.net id hhAS1p0020h5dSU05hASza; Mon, 19 Jan 2015 00:10:26 -0500 Received: from impout003 ([68.114.189.18]) by mtaout006.msg.strl.va.charter.net (InterMail vM.9.00.015.01 201-2473-143-101) with ESMTP id <20150119051026.YFNB1734.mtaout006.msg.strl.va.charter.net@impout003>; Sun, 18 Jan 2015 23:10:26 -0600 Received: from pavi.localdomain ([70.209.228.9]) by impout003 with charter.net id hhAR1p00C0CoUY601hASbA; Sun, 18 Jan 2015 23:10:26 -0600 X-Authority-Analysis: v=2.1 cv=KojD2AmN c=1 sm=1 tr=0 a=2x52SpHRWNI6c/PvzbiH+g==:117 a=2x52SpHRWNI6c/PvzbiH+g==:17 a=hOpmn2quAAAA:8 a=DrNGYBpgUcYA:10 a=r77TgQKjGQsHNAKrUKIA:9 a=9iDbn-4jx3cA:10 a=cKsnjEOsciEA:10 a=gZbpxnkM3yUA:10 a=mDV3o1hIAAAA:8 a=2pfUFJHvJbrmENf0aAQA:9 a=6t2YzM-guZnTN2Hp:21 a=zGdA4zX1KrQpwvlQ:21 a=QEXdDO2ut3YA:10 a=zo5UuM9zprJsMjT84rkA:9 a=z_3F83U8fK9vmbTR:21 a=sD_7g_QI9a20eatP:21 a=WzQICiuXm8o8MrpErxoA:9 X-Auth-id: anZkZWxpc2xlQGNoYXJ0ZXIubmV0 Message-ID: <54BC91C0.7060700@charter.net> Date: Sun, 18 Jan 2015 21:10:24 -0800 From: Jerry DeLisle User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:31.0) Gecko/20100101 Thunderbird/31.3.0 MIME-Version: 1.0 To: gfortran , gcc patches Subject: [patch, Fortran] PR61933 Inquire on Internal Units I reopened this PR to do some cleanup and to address a use case presented by Joost in comment #7 of the subject PR. The fundamental problem: if the variable containing the unit number in an INQUIRE statement is of type KIND greater than 4 and the value is outside the range of a KIND=4 we cannot test for it within the run-time library. Unit numbers are passed to the run-time in the IOPARM structures as a KIND=4. KIND=8 are cast into the KIND=4. The test case gfortran.dg/negative_unit_int8.f illustrates a case where a bogus unit number can get passed to the library. To resolve this previously we built range checks in trans_io.c (set_parameter_value) that tests the unit numbers and issues an error call to the run-time library. This is fine for all statements except INQUIRE which should not give an error. However, we do want to identify such an out-of-range unit number as not existing. This patch changes this by renaming the previous set_parameter_value to set_parameter_value_chk. I then created a new version of set_parameter_value that does no checking so that it can be used where generating errors is not needed. I have created two new functions which build code that tests for the out of range cases specific to INQUIRE. If a bad unit number is found, the UNIT value in the IOPARM structure is set to -2, a new reserved value. (after this patch we will have reserved values -3 thru -9 still available for future uses) The definition of unit existence is adjusted to be any negative unit currently connected having been created with NEWUNIT and all KIND=4 positive values. A -2 indicating an invalid unit will, by default, return EXISTS=false. The behind the scenes testing is never seen in user space as shown here with an -fdump-tree-original example from the negative_unit_int8.f . For non-INQUIRE cases: D.3384 = i; if (D.3384 < -2147483647) { _gfortran_generate_error (&dt_parm.0, 5005, &"Unit number in I/O statement too small" [1]{lb: 1 sz: 1}); } if (D.3384 > 2147483647) { _gfortran_generate_error (&dt_parm.0, 5005, &"Unit number in I/O statement too large" [1]{lb: 1 sz: 1}); } dt_parm.0.common.unit = (integer(kind=4)) D.3384; For the new INQUIRE case: integer(kind=8) i; --- snip --- inquire_parm.4.common.unit = (integer(kind=4)) i;<---notice the conversion to kind=4 here D.3393 = i; if (D.3393 < 0) { inquire_parm.4.common.unit = -2; } if (D.3393 > 2147483647) { inquire_parm.4.common.unit = -2; } When all is acceptable, common.unit is untouched and the normal assignment has happened. The users variable, in this case i, is untouched as well because of the temporary D.3393. The IOPARM stucture is also temporary and not used again. The patch updates the test case mentioned above. Regression tested on x86-64 and Joost's case in the PR now works as expected. OK for trunk? Regards, Jerry 2015-01-18 Jerry DeLisle PR fortran/61933 * trans-io.c (set_parameter_value): Delete use of has_iostat. Redefine to not generate any runtime error check calls. (set_parameter_value_chk): Rename of the former set_parameter_value with the runtimr error checks and fix whitespace. (gfc_trans_io_inquire_check): New function that builds a runtime conditional block to set the INQUIRE common parameter block unit number to -2 when unit numbers exceed positive KIND=4 limits. (set_parameter_value_inquire): New function that builds the conditional expressions and calls gfc_trans_io_inquire_check. (gfc_trans_open): Whitespace. For unit, use the renamed set_parameter_value_chk. (gfc_trans_close): Likewise use renamed function. (build_filepos): Whitespace and use renamed function. (gfc_trans_inquire): Whitespace and for unit use set_parameter_value and set_parameter_value_inquire. (gfc_trans_wait): Remove p->iostat from call to set_parameter_value. Use new set_parameter_value_chk for unit. (build_dt): Use the new set_parameter_value without p->iostat and fix whitespace. Use set_parameter_value_chk for unit. 2015-01-18 Jerry DeLisle PR libgfortran/61933 * io/inquire.c (inquire_via_unit): Set existing to true for any negative unit that is currently connected and any positive units within range of KIND=4 value. The unit value for any out of range case that may occur if the user is using a KIND=8 will have been set to -2 which is reserved and can never be opened, and therefore the unit does not exist. Index: gcc/fortran/trans-io.c =================================================================== --- gcc/fortran/trans-io.c (revision 219703) +++ gcc/fortran/trans-io.c (working copy) @@ -512,7 +512,37 @@ set_parameter_const (stmtblock_t *block, tree var, st_parameter_XXX structure. This is a pass by value. */ static unsigned int -set_parameter_value (stmtblock_t *block, bool has_iostat, tree var, +set_parameter_value (stmtblock_t *block, tree var, enum iofield type, + gfc_expr *e) +{ + gfc_se se; + tree tmp; + gfc_st_parameter_field *p = &st_parameter_field[type]; + tree dest_type = TREE_TYPE (p->field); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, e); + + se.expr = convert (dest_type, se.expr); + gfc_add_block_to_block (block, &se.pre); + + if (p->param_type == IOPARM_ptype_common) + var = fold_build3_loc (input_location, COMPONENT_REF, + st_parameter[IOPARM_ptype_common].type, + var, TYPE_FIELDS (TREE_TYPE (var)), NULL_TREE); + + tmp = fold_build3_loc (input_location, COMPONENT_REF, dest_type, var, + p->field, NULL_TREE); + gfc_add_modify (block, tmp, se.expr); + return p->mask; +} + + +/* Similar to set_parameter_value except generate runtime + error checks. */ + +static unsigned int +set_parameter_value_chk (stmtblock_t *block, bool has_iostat, tree var, enum iofield type, gfc_expr *e) { gfc_se se; @@ -550,7 +580,6 @@ static unsigned int gfc_trans_io_runtime_check (has_iostat, cond, var, LIBERROR_BAD_UNIT, "Unit number in I/O statement too large", &se.pre); - } se.expr = convert (dest_type, se.expr); @@ -568,6 +597,78 @@ static unsigned int } +/* Set the unit number in the inquire parameter block to -2. */ + +static void +gfc_trans_io_inquire_check (tree cond, tree var, stmtblock_t * pblock) +{ + stmtblock_t block; + tree body; + + gfc_start_block (&block); + + /* The unit number -2 is reserved. No units can ever have this + value. It is used here to signal to the runtime library that the + inquire unit number is outside the allowable range and so cannot + exist. It is needed when -fdefault-integer-8 is uesed. */ + + set_parameter_const (&block, var, IOPARM_common_unit, -2); + + body = gfc_finish_block (&block); + + var = build3_v (COND_EXPR, cond, body, build_empty_stmt (input_location)); + gfc_add_expr_to_block (pblock, var); +} + + +/* Build code to check the unit range if KIND=8 is used. Similar to + set_parameter_value_chk but we do not generate error calls for + inquire statements. */ + +static unsigned int +set_parameter_value_inquire (stmtblock_t *block, tree var, + enum iofield type, gfc_expr *e) +{ + gfc_se se; + gfc_st_parameter_field *p = &st_parameter_field[type]; + tree dest_type = TREE_TYPE (p->field); + + gfc_init_se (&se, NULL); + gfc_conv_expr_val (&se, e); + + /* If we're inquiring on a UNIT number, we need to check to make + sure it exists for larger than kind = 4. */ + if (type == IOPARM_common_unit && e->ts.kind > 4) + { + tree cond, val; + int i; + + /* Don't evaluate the UNIT number multiple times. */ + se.expr = gfc_evaluate_now (se.expr, &se.pre); + + /* UNIT numbers should be greater than zero. */ + i = gfc_validate_kind (BT_INTEGER, 4, false); + cond = build2_loc (input_location, LT_EXPR, boolean_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), + integer_zero_node)); + gfc_trans_io_inquire_check (cond, var, &se.pre); + + /* UNIT numbers should be less than the max. */ + val = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, 4); + cond = build2_loc (input_location, GT_EXPR, boolean_type_node, + se.expr, + fold_convert (TREE_TYPE (se.expr), val)); + gfc_trans_io_inquire_check (cond, var, &se.pre); + } + + se.expr = convert (dest_type, se.expr); + gfc_add_block_to_block (block, &se.pre); + + return p->mask; +} + + /* Generate code to store a non-string I/O parameter into the st_parameter_XXX structure. This is pass by reference. */ @@ -978,7 +1079,7 @@ gfc_trans_open (gfc_code * code) mask |= set_string (&block, &post_block, var, IOPARM_open_form, p->form); if (p->recl) - mask |= set_parameter_value (&block, p->iostat, var, IOPARM_open_recl_in, + mask |= set_parameter_value (&block, var, IOPARM_open_recl_in, p->recl); if (p->blank) @@ -1029,7 +1130,7 @@ gfc_trans_open (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); else set_parameter_const (&block, var, IOPARM_common_unit, 0); @@ -1082,7 +1183,7 @@ gfc_trans_close (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); else set_parameter_const (&block, var, IOPARM_common_unit, 0); @@ -1124,8 +1225,8 @@ build_filepos (tree function, gfc_code * code) p->iomsg); if (p->iostat) - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_common_iostat, - p->iostat); + mask |= set_parameter_ref (&block, &post_block, var, + IOPARM_common_iostat, p->iostat); if (p->err) mask |= IOPARM_common_err; @@ -1133,7 +1234,8 @@ build_filepos (tree function, gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, + p->unit); else set_parameter_const (&block, var, IOPARM_common_unit, 0); @@ -1225,10 +1327,8 @@ gfc_trans_inquire (gfc_code * code) p->file); if (p->exist) - { - mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, + mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_exist, p->exist); - } if (p->opened) mask |= set_parameter_ref (&block, &post_block, var, IOPARM_inquire_opened, @@ -1360,7 +1460,10 @@ gfc_trans_inquire (gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + { + set_parameter_value (&block, var, IOPARM_common_unit, p->unit); + set_parameter_value_inquire (&block, var, IOPARM_common_unit, p->unit); + } else set_parameter_const (&block, var, IOPARM_common_unit, 0); @@ -1407,12 +1510,12 @@ gfc_trans_wait (gfc_code * code) mask |= IOPARM_common_err; if (p->id) - mask |= set_parameter_value (&block, p->iostat, var, IOPARM_wait_id, p->id); + mask |= set_parameter_value (&block, var, IOPARM_wait_id, p->id); set_parameter_const (&block, var, IOPARM_common_flags, mask); if (p->unit) - set_parameter_value (&block, p->iostat, var, IOPARM_common_unit, p->unit); + set_parameter_value_chk (&block, p->iostat, var, IOPARM_common_unit, p->unit); tmp = gfc_build_addr_expr (NULL_TREE, var); tmp = build_call_expr_loc (input_location, @@ -1706,12 +1809,11 @@ build_dt (tree function, gfc_code * code) IOPARM_dt_id, dt->id); if (dt->pos) - mask |= set_parameter_value (&block, dt->iostat, var, IOPARM_dt_pos, - dt->pos); + mask |= set_parameter_value (&block, var, IOPARM_dt_pos, dt->pos); if (dt->asynchronous) - mask |= set_string (&block, &post_block, var, IOPARM_dt_asynchronous, - dt->asynchronous); + mask |= set_string (&block, &post_block, var, + IOPARM_dt_asynchronous, dt->asynchronous); if (dt->blank) mask |= set_string (&block, &post_block, var, IOPARM_dt_blank, @@ -1738,8 +1840,7 @@ build_dt (tree function, gfc_code * code) dt->sign); if (dt->rec) - mask |= set_parameter_value (&block, dt->iostat, var, IOPARM_dt_rec, - dt->rec); + mask |= set_parameter_value (&block, var, IOPARM_dt_rec, dt->rec); if (dt->advance) mask |= set_string (&block, &post_block, var, IOPARM_dt_advance, @@ -1791,8 +1892,8 @@ build_dt (tree function, gfc_code * code) set_parameter_const (&block, var, IOPARM_common_flags, mask); if (dt->io_unit && dt->io_unit->ts.type == BT_INTEGER) - set_parameter_value (&block, dt->iostat, var, IOPARM_common_unit, - dt->io_unit); + set_parameter_value_chk (&block, dt->iostat, var, + IOPARM_common_unit, dt->io_unit); } else set_parameter_const (&block, var, IOPARM_common_flags, mask); Index: gcc/testsuite/gfortran.dg/negative_unit_int8.f =================================================================== --- gcc/testsuite/gfortran.dg/negative_unit_int8.f (revision 219703) +++ gcc/testsuite/gfortran.dg/negative_unit_int8.f (working copy) @@ -30,6 +30,6 @@ ! This one is nasty inquire (unit=i, exist=l, iostat=i) if (l) call abort - if (i.ne.ERROR_BAD_UNIT) call abort + if (i.ne.0) call abort end Index: libgfortran/io/inquire.c =================================================================== --- libgfortran/io/inquire.c (revision 219703) +++ libgfortran/io/inquire.c (working copy) @@ -45,7 +45,8 @@ inquire_via_unit (st_parameter_inquire *iqp, gfc_u generate_error (&iqp->common, LIBERROR_INQUIRE_INTERNAL_UNIT, NULL); if ((cf & IOPARM_INQUIRE_HAS_EXIST) != 0) - *iqp->exist = (u != NULL); + *iqp->exist = (u != NULL) || (iqp->common.unit >= 0 + && iqp->common.unit <= GFC_INTEGER_4_HUGE); if ((cf & IOPARM_INQUIRE_HAS_OPENED) != 0) *iqp->opened = (u != NULL);