From patchwork Thu Feb 22 19:11:25 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry D X-Patchwork-Id: 86237 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 1401C3858420 for ; Thu, 22 Feb 2024 19:12:13 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pg1-x52e.google.com (mail-pg1-x52e.google.com [IPv6:2607:f8b0:4864:20::52e]) by sourceware.org (Postfix) with ESMTPS id 5669F3858D39; Thu, 22 Feb 2024 19:11:27 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 5669F3858D39 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmail.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmail.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 5669F3858D39 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2607:f8b0:4864:20::52e ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1708629089; cv=none; b=W3OP19oSCFHtLB20rVk6eN2GqdUC//Q6Mw8I3HRBteKCyn2dtm9IldkwNnKVJ7f+5qn2PsjvECogghLjiIEikdzdBZr/ABBfNm+8j/L0qLn7bujS34YAXq8Jhb9UYM1YfbXMl5iBkDhJ62dD0o6dwVbDzxFWHPqxZxaV7uCiTpQ= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1708629089; c=relaxed/simple; bh=QrQrd0w2ifwNE45dPuphA2w5vIa/gE5Q8qWuBG0H8aQ=; h=DKIM-Signature:Message-ID:Date:MIME-Version:To:From:Subject; b=WkaBKstpcZO11DKMxqdVnQUIvaFHAPqNuowg51EoRahwcrFmm4oIb2St3GxH7LWQCoed+SpYQDlwLsdzhRO/w7pLZBcbTywqAd5lx4DN6WV85OsyKLDF2SAHRO/pUZotZrbQPO0/gBI/EsfI3Uz/Dvqalmx5ucY6a3hWuwd93EU= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-pg1-x52e.google.com with SMTP id 41be03b00d2f7-5cfb8126375so5604a12.1; Thu, 22 Feb 2024 11:11:27 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1708629086; x=1709233886; darn=gcc.gnu.org; h=autocrypt:subject:from:cc:to:content-language:user-agent :mime-version:date:message-id:from:to:cc:subject:date:message-id :reply-to; bh=6D0FtZyNuaolgiOqoe1NbaGeHdqb71QB3opGcz5Z3PA=; b=VCPbOjTBms+PrOR++sYfRskEOooxj2k9Mqy2uMns74PtLXzkcrhutts8+PjVvO1Ew1 3HdcWSPULx6JPYn93W+4Q4cXJ8Sk/OnM7b+hGp8xn1nLvtJB0mN8HNRzZBdzLHJapylw vtwhwEHIUq0IlQ9HcnJPQMGD8X99/eC1siQBWzVeqV2nNpGwOaow2FxfPu1GyLkXN193 42R8ca0pgHP0VqchnUNfV/GLdPrShn3gyiKuBrbtvqax1NphPqeK2jCrKS58T2jautIT sImfGCSyKSaSXLmuFRp/UdcQjVsk4DV6YR2HG9d1Of2A9b2RIj9kO+69dbAiJ+slKJE1 2Ivw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1708629086; x=1709233886; h=autocrypt:subject:from:cc:to:content-language:user-agent :mime-version:date:message-id:x-gm-message-state:from:to:cc:subject :date:message-id:reply-to; bh=6D0FtZyNuaolgiOqoe1NbaGeHdqb71QB3opGcz5Z3PA=; b=LxComA3PWPB6O03pqZkE6DApHSoqpjD/QZk3djKJ4VyV8mw/zjBNKaQyS7sucTBwEx iCM+4xtExrxTUE5WGNOQrErdH9nSUuTGV95NR6AtJsdgnOEgLUmnd51mBY6sUal3C/Hc LRwfsedE+C8LddxINgr9+eXEP2j4po1B6O0RlT/BD+aKFBBZKwnKiikZt/8GDmP9K98j vJlLaq3DDmDdsCcLXljQM3y9WJMfW2Fjb4ImmgWpdnWCeAPdnZy90gBTLgVHv2Xopw4W 8XrvOFI2vBeRDe/QY704+NOMCs1ZoGijf50jg9oIZz3lqnceifX7UjDlDcd9/HuegO5U 4vRw== X-Gm-Message-State: AOJu0Yzc1rSbB2LCmpUBC5hmFQGWiY5JHLVlJXdC13pWHY3aSYjMpj08 L6Gh+ljFe8shejsnUBWzfccmKh1AmHd0SCrvyvUrmACCDKCgf+Fq7yx3S+6PAb4= X-Google-Smtp-Source: AGHT+IEQh7gRi73hEe7P00gAJS0K0WS0Hf4dSQL7//sQyqOvqrZLpyVlJsXXPDMW6RVKuWcOnYIWZw== X-Received: by 2002:a05:6a21:328d:b0:1a0:d4d4:260b with SMTP id yt13-20020a056a21328d00b001a0d4d4260bmr2679513pzb.3.1708629085869; Thu, 22 Feb 2024 11:11:25 -0800 (PST) Received: from [192.168.1.20] ([50.37.177.113]) by smtp.gmail.com with ESMTPSA id k2-20020a632402000000b005dcc8a3b26esm10369418pgk.16.2024.02.22.11.11.25 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Thu, 22 Feb 2024 11:11:25 -0800 (PST) Message-ID: <701a3111-c3b5-422c-bee7-50ba00e3847a@gmail.com> Date: Thu, 22 Feb 2024 11:11:25 -0800 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US To: gfortran Cc: gcc-patches From: Jerry D Subject: [patch, libgfortran] PR105456 Child I/O does not propage iostat Autocrypt: addr=jvdelisle2@gmail.com; keydata= xjMEY5TlkxYJKwYBBAHaRw8BAQdAyrkRDhmJhSTTlV/50gJLlvliU6/Lm5C9ViKV8T9y1GnN HkplcnJ5IEQgPGp2ZGVsaXNsZTJAZ21haWwuY29tPsKJBBMWCAAxFiEEOFR0TS0390uh8dRV uWXAJaWpwWoFAmOU5ZMCGwMECwkIBwUVCAkKCwUWAgMBAAAKCRC5ZcAlpanBalsJAP4wdCiH 2Of9oZv1QWgZ/AVdbWFM3Fv47/WZQHOXfoZ9HgD6AkXrKeJ+6usST7PEaDJjptaViT1fLiYY V/6XaOKSsgLOOARjlOWTEgorBgEEAZdVAQUBAQdAdA7PczYnl07vnOT9oP/wvvMDd4HP09Zl g3LzwXQJWT8DAQgHwngEGBYIACAWIQQ4VHRNLTf3S6Hx1FW5ZcAlpanBagUCY5TlkwIbDAAK CRC5ZcAlpanBasF/AQCa5WjlsVpLsEiggZyT18MOJNAdeRd7wkGDUrwedHrvawD/cE1H+/Ms L1ZwvQiLfGdx8crigQqWTQyos4kH8Wx82wc= X-Spam-Status: No, score=-8.1 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, GIT_PATCH_0, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Hi all, The attached fix adds a check for an error condition from a UDDTIO procedure in the case where there is no actual underlying error, but the user defines an error by setting the iostat variable manually before returning to the parent READ. I did not address the case of a formatted WRITE or unformatted READ/WRITE until I get some feedback on the approach. If this approach is OK I would like to commit and then do a separate patch for the cases I just mentioned. Feedback appreciated. Regression tested on x86_64. OK for trunk? Jerry Author: Jerry DeLisle Date: Thu Feb 22 10:48:39 2024 -0800 libgfortran: Propagate user defined iostat and iomsg. PR libfortran/105456 libgfortran/ChangeLog: * io/list_read.c (list_formatted_read_scalar): Add checks for the case where a user defines their own error codes and error messages and generate the runtime error. gcc/testsuite/ChangeLog: * gfortran.dg/pr105456.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/pr105456.f90 b/gcc/testsuite/gfortran.dg/pr105456.f90 new file mode 100644 index 00000000000..411873f4aed --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr105456.f90 @@ -0,0 +1,41 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module sk1 + implicit none + type char + character :: ch + end type char + interface read (formatted) + module procedure read_formatted + end interface read (formatted) +contains + subroutine read_formatted (dtv, unit, iotype, vlist, piostat, piomsg) + class (char), intent(inout) :: dtv + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: piostat + character (len=*), intent(inout) :: piomsg + character :: ch + read (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) ch + piostat = 42 + piomsg="The users message" + dtv%ch = ch + end subroutine read_formatted +end module sk1 + +program skip1 + use sk1 + implicit none + integer :: myerror = 0 + character(64) :: mymessage = "" + type (char) :: x + open (10,status="scratch") + write (10,'(A)') '', 'a' + rewind (10) + read (10,*) x + print *, myerror, mymessage + write (*,'(10(A))') "Read: '",x%ch,"'" +end program skip1 +! { dg-output ".*(unit = 10, file = .*)" } +! { dg-output "Fortran runtime error: The users message" } diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index 3d29cb64813..ee3ab713519 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -2138,6 +2138,7 @@ static int list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, size_t size) { + char message[MSGLEN]; gfc_char4_t *q, *r; size_t m; int c; @@ -2247,7 +2248,7 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, child_iostat = ((dtp->common.flags & IOPARM_HAS_IOSTAT) ? dtp->common.iostat : &noiostat); - /* Set iomsge, intent(inout). */ + /* Set iomsg, intent(inout). */ if (dtp->common.flags & IOPARM_HAS_IOMSG) { child_iomsg = dtp->common.iomsg; @@ -2266,6 +2267,25 @@ list_formatted_read_scalar (st_parameter_dt *dtp, bt type, void *p, iotype_len, child_iomsg_len); dtp->u.p.child_saved_iostat = *child_iostat; dtp->u.p.current_unit->child_dtio--; + + + if ((dtp->u.p.child_saved_iostat != 0) && + !(dtp->common.flags & IOPARM_HAS_IOMSG) && + !(dtp->common.flags & IOPARM_HAS_IOSTAT)) + { + /* Trim trailing spaces from the message. */ + for(int i = IOMSG_LEN - 1; i > 0; i--) + if (!isspace(child_iomsg[i])) + { + /* Add two to get back to the end of child_iomsg. */ + child_iomsg_len = i+2; + break; + } + free_line (dtp); + snprintf (message, child_iomsg_len, child_iomsg); + generate_error (&dtp->common, dtp->u.p.child_saved_iostat, + message); + } } break; default: