From patchwork Thu Feb 29 05:29:06 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry D X-Patchwork-Id: 208202 Return-Path: Delivered-To: ouuuleilei@gmail.com Received: by 2002:a05:7301:2097:b0:108:e6aa:91d0 with SMTP id gs23csp188707dyb; Wed, 28 Feb 2024 21:29:56 -0800 (PST) X-Forwarded-Encrypted: i=3; AJvYcCWaMNzM7WBhq0aAJ3YO5I+b0lNpAIVhC2W4p/1ZlqU/Z32vdFYLvQpdc1m5CHinO6LsTMpZqkSBIt/8zzFslRpBUPeklQ== X-Google-Smtp-Source: AGHT+IE7rmyxfVwO3j+mIerjEZO0q5bQTr+iJat8tRK/x2PH+l7DO1auA/HIiEXxLxe2z/h7Y86a X-Received: by 2002:ad4:55f2:0:b0:690:38bd:49bc with SMTP id bu18-20020ad455f2000000b0069038bd49bcmr1168566qvb.3.1709184596260; Wed, 28 Feb 2024 21:29:56 -0800 (PST) ARC-Seal: i=2; a=rsa-sha256; t=1709184596; cv=pass; d=google.com; s=arc-20160816; b=MIITsBFVywc/Q++NmWqzu6cLQqTzu9HScyggdZ3MT/ZB9Ld/1b7diVcZa4DzYzPNAG b3sKUaxLiXD2+a4NC9ay/Vlu04mWFpCiPiTZPqCMmCRnpMWa7RR5yX533IzebNgEDZGX ilmG2HzQJXh8edBPNmPtYJwYPLTqAo6Wr0/zBaROlQv11EWQ9bzHJafwcffa37XdANW/ DkH1tRM6H2H7bOG2ABhTD1q98fXArFbA5D3JXmqv+9aVKK4snf+qy994cZp5PPT3Dc2J 9alBnqM1S94BoAE0ENmHqdKt46CRe0zd/qiJyVYM+byOUn0M13oS72SNuUCKwPb4pwnw DvQQ== ARC-Message-Signature: i=2; a=rsa-sha256; c=relaxed/relaxed; d=google.com; s=arc-20160816; h=errors-to:list-subscribe:list-help:list-post:list-archive :list-unsubscribe:list-id:precedence:autocrypt:subject:from:cc:to :content-language:user-agent:mime-version:date:message-id :dkim-signature:arc-filter:dmarc-filter:delivered-to; bh=jls1VfvMXSD/2LYVppPjbkZhCoLzpta4m/TzEYw72t0=; fh=UkF7zbAmGOuQNqgv9WAvv2RTdH3w2UR/Ma+DhILsXKU=; b=Avj2/fAzXnvuOc5OPuhiPY/2xdFX+oPs/s5jrAvOz8WO8X1SYO1N3NPQV6knc8hmoR xHIMR7ycfjRP3NvvPO+6qTS15nsplsJu/E/PDhli21UNHkiJh+eqnl2xeKIuL/ay79BL lzNBtNba/fkIEQNH7DpymPbVXdJ02ZyNJUfq5PrF8MOM+aoJV858UK/Wzpij3uKOUIAK iT7LBHgpK8C9O16wvssVbsLwUPbhNEgzIbW17zgYPU4v7JzhDW5nUkogUNlzDr0bEdLI q5m9+fyQLQ204i7zmzW5YoBeXCiUXe8nZz21lcWx78JWoa6ouVRtEak8d6KZyXo4uwZi p1Nw==; dara=google.com ARC-Authentication-Results: i=2; mx.google.com; dkim=pass header.i=@gmail.com header.s=20230601 header.b=NDIsBbXU; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=QUARANTINE dis=NONE) header.from=gmail.com Received: from server2.sourceware.org (server2.sourceware.org. [2620:52:3:1:0:246e:9693:128c]) by mx.google.com with ESMTPS id e5-20020a0562141d0500b00681991637e6si693426qvd.484.2024.02.28.21.29.56 for (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 28 Feb 2024 21:29:56 -0800 (PST) Received-SPF: pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) client-ip=2620:52:3:1:0:246e:9693:128c; Authentication-Results: mx.google.com; dkim=pass header.i=@gmail.com header.s=20230601 header.b=NDIsBbXU; arc=pass (i=1); spf=pass (google.com: domain of gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org designates 2620:52:3:1:0:246e:9693:128c as permitted sender) smtp.mailfrom="gcc-patches-bounces+ouuuleilei=gmail.com@gcc.gnu.org"; dmarc=pass (p=NONE sp=QUARANTINE dis=NONE) header.from=gmail.com Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id F16F43858C36 for ; Thu, 29 Feb 2024 05:29:55 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-oi1-x22d.google.com (mail-oi1-x22d.google.com [IPv6:2607:f8b0:4864:20::22d]) by sourceware.org (Postfix) with ESMTPS id CE4683858C5F; Thu, 29 Feb 2024 05:29:08 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org CE4683858C5F 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 CE4683858C5F Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2607:f8b0:4864:20::22d ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1709184552; cv=none; b=opY4MPdXUIA2TEyro0YMZLDpUCyEZy3MUFfZLOL5m6afpA3Cb34q5QfcqGy9Js7lgYTF/zHcQXV1hG8sfiA6Tyu7Nt4L3ZCyHdlXSJhhM36Chb5QA9AK/ARrbhWiO3rfc2G2tWK9SHfW6cZ12j1nAieEaykI6Cwa8E8wZGO6hOI= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1709184552; c=relaxed/simple; bh=ihJ/hU3LMmYZ+Cq6H8xbarTONSn2Ys7pRKrEjwjWuOc=; h=DKIM-Signature:Message-ID:Date:MIME-Version:To:From:Subject; b=CmoyFV3xqPYajsHsSb/QC2/PwNpSsYEhOxlw8qx3iJiWuN3bnHIsSzai7/GWTp01UCqVvP2FciRURpRh6krRBGl/E6qLpMtL1vNRidh5bQYRDLwZSaStCr81dZpzzohjSHADQV+pZtE+nEpUVTZaTABbIbQG7xk+g5Qeke86jsY= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-oi1-x22d.google.com with SMTP id 5614622812f47-3bc21303a35so144826b6e.0; Wed, 28 Feb 2024 21:29:08 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1709184548; x=1709789348; 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=jls1VfvMXSD/2LYVppPjbkZhCoLzpta4m/TzEYw72t0=; b=NDIsBbXUCUFaahAdVYLJtEe63I/Vo+YFPW8uaq02KClLIP476hBU/pqUgwzkR/FE1F lJABrHm2GDGB2NfC6aCCwCCYHe+q41XyzhseL/hG7w1fTXYscNscch0ub0e4dNMkC0mI uMpZlszMoQD9ZhB8pwQ6hqdA6rwfbwGyzOCm46XEbbfI7DgN/x7nRtUFV8rHmbBb/CgK JDKUHAT0RXOtxFLtO9wXE+qnuFXAYkVlU6JXjaRqFHXl766iOfUivZcr8dr4VTC8oY7p PnPDgqecn6zaSP3nWJS/4jOmCXtxaNGtZVaULQ9wJDiHFsCJsf37RmbXLlex5/L3pKqU uMrw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1709184548; x=1709789348; 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=jls1VfvMXSD/2LYVppPjbkZhCoLzpta4m/TzEYw72t0=; b=nrzhSeB19Kvb8CRcfN3cclQxM0gvunD47nASrrgRgXqnDX5CHoIpntArT+CtGwOTuB KzDEqRXHXQzpepuhLjhGzi/Z2VblfVCMG5rnFGSwn4QT1qdZ4u3kr7crDDU65IfqLvqL hRWefVGsSuHrjHIpmYeuTEzy8lPZBzB7lG9cOgZPCfp7IiPz7QPde0zxfsG2H8M6/pTt edB5aw41xiK1FbrTzO1xALkSoa6AJT2DXO9hyL92tUH9lvrKlAOm3wcxVAwPxbjrJyoZ fSyFG8sq9nPyiIrh8lTFVDdeEkTqrrKl0n4N26QS+JPErArebeGEL1YqdLZ8pNhKcuyZ beTQ== X-Gm-Message-State: AOJu0Yx7QWbQfOkLuOV7n2Le/Vrv+KFHb83w15J5Puw2iWczRI1vn8WK Aic/5VJD9w8N6mt7bP+zwsZZkMDul9neTUYZW90eXaXNjJnhm8JneA6E9hOd X-Received: by 2002:a05:6870:d28b:b0:21f:8fde:1fcd with SMTP id d11-20020a056870d28b00b0021f8fde1fcdmr995461oae.0.1709184547708; Wed, 28 Feb 2024 21:29:07 -0800 (PST) Received: from [192.168.1.20] ([50.37.177.113]) by smtp.gmail.com with ESMTPSA id i19-20020aa787d3000000b006e4e19f3539sm355160pfo.86.2024.02.28.21.29.07 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Wed, 28 Feb 2024 21:29:07 -0800 (PST) Message-ID: <943c3685-c4d4-4f22-8b65-6336f8770043@gmail.com> Date: Wed, 28 Feb 2024 21:29:06 -0800 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US To: gfortran Cc: gcc-patches From: Jerry D Subject: [patch, libgfortran] Part 2: 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+ouuuleilei=gmail.com@gcc.gnu.org X-getmail-retrieved-from-mailbox: INBOX X-GMAIL-THRID: 1792209946954587255 X-GMAIL-MSGID: 1792209946954587255 The attached patch adds the error checks similar to the first patch previously committed. I noticed a redundancy in some defines MSGLEN and IOMSG_LEN so I consolidated this to one define in io.h. This is just cleanup stuff. I have added test cases for each of the places where UDTIO is done in the library. Regressions tested on x86_64. OK for trunk? Regards, Jerry commit 640991bd6b83df4197b2eaec63d1e0e695e48b75 Author: Jerry DeLisle Date: Wed Feb 28 20:51:06 2024 -0800 Fortran: Add user defined error messages for UDTIO. The defines IOMSG_LEN and MSGLEN were redundant so these are combined into IOMSG_LEN as defined in io.h. The remainder of the patch adds checks for when a user defined derived type IO procedure sets the IOSTAT or IOMSG variables independent of the librrary defined I/O messages. PR libfortran/105456 libgfortran/ChangeLog: * io/io.h (IOMSG_LEN): Moved to here. * io/list_read.c (MSGLEN): Removed MSGLEN. (convert_integer): Changed MSGLEN to IOMSG_LEN. (parse_repeat): Likewise. (read_logical): Likewise. (read_integer): Likewise. (read_character): Likewise. (parse_real): Likewise. (read_complex): Likewise. (read_real): Likewise. (check_type): Likewise. (list_formatted_read_scalar): Adjust to IOMSG_LEN. (nml_read_obj): Add user defined error message. * io/transfer.c (unformatted_read): Add user defined error message. (unformatted_write): Add user defined error message. (formatted_transfer_scalar_read): Add user defined error message. (formatted_transfer_scalar_write): Add user defined error message. * io/write.c (list_formatted_write_scalar): Add user defined error message. (nml_write_obj): Add user defined error message. gcc/testsuite/ChangeLog: * gfortran.dg/pr105456-nmlr.f90: New test. * gfortran.dg/pr105456-nmlw.f90: New test. * gfortran.dg/pr105456-ruf.f90: New test. * gfortran.dg/pr105456-wf.f90: New test. * gfortran.dg/pr105456-wuf.f90: New test. diff --git a/gcc/testsuite/gfortran.dg/pr105456-nmlr.f90 b/gcc/testsuite/gfortran.dg/pr105456-nmlr.f90 new file mode 100644 index 00000000000..5ce5d082133 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr105456-nmlr.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module m + implicit none + type :: t + character :: c + integer :: k + contains + procedure :: write_formatted + generic :: write(formatted) => write_formatted + procedure :: read_formatted + generic :: read(formatted) => read_formatted + end type +contains + subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + if (iotype.eq."NAMELIST") then + write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k + else + write (unit,*) dtv%c, dtv%k + end if + end subroutine + subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character :: comma + if (iotype.eq."NAMELIST") then + read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k + else + read (unit,*) dtv%c, comma, dtv%k + endif + iostat = 42 + iomsg = "The users message" + if (comma /= ',') STOP 1 + end subroutine +end module + +program p + use m + implicit none + character(len=50) :: buffer + type(t) :: x + namelist /nml/ x + x = t('a', 5) + write (buffer, nml) + if (buffer.ne.' &NML X=a, 5 /') STOP 1 + x = t('x', 0) + read (buffer, nml) + if (x%c.ne.'a'.or. x%k.ne.5) STOP 2 +end +! { dg-output "Fortran runtime error: The users message" } diff --git a/gcc/testsuite/gfortran.dg/pr105456-nmlw.f90 b/gcc/testsuite/gfortran.dg/pr105456-nmlw.f90 new file mode 100644 index 00000000000..2c496e611f4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr105456-nmlw.f90 @@ -0,0 +1,60 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module m + implicit none + type :: t + character :: c + integer :: k + contains + procedure :: write_formatted + generic :: write(formatted) => write_formatted + procedure :: read_formatted + generic :: read(formatted) => read_formatted + end type +contains + subroutine write_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(in) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + if (iotype.eq."NAMELIST") then + write (unit, '(a1,a1,i3)') dtv%c,',', dtv%k + else + write (unit,*) dtv%c, dtv%k + end if + iostat = 42 + iomsg = "The users message" + end subroutine + subroutine read_formatted(dtv, unit, iotype, v_list, iostat, iomsg) + class(t), intent(inout) :: dtv + integer, intent(in) :: unit + character(*), intent(in) :: iotype + integer, intent(in) :: v_list(:) + integer, intent(out) :: iostat + character(*), intent(inout) :: iomsg + character :: comma + if (iotype.eq."NAMELIST") then + read (unit, '(a1,a1,i3)') dtv%c, comma, dtv%k + else + read (unit,*) dtv%c, comma, dtv%k + end if + if (comma /= ',') STOP 1 + end subroutine +end module + +program p + use m + implicit none + character(len=50) :: buffer + type(t) :: x + namelist /nml/ x + x = t('a', 5) + write (buffer, nml) + if (buffer.ne.' &NML X=a, 5 /') STOP 1 + x = t('x', 0) + read (buffer, nml) + if (x%c.ne.'a'.or. x%k.ne.5) STOP 2 +end +! { dg-output "Fortran runtime error: The users message" } diff --git a/gcc/testsuite/gfortran.dg/pr105456-ruf.f90 b/gcc/testsuite/gfortran.dg/pr105456-ruf.f90 new file mode 100644 index 00000000000..c176c4aa18c --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr105456-ruf.f90 @@ -0,0 +1,36 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module sk1 + implicit none + type char + character :: ch + end type char + interface read (unformatted) + module procedure read_unformatted + end interface read (unformatted) +contains + subroutine read_unformatted (dtv, unit, 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 + read (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch + piostat = 42 + piomsg="The users message" + end subroutine read_unformatted +end module sk1 + +program skip1 + use sk1 + implicit none + type (char) :: x + x%ch = 'X' + open (10, form='unformatted', status='scratch') + write (10) 'X' + rewind (10) + read (10) x +end program skip1 +! { dg-output ".*(unit = 10, file = .*)" } +! { dg-output "Fortran runtime error: The users message" } diff --git a/gcc/testsuite/gfortran.dg/pr105456-wf.f90 b/gcc/testsuite/gfortran.dg/pr105456-wf.f90 new file mode 100644 index 00000000000..f1c5350cc00 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr105456-wf.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module sk1 + implicit none + type char + character :: ch + end type char + interface write (formatted) + module procedure write_formatted + end interface write (formatted) +contains + subroutine write_formatted (dtv, unit, iotype, vlist, piostat, piomsg) + class (char), intent(in) :: dtv + integer, intent(in) :: unit + character (len=*), intent(in) :: iotype + integer, intent(in) :: vlist(:) + integer, intent(out) :: piostat + character (len=*), intent(inout) :: piomsg + write (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch + piostat = 42 + piomsg="The users message" + end subroutine write_formatted +end module sk1 + +program skip1 + use sk1 + implicit none + type (char) :: x + x%ch = 'X' + open (10, status='scratch') + write (10,*) x +end program skip1 +! { dg-output ".*(unit = 10, file = .*)" } +! { dg-output "Fortran runtime error: The users message" } diff --git a/gcc/testsuite/gfortran.dg/pr105456-wuf.f90 b/gcc/testsuite/gfortran.dg/pr105456-wuf.f90 new file mode 100644 index 00000000000..2b637b704a4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pr105456-wuf.f90 @@ -0,0 +1,34 @@ +! { dg-do run } +! { dg-shouldfail "The users message" } +module sk1 + implicit none + type char + character :: ch + end type char + interface write (unformatted) + module procedure write_unformatted + end interface write (unformatted) +contains + subroutine write_unformatted (dtv, unit, piostat, piomsg) + class (char), intent(in) :: dtv + integer, intent(in) :: unit + !character (len=*), intent(in) :: iotype + !integer, intent(in) :: vlist(:) + integer, intent(out) :: piostat + character (len=*), intent(inout) :: piomsg + write (unit,fmt='(A1)', advance="no", iostat=piostat, iomsg=piomsg) dtv%ch + piostat = 42 + piomsg="The users message" + end subroutine write_unformatted +end module sk1 + +program skip1 + use sk1 + implicit none + type (char) :: x + x%ch = 'X' + open (10, form='unformatted', status='scratch') + write (10) x +end program skip1 +! { dg-output ".*(unit = 10, file = .*)" } +! { dg-output "Fortran runtime error: The users message" } diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 59bc19ee815..1c23676cc4c 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -34,6 +34,9 @@ see the files COPYING3 and COPYING.RUNTIME respectively. If not, see #define gcc_unreachable() __builtin_unreachable () +/* Used for building error message strings. */ +#define IOMSG_LEN 256 + /* POSIX 2008 specifies that the extended locale stuff is found in locale.h, but some systems have them in xlocale.h. */ @@ -99,10 +102,6 @@ typedef struct array_loop_spec } array_loop_spec; -/* User defined input/output iomsg length. */ - -#define IOMSG_LEN 256 - /* Subroutine formatted_dtio (struct, unit, iotype, v_list, iostat, iomsg, (_iotype), (_iomsg)) */ typedef void (*formatted_dtio)(void *, GFC_INTEGER_4 *, char *, diff --git a/libgfortran/io/list_read.c b/libgfortran/io/list_read.c index ee3ab713519..db7d53b69d8 100644 --- a/libgfortran/io/list_read.c +++ b/libgfortran/io/list_read.c @@ -64,10 +64,6 @@ typedef unsigned char uchar; #define MAX_REPEAT 200000000 - -#define MSGLEN 100 - - /* Wrappers for calling the current worker functions. */ #define next_char(dtp) ((dtp)->u.p.current_unit->next_char_fn_ptr (dtp)) @@ -632,7 +628,7 @@ nml_bad_return (st_parameter_dt *dtp, char c) static int convert_integer (st_parameter_dt *dtp, int length, int negative) { - char c, *buffer, message[MSGLEN]; + char c, *buffer, message[IOMSG_LEN]; int m; GFC_UINTEGER_LARGEST v, max, max10; GFC_INTEGER_LARGEST value; @@ -682,7 +678,7 @@ convert_integer (st_parameter_dt *dtp, int length, int negative) if (dtp->u.p.repeat_count == 0) { - snprintf (message, MSGLEN, "Zero repeat count in item %d of list input", + snprintf (message, IOMSG_LEN, "Zero repeat count in item %d of list input", dtp->u.p.item_count); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); @@ -695,10 +691,10 @@ convert_integer (st_parameter_dt *dtp, int length, int negative) overflow: if (length == -1) - snprintf (message, MSGLEN, "Repeat count overflow in item %d of list input", + snprintf (message, IOMSG_LEN, "Repeat count overflow in item %d of list input", dtp->u.p.item_count); else - snprintf (message, MSGLEN, "Integer overflow while reading item %d", + snprintf (message, IOMSG_LEN, "Integer overflow while reading item %d", dtp->u.p.item_count); free_saved (dtp); @@ -715,7 +711,7 @@ convert_integer (st_parameter_dt *dtp, int length, int negative) static int parse_repeat (st_parameter_dt *dtp) { - char message[MSGLEN]; + char message[IOMSG_LEN]; int c, repeat; if ((c = next_char (dtp)) == EOF) @@ -746,7 +742,7 @@ parse_repeat (st_parameter_dt *dtp) if (repeat > MAX_REPEAT) { - snprintf (message, MSGLEN, + snprintf (message, IOMSG_LEN, "Repeat count overflow in item %d of list input", dtp->u.p.item_count); @@ -759,7 +755,7 @@ parse_repeat (st_parameter_dt *dtp) case '*': if (repeat == 0) { - snprintf (message, MSGLEN, + snprintf (message, IOMSG_LEN, "Zero repeat count in item %d of list input", dtp->u.p.item_count); @@ -789,7 +785,7 @@ parse_repeat (st_parameter_dt *dtp) } else eat_line (dtp); - snprintf (message, MSGLEN, "Bad repeat count in item %d of list input", + snprintf (message, IOMSG_LEN, "Bad repeat count in item %d of list input", dtp->u.p.item_count); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); return 1; @@ -816,7 +812,7 @@ l_push_char (st_parameter_dt *dtp, char c) static void read_logical (st_parameter_dt *dtp, int length) { - char message[MSGLEN]; + char message[IOMSG_LEN]; int c, i, v; if (parse_repeat (dtp)) @@ -953,7 +949,7 @@ read_logical (st_parameter_dt *dtp, int length) } else if (c != '\n') eat_line (dtp); - snprintf (message, MSGLEN, "Bad logical value while reading item %d", + snprintf (message, IOMSG_LEN, "Bad logical value while reading item %d", dtp->u.p.item_count); free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); @@ -977,7 +973,7 @@ read_logical (st_parameter_dt *dtp, int length) static void read_integer (st_parameter_dt *dtp, int length) { - char message[MSGLEN]; + char message[IOMSG_LEN]; int c, negative; negative = 0; @@ -1112,7 +1108,7 @@ read_integer (st_parameter_dt *dtp, int length) else if (c != '\n') eat_line (dtp); - snprintf (message, MSGLEN, "Bad integer for item %d in list input", + snprintf (message, IOMSG_LEN, "Bad integer for item %d in list input", dtp->u.p.item_count); free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); @@ -1140,7 +1136,7 @@ read_integer (st_parameter_dt *dtp, int length) static void read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) { - char quote, message[MSGLEN]; + char quote, message[IOMSG_LEN]; int c; quote = ' '; /* Space means no quote character. */ @@ -1286,7 +1282,7 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) else { free_saved (dtp); - snprintf (message, MSGLEN, "Invalid string input in item %d", + snprintf (message, IOMSG_LEN, "Invalid string input in item %d", dtp->u.p.item_count); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); } @@ -1306,7 +1302,7 @@ read_character (st_parameter_dt *dtp, int length __attribute__ ((unused))) static int parse_real (st_parameter_dt *dtp, void *buffer, int length) { - char message[MSGLEN]; + char message[IOMSG_LEN]; int c, m, seen_dp; if ((c = next_char (dtp)) == EOF) @@ -1521,7 +1517,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) else if (c != '\n') eat_line (dtp); - snprintf (message, MSGLEN, "Bad complex floating point " + snprintf (message, IOMSG_LEN, "Bad complex floating point " "number for item %d", dtp->u.p.item_count); free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); @@ -1536,7 +1532,7 @@ parse_real (st_parameter_dt *dtp, void *buffer, int length) static void read_complex (st_parameter_dt *dtp, void *dest, int kind, size_t size) { - char message[MSGLEN]; + char message[IOMSG_LEN]; int c; if (parse_repeat (dtp)) @@ -1633,7 +1629,7 @@ eol_4: else if (c != '\n') eat_line (dtp); - snprintf (message, MSGLEN, "Bad complex value in item %d of list input", + snprintf (message, IOMSG_LEN, "Bad complex value in item %d of list input", dtp->u.p.item_count); free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); @@ -1645,7 +1641,7 @@ eol_4: static void read_real (st_parameter_dt *dtp, void *dest, int length) { - char message[MSGLEN]; + char message[IOMSG_LEN]; int c; int seen_dp; int is_inf; @@ -2059,7 +2055,7 @@ read_real (st_parameter_dt *dtp, void *dest, int length) else if (c != '\n') eat_line (dtp); - snprintf (message, MSGLEN, "Bad real number in item %d of list input", + snprintf (message, IOMSG_LEN, "Bad real number in item %d of list input", dtp->u.p.item_count); free_line (dtp); generate_error (&dtp->common, LIBERROR_READ_VALUE, message); @@ -2072,11 +2068,11 @@ read_real (st_parameter_dt *dtp, void *dest, int length) static int check_type (st_parameter_dt *dtp, bt type, int kind) { - char message[MSGLEN]; + char message[IOMSG_LEN]; if (dtp->u.p.saved_type != BT_UNKNOWN && dtp->u.p.saved_type != type) { - snprintf (message, MSGLEN, "Read type %s where %s was expected for item %d", + snprintf (message, IOMSG_LEN, "Read type %s where %s was expected for item %d", type_name (dtp->u.p.saved_type), type_name (type), dtp->u.p.item_count); free_line (dtp); @@ -2090,7 +2086,7 @@ check_type (st_parameter_dt *dtp, bt type, int kind) if ((type != BT_COMPLEX && dtp->u.p.saved_length != kind) || (type == BT_COMPLEX && dtp->u.p.saved_length != kind*2)) { - snprintf (message, MSGLEN, + snprintf (message, IOMSG_LEN, "Read kind %d %s where kind %d is required for item %d", type == BT_COMPLEX ? dtp->u.p.saved_length / 2 : dtp->u.p.saved_length, @@ -2138,7 +2134,6 @@ 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; @@ -2267,12 +2262,12 @@ 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)) { + char message[IOMSG_LEN]; /* Trim trailing spaces from the message. */ for(int i = IOMSG_LEN - 1; i > 0; i--) if (!isspace(child_iomsg[i])) @@ -3060,7 +3055,7 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset, GFC_DESCRIPTOR_DATA(&vlist) = NULL; GFC_DIMENSION_SET(vlist.dim[0],1, 0, 0); - + list_obj.vptr = nl->vtable; list_obj.len = 0; @@ -3088,6 +3083,26 @@ nml_read_obj (st_parameter_dt *dtp, namelist_info *nl, index_type offset, 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)) + { + char message[IOMSG_LEN]; + /* 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; + } + snprintf (message, child_iomsg_len, child_iomsg); + generate_error (&dtp->common, dtp->u.p.child_saved_iostat, + message); + goto nml_err_ret; + } + goto incr_idx; } diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 01db4122d16..992aacc1df9 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -1120,7 +1120,28 @@ unformatted_read (st_parameter_dt *dtp, bt type, dtp->u.p.current_unit->child_dtio++; dtp->u.p.ufdtio_ptr (dest, &unit, child_iostat, child_iomsg, 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)) + { + char message[IOMSG_LEN]; + + /* 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; + } + snprintf (message, child_iomsg_len, child_iomsg); + generate_error (&dtp->common, dtp->u.p.child_saved_iostat, + message); + } + return; } @@ -1250,7 +1271,27 @@ unformatted_write (st_parameter_dt *dtp, bt type, dtp->u.p.current_unit->child_dtio++; dtp->u.p.ufdtio_ptr (source, &unit, child_iostat, child_iomsg, 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)) + { + char message[IOMSG_LEN]; + + /* 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; + } + snprintf (message, child_iomsg_len, child_iomsg); + generate_error (&dtp->common, dtp->u.p.child_saved_iostat, + message); + } return; } @@ -1730,8 +1771,28 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist, child_iostat, child_iomsg, 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)) + { + char message[IOMSG_LEN]; + + /* 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; + } + snprintf (message, child_iomsg_len, child_iomsg); + generate_error (&dtp->common, dtp->u.p.child_saved_iostat, + message); + } + if (f->u.udf.string_len != 0) free (iotype); /* Note: vlist is freed in free_format_data. */ @@ -2214,8 +2275,28 @@ formatted_transfer_scalar_write (st_parameter_dt *dtp, bt type, void *p, int kin dtp->u.p.fdtio_ptr (p, &unit, iotype, f->u.udf.vlist, child_iostat, child_iomsg, 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)) + { + char message[IOMSG_LEN]; + + /* 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; + } + snprintf (message, child_iomsg_len, child_iomsg); + generate_error (&dtp->common, dtp->u.p.child_saved_iostat, + message); + } + if (f->u.udf.string_len != 0) free (iotype); /* Note: vlist is freed in free_format_data. */ diff --git a/libgfortran/io/write.c b/libgfortran/io/write.c index 1a7c12345f9..d91a64d947b 100644 --- a/libgfortran/io/write.c +++ b/libgfortran/io/write.c @@ -1991,7 +1991,27 @@ list_formatted_write_scalar (st_parameter_dt *dtp, bt type, void *p, int kind, dtp->u.p.fdtio_ptr (p, &unit, iotype, &vlist, child_iostat, child_iomsg, 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)) + { + char message[IOMSG_LEN]; + + /* 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; + } + snprintf (message, child_iomsg_len, child_iomsg); + generate_error (&dtp->common, dtp->u.p.child_saved_iostat, + message); + } } break; default: @@ -2330,8 +2350,28 @@ nml_write_obj (st_parameter_dt *dtp, namelist_info *obj, index_type offset, child_iostat, child_iomsg, 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)) + { + char message[IOMSG_LEN]; + + /* 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; + } + snprintf (message, child_iomsg_len, child_iomsg); + generate_error (&dtp->common, dtp->u.p.child_saved_iostat, + message); + } + goto obj_loop; }