From patchwork Wed Jun 3 20:42:47 2026 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Jerry D X-Patchwork-Id: 136421 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from vm01.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 6D3D34BA2E2A for ; Wed, 3 Jun 2026 20:43:43 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 6D3D34BA2E2A Authentication-Results: sourceware.org; dkim=pass (2048-bit key, unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256 header.s=20251104 header.b=cBMw2S5Y X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pj1-x102f.google.com (mail-pj1-x102f.google.com [IPv6:2607:f8b0:4864:20::102f]) by sourceware.org (Postfix) with ESMTPS id 050034BA5436 for ; Wed, 3 Jun 2026 20:42:50 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 050034BA5436 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 050034BA5436 Authentication-Results: sourceware.org; arc=none smtp.remote-ip=2607:f8b0:4864:20::102f ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1780519370; cv=none; b=DYScagO/SycByJgIW3FG3eR+gd2t6v6PcE/c0z/zs+818j9PwUKwdo61ftqtCuP71xYMb8HNgAhyW2enxhFA54PGPQ/ml9oBDuahXy+1SG177iZjZw5x/bKxXDLormPfEkANoZulGXADFbHEbsRaN/2/u/DfK86hQj3ZBf1vRhg= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1780519370; c=relaxed/simple; bh=0FD3jJi53Ra0iW4Ighd4+XX5Xhg19ZqIaj9KoKtnQBo=; h=DKIM-Signature:Message-ID:Date:MIME-Version:To:From:Subject; b=cZUanb3CxPkRqqiqoJkHryE5zstTsJNrxt8FZOXyMrrBCKPDAR44VADBfEiokzp/76oLHnV8By/i8djQ6ZDwnxorlHSkwJvtF/V49RGMXtH5hzh62h1ylqOtyL8vZs3srB2KD2MLtPuo/GPgxdMVHlw280fjc+jeAubf7sUPbb0= ARC-Authentication-Results: i=1; sourceware.org; dkim=pass (2048-bit key, unprotected) header.d=gmail.com header.i=@gmail.com header.a=rsa-sha256 header.s=20251104 header.b=cBMw2S5Y DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 050034BA5436 Received: by mail-pj1-x102f.google.com with SMTP id 98e67ed59e1d1-36c68964315so2888722a91.2 for ; Wed, 03 Jun 2026 13:42:49 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20251104; t=1780519369; x=1781124169; darn=gcc.gnu.org; h=autocrypt:subject:from:to:content-language:user-agent:mime-version :date:message-id:from:to:cc:subject:date:message-id:reply-to; bh=c9rhO4AA7pFNRwS8eOm/WQ9QWwNbkYRXchN58klw0rc=; b=cBMw2S5Y7Yc6ELt2uwSP7XcDBB94Sts+v8MAzm6DedKejRbNlKvUq8O2y/lZE0BH0+ OyeNlvj87ZTrOHbv0mLl1ocjuFGRfxGK3szQPbwmG6yfLkQRyQK7reNLrOZexnO8Awbq ZqYXGATdM9J8j50UL262axxYNMD452cULs2jbpjalvpxjbNLdGT80nLfAbRdRglKp9OS ugxJzzIVtNZlah6T5DEs2qYdJx/Tx8Aa+c3i45nETjgcoLC2y9ROzCPkV+uRQoX82yyB FJRk/3prE31E2ZFrhIYG9iSA7FZFFSRpfU4Xd3iOVqv8DIJn1HxtPIagWLkRSa4q4d8L o2Ng== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20251104; t=1780519369; x=1781124169; h=autocrypt:subject:from:to:content-language:user-agent:mime-version :date:message-id:x-gm-gg:x-gm-message-state:from:to:cc:subject:date :message-id:reply-to; bh=c9rhO4AA7pFNRwS8eOm/WQ9QWwNbkYRXchN58klw0rc=; b=rVYuFlsXrH/B5jQw7eKm+t1WX/XICy9jeR6HFus0YWvKANstGwNTvxBLpHScHvfNvM c5heBvaZ6yIyU46inVXra/EBqyaj9DiTKb8kadQIClEU+zj0OUDVNtsj7m8V+FworYkb 80eVLAM00dfogqLS9OfrgoQ84yxbp/PfsJjgeFu9eRvy/UqSedC3i7L6OywDWUjfghB3 ev9QqzPNOXPVFH/m5agZABbIXyaTsgjtuO2kjNXITZPN5B88bidj/hOkAXvmMVPMykGn jtAvl6H+/osUR/z9RcTqneVhSRvt1ybTeuiDvT4xvu4yajgiPJu8+9gljZMu2wsToKhi Ve9A== X-Forwarded-Encrypted: i=1; AFNElJ/qcjtLAXqihQ4+yMrUF5bq+BcGgep/4grmQlgxbyleabOjGJkyqsMKbOhk6MXocep4ugLZPigFt1r6cA==@gcc.gnu.org X-Gm-Message-State: AOJu0Yz2GsEqMBUVfSaTIq0jrjeEhS9QEt7XIU8erht6iGrAopTjpiXp qC/syHcsk0b48suJS+2YjMnHFWBadbu6H66V5OQGqUKf3g0DwZ/dMyQh X-Gm-Gg: Acq92OHd7Coyuci2rvEN+CNecuD9+gRhlivsIf7te/TVN0z9eWsx5SHkeoDL1cSWaIF kVKE+ZAepSNDttcOBRAskvCbSRu8jVhj1zQiwEttkohlRE04QI3Uy80LQYajdYJhFmnex7vh1i/ 9eq9pPZZKgaX7u333TjvpBLGGmAhHfhQx2WcHGu0cX4kLzdXDZ2OurpWGT27TwOAtKz9/zpEE+Q kCHZ9U/F62MZNJTF68w3z6CjSKvnH+GFUq3dfUIYV3gO0lmN4TIb99SuZZm3UrP2PzNwOj0JbOw 8DoF3OmrM2NN93S93isDUo1Z/mL+ZMMC0gL/B0Y//eat9R8/tekduV+5d3e/Yrz4+p1jiPi5fhm ngJSMaKgSIYc0cN9ExjcVwsXt9Q+2v3a9GTb6QhI+NUgSOuSPzIKQqPJQfpo5Rad4zHpoPQo4fY ICamybm4bhBsJ2Q+2niLc5KTYXVGrk94fDg94dukUI/aSlorep X-Received: by 2002:a17:90b:268e:b0:369:e217:d110 with SMTP id 98e67ed59e1d1-36e3486bc55mr4831633a91.27.1780519368858; Wed, 03 Jun 2026 13:42:48 -0700 (PDT) Received: from [10.168.168.66] ([50.37.179.80]) by smtp.gmail.com with ESMTPSA id 98e67ed59e1d1-36f6bf830b2sm568043a91.4.2026.06.03.13.42.47 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Wed, 03 Jun 2026 13:42:48 -0700 (PDT) Message-ID: Date: Wed, 3 Jun 2026 13:42:47 -0700 MIME-Version: 1.0 User-Agent: Mozilla Thunderbird Content-Language: en-US To: gfortran , gcc-patches From: Jerry D Subject: [PATCH] Fortran: [PR93727] Add EX format READ (read_ex) 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.7 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 shortcircuit=no autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on 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 The following implements the last of the EX formatting work. The attached patch has been regression tested on x86_64. The test case provided round trip testing to ensure what we read is what we wrote. OK for mainline? Best regards, Jerry --- Fortran: [PR93727] Add EX format READ (read_ex) Implement read_ex in libgfortran to handle EX edit-descriptor input per Fortran 2023 13.7.2.3.6. The input field may contain: * a hexadecimal-significand form (0XP) passed directly to the C strtod/strtold family for exact bit-for-bit conversion; * any form acceptable for Fw.d input (decimal fallback), including INF and NAN representations. For decimal input without a decimal point the d field of the EX.w.d descriptor adjusts the exponent exactly as for Fw.d. BN/BZ blank handling and the kP scale factor are also supported via the shared decimal path. Assisted by: Claude Sonnet 4.6 PR fortran/93727 libgfortran/ChangeLog: * io/read.c (read_ex): New function implementing EX format read. * io/io.h (read_ex): Declare. * io/transfer.c (formatted_transfer_scalar_read): Add FMT_EX case dispatching to read_ex. gcc/testsuite/ChangeLog: * gfortran.dg/EXformat_4.F90: New test covering EX format read for kind=4 and 8 (always) and kind=10, 16 (when available): hex-significand literals, lowercase prefix, negative binary exponent, decimal fallback, d-field adjustment, INF/NAN, zero field, and round-trips through write_ex. --- From ac5caffca8de75c6ad6026d930c1bc8a38ee0452 Mon Sep 17 00:00:00 2001 From: Jerry DeLisle Date: Mon, 25 May 2026 21:13:19 -0700 Subject: [PATCH] Fortran: [PR93727] Add EX format READ (read_ex) Implement read_ex in libgfortran to handle EX edit-descriptor input per Fortran 2023 13.7.2.3.6. The input field may contain: * a hexadecimal-significand form (0XP) passed directly to the C strtod/strtold family for exact bit-for-bit conversion; * any form acceptable for Fw.d input (decimal fallback), including INF and NAN representations. For decimal input without a decimal point the d field of the EX.w.d descriptor adjusts the exponent exactly as for Fw.d. BN/BZ blank handling and the kP scale factor are also supported via the shared decimal path. Assisted by: Claude Sonnet 4.6 PR fortran/93727 libgfortran/ChangeLog: * io/read.c (read_ex): New function implementing EX format read. * io/io.h (read_ex): Declare. * io/transfer.c (formatted_transfer_scalar_read): Add FMT_EX case dispatching to read_ex. gcc/testsuite/ChangeLog: * gfortran.dg/EXformat_4.F90: New test covering EX format read for kind=4 and 8 (always) and kind=10, 16 (when available): hex-significand literals, lowercase prefix, negative binary exponent, decimal fallback, d-field adjustment, INF/NAN, zero field, and round-trips through write_ex. --- gcc/testsuite/gfortran.dg/EXformat_4.F90 | 172 +++++++++++ libgfortran/io/io.h | 3 + libgfortran/io/read.c | 358 +++++++++++++++++++++++ libgfortran/io/transfer.c | 8 + 4 files changed, 541 insertions(+) create mode 100644 gcc/testsuite/gfortran.dg/EXformat_4.F90 diff --git a/gcc/testsuite/gfortran.dg/EXformat_4.F90 b/gcc/testsuite/gfortran.dg/EXformat_4.F90 new file mode 100644 index 00000000000..c90857ac3e7 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/EXformat_4.F90 @@ -0,0 +1,172 @@ +! { dg-do run } +! PR93727 Test EX format READ (read_ex). +! Covers: hex-significand input (0X...P...), decimal fallback, round-trips, +! INF/NAN, and all supported real kinds. +program main + implicit none + call test04 + call test08 + call test10 + call test16 + +contains + +subroutine test04 + real(kind=4) :: r4 + character(kind=1,len=40) :: s + + ! Round-trip: write then read back. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_4) + read(s,'(EX40.0)') r4 + if (r4 /= -huge(1.0_4)) stop 1 + + s = ' ' + write(s,'(EX0.0)') tiny(1.0_4) + read(s,'(EX40.0)') r4 + if (r4 /= tiny(1.0_4)) stop 2 + + ! Explicit hex literal input. + s = '0X1.8P+0' ! = 1.5 exactly + read(s,'(EX40.0)') r4 + if (r4 /= 1.5_4) stop 3 + + s = '-0X1.P+0' ! = -1.0 + read(s,'(EX40.0)') r4 + if (r4 /= -1.0_4) stop 4 + + ! Decimal fallback: no 0X prefix, ordinary E-style input. + s = '1.5E0' + read(s,'(EX40.0)') r4 + if (r4 /= 1.5_4) stop 5 + + s = ' 1.5E2 ' + read(s,'(EX40.0)') r4 + if (r4 /= 150.0_4) stop 6 + + ! Zero field (blank record). + s = ' ' + read(s,'(EX4.0)') r4 + if (r4 /= 0.0_4) stop 7 + +end subroutine test04 + + +subroutine test08 + real(kind=8) :: r8 + character(kind=1,len=40) :: s + + ! Round-trip. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_8) + read(s,'(EX40.0)') r8 + if (r8 /= -huge(1.0_8)) stop 8 + + s = ' ' + write(s,'(EX0.0)') tiny(1.0_8) + read(s,'(EX40.0)') r8 + if (r8 /= tiny(1.0_8)) stop 9 + + ! Explicit hex: IEEE 754 representation of 1/3. + s = '0X1.5555555555555P-2' + read(s,'(EX40.0)') r8 + if (r8 /= 1.0_8 / 3.0_8) stop 10 + + ! Negative hex. + s = '-0X1.8P+0' ! = -1.5 + read(s,'(EX40.0)') r8 + if (r8 /= -1.5_8) stop 11 + + ! Decimal fallback. + s = '3.14159265358979E0' + read(s,'(EX40.0)') r8 + if (abs(r8 - 3.14159265358979_8) > 2.0_8 * epsilon(r8)) stop 12 + + ! Round-trip on an interesting value. + s = ' ' + write(s,'(EX0.0)') -3.14159265358979_8 * 25.0_8 + read(s,'(EX40.0)') r8 + if (r8 /= -3.14159265358979_8 * 25.0_8) stop 13 + + ! Lowercase hex prefix and negative binary exponent. + s = '0x1.8p-1' ! = 0.75 + read(s,'(EX40.0)') r8 + if (r8 /= 0.75_8) stop 14 + + ! d-field: no decimal point in decimal input; d=2 places from right. + s = '12345 ' + read(s,'(EX10.2)') r8 + if (r8 /= 123.45_8) stop 15 + + ! INF and NaN input via decimal fallback path. + s = 'Inf' + read(s,'(EX40.0)') r8 + if (r8 <= huge(r8)) stop 16 + + s = '-Infinity' + read(s,'(EX40.0)') r8 + if (r8 >= -huge(r8)) stop 17 + + s = 'NaN' + read(s,'(EX40.0)') r8 + if (r8 == r8) stop 18 + +end subroutine test08 + + +#ifdef __GFC_REAL_10__ +subroutine test10 + real(kind=10) :: r10 + character(kind=1,len=40) :: s + + ! Round-trip. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_10) + read(s,'(EX40.0)') r10 + if (r10 /= -huge(1.0_10)) stop 19 + + s = ' ' + write(s,'(EX0.0)') tiny(1.0_10) + read(s,'(EX40.0)') r10 + if (r10 /= tiny(1.0_10)) stop 20 + + ! Explicit hex: 1.5 = 0X1.8P+0 + s = '0X1.8P+0' + read(s,'(EX40.0)') r10 + if (r10 /= 1.5_10) stop 21 + +end subroutine test10 +#else +subroutine test10 +end subroutine test10 +#endif + + +#ifdef __GFC_REAL_16__ +subroutine test16 + real(kind=16) :: r16 + character(kind=1,len=40) :: s + + ! Round-trip. + s = ' ' + write(s,'(EX0.0)') -huge(1.0_16) + read(s,'(EX40.0)') r16 + if (r16 /= -huge(1.0_16)) stop 22 + + s = ' ' + write(s,'(EX0.0)') tiny(1.0_16) + read(s,'(EX40.0)') r16 + if (r16 /= tiny(1.0_16)) stop 23 + + ! Explicit hex: 1.5 = 0X1.8P+0 + s = '0X1.8P+0' + read(s,'(EX40.0)') r16 + if (r16 /= 1.5_16) stop 24 + +end subroutine test16 +#else +subroutine test16 +end subroutine test16 +#endif + +end program main diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 1fd0908859f..d131d9544c4 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -887,6 +887,9 @@ internal_proto(read_a); extern void read_f (st_parameter_dt *, const fnode *, char *, int); internal_proto(read_f); +extern void read_ex (st_parameter_dt *, const fnode *, char *, int); +internal_proto(read_ex); + extern void read_l (st_parameter_dt *, const fnode *, char *, int); internal_proto(read_l); diff --git a/libgfortran/io/read.c b/libgfortran/io/read.c index aeec725684b..047fff11643 100644 --- a/libgfortran/io/read.c +++ b/libgfortran/io/read.c @@ -1525,6 +1525,364 @@ bad_float: } +/* read_ex()-- Read a floating-point number with EX editing. + Per Fortran 2023 13.7.2.3.6 para 3, the input form is the same as for + Fw.d editing (13.7.2.3.2). That includes the hexadecimal-significand + form (13.7.2.3.2 para 7): [sign] 0X [hex-significand] P [decimal-exp]. + Decimal mantissas and IEEE exceptional forms (INF, NAN) are also + accepted. Embedded blanks are not permitted within a hex float; C + strtod handles the 0x...p... form natively. */ + +void +read_ex (st_parameter_dt *dtp, const fnode *f, char *dest, int length) +{ +#define READEX_TMP 64 + char tmp[READEX_TMP]; + size_t buf_size = 0; + size_t w; + int seen_dp, exponent; + int exponent_sign; + const char *p; + char *buffer; + char *out; + int seen_int_digit; + int seen_dec_digit; + + seen_dp = 0; + seen_int_digit = 0; + seen_dec_digit = 0; + exponent_sign = 1; + exponent = 0; + w = f->u.real.w; + buffer = tmp; + + p = read_block_form (dtp, &w); + if (p == NULL) + return; + p = eat_leading_spaces (&w, (char *) p); + if (w == 0) + goto zero; + + buf_size = w + 11; + if (buf_size > READEX_TMP) + buffer = xmalloc (buf_size); + + out = buffer; + + /* Optional sign. */ + if (*p == '-' || *p == '+') + { + if (*p == '-') + *(out++) = '-'; + ++p; + --w; + } + + p = eat_leading_spaces (&w, (char *) p); + if (w == 0) + { + if (buf_size > READEX_TMP) + free (buffer); + goto zero; + } + + /* IEEE exceptional specification: INF or NAN. */ + if (unlikely (w >= 3 && (*p == 'i' || *p == 'I' || *p == 'n' || *p == 'N'))) + { + int seen_paren = 0; + char *save = out; + + while (w > 0) + { + *out = safe_tolower (*p); + switch (*p) + { + case ' ': + if (dtp->u.p.blank_status == BLANK_ZERO) + { + *out = '0'; + break; + } + *out = '\0'; + if (seen_paren == 1) + goto bad_float; + break; + case '(': + seen_paren++; + *out = '\0'; + break; + case ')': + if (seen_paren++ != 1) + goto bad_float; + break; + default: + if (!safe_isalnum (*out)) + goto bad_float; + } + --w; + ++p; + ++out; + } + + *out = '\0'; + + if (seen_paren != 0 && seen_paren != 2) + goto bad_float; + + if ((strcmp (save, "inf") == 0) || (strcmp (save, "infinity") == 0)) + { + if (seen_paren) + goto bad_float; + } + else if (strcmp (save, "nan") != 0) + goto bad_float; + + convert_infnan (dtp, dest, buffer, length); + if (buf_size > READEX_TMP) + free (buffer); + return; + } + + /* Hexadecimal-significand number: 0X or 0x prefix. + Embedded blanks are forbidden; we stop at the first blank and let + convert_real report an error if the string is malformed. */ + if (w >= 2 && *p == '0' && (p[1] == 'x' || p[1] == 'X')) + { + while (w > 0 && *p != ' ') + { + *(out++) = *p++; + --w; + } + *(out++) = '\0'; + + convert_real (dtp, dest, buffer, length); + if (buf_size > READEX_TMP) + free (buffer); + return; + } + + /* Decimal floating-point fallback: same rules as Fw.d editing. */ + while (w > 0) + { + switch (*p) + { + case ',': + if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA) + goto bad_float; + if (seen_dp) + goto bad_float; + if (!seen_int_digit) + *(out++) = '0'; + *(out++) = '.'; + seen_dp = 1; + break; + + case '.': + if (dtp->u.p.current_unit->decimal_status != DECIMAL_POINT) + goto bad_float; + if (seen_dp) + goto bad_float; + if (!seen_int_digit) + *(out++) = '0'; + *(out++) = '.'; + seen_dp = 1; + break; + + case ' ': + if (dtp->u.p.blank_status == BLANK_ZERO) + { + *(out++) = '0'; + goto found_digit; + } + else if (dtp->u.p.blank_status == BLANK_NULL) + break; + else + goto done; + /* Fall through. */ + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + *(out++) = *p; +found_digit: + if (!seen_dp) + seen_int_digit = 1; + else + seen_dec_digit = 1; + break; + + case '-': + case '+': + goto exponent; + + case 'e': + case 'E': + case 'd': + case 'D': + case 'q': + case 'Q': + ++p; + --w; + goto exponent; + + default: + goto bad_float; + } + + ++p; + --w; + } + + /* No exponent seen; apply the scale factor. */ + exponent = -dtp->u.p.scale_factor; + goto done; + +exponent: + p = eat_leading_spaces (&w, (char *) p); + if (*p == '-' || *p == '+') + { + if (*p == '-') + exponent_sign = -1; + ++p; + --w; + } + + if (w == 0) + { + if (dtp->common.flags & IOPARM_DT_DEC_EXT) + goto done; + else + goto bad_float; + } + + if (dtp->u.p.blank_status == BLANK_UNSPECIFIED) + { + while (w > 0 && safe_isdigit (*p)) + { + exponent *= 10; + exponent += *p - '0'; + ++p; + --w; + } + while (w > 0) + { + if (*p != ' ') + goto bad_float; + ++p; + --w; + } + } + else + { + while (w > 0) + { + if (*p == ' ') + { + if (dtp->u.p.blank_status == BLANK_ZERO) + exponent *= 10; + else + assert (dtp->u.p.blank_status == BLANK_NULL); + } + else if (!safe_isdigit (*p)) + goto bad_float; + else + { + exponent *= 10; + exponent += *p - '0'; + } + ++p; + --w; + } + } + + exponent *= exponent_sign; + +done: + if (!seen_dp) + exponent -= f->u.real.d; + + if (seen_dp && !seen_dec_digit) + *(out++) = '0'; + else if (!seen_int_digit && !seen_dec_digit) + { + notify_std (&dtp->common, GFC_STD_LEGACY, + "REAL input of style 'E+NN'"); + *(out++) = '0'; + } + + if (exponent != 0) + { + int dig; + + *(out++) = 'e'; + if (exponent < 0) + { + *(out++) = '-'; + exponent = -exponent; + } + + if (exponent >= 10000) + goto bad_float; + + for (dig = 3; dig >= 0; --dig) + { + out[dig] = (char) ('0' + exponent % 10); + exponent /= 10; + } + out += 4; + } + *(out++) = '\0'; + + convert_real (dtp, dest, buffer, length); + if (buf_size > READEX_TMP) + free (buffer); + return; + +zero: + switch (length) + { + case 4: + *((GFC_REAL_4 *) dest) = 0.0; + break; + case 8: + *((GFC_REAL_8 *) dest) = 0.0; + break; +#ifdef HAVE_GFC_REAL_10 + case 10: + *((GFC_REAL_10 *) dest) = 0.0; + break; +#endif +#ifdef HAVE_GFC_REAL_16 + case 16: + *((GFC_REAL_16 *) dest) = 0.0; + break; +#endif +#ifdef HAVE_GFC_REAL_17 + case 17: + *((GFC_REAL_17 *) dest) = 0.0; + break; +#endif + default: + internal_error (&dtp->common, "Unsupported real kind during IO"); + } + return; + +bad_float: + if (buf_size > READEX_TMP) + free (buffer); + generate_error (&dtp->common, LIBERROR_READ_VALUE, + "Bad value during floating point read"); + next_record (dtp, 1); + return; +} + + /* read_x()-- Deal with the X/TR descriptor. We just read some data and never look at it. */ diff --git a/libgfortran/io/transfer.c b/libgfortran/io/transfer.c index 99e90f3c803..49b211ba667 100644 --- a/libgfortran/io/transfer.c +++ b/libgfortran/io/transfer.c @@ -1840,6 +1840,14 @@ formatted_transfer_scalar_read (st_parameter_dt *dtp, bt type, void *p, int kind read_f (dtp, f, p, kind); break; + case FMT_EX: + if (n == 0) + goto need_read_data; + if (require_type (dtp, BT_REAL, type, f)) + return; + read_ex (dtp, f, p, kind); + break; + case FMT_F: if (n == 0) goto need_read_data; -- 2.54.0