Commit 88a8126a by Janne Blomqvist

fortran/89100: Default widths with -fdec-format-defaults

gcc/fortran ChangeLog:

2019-05-22  Jeff Law  <law@redhat.com>
            Mark Eggleston  <mark.eggleston@codethink.com>

        PR fortran/89100
        * gfortran.texi: Add Default widths for F, G and I format
        descriptors to Extensions section.
        * invoke.texi: Add -fdec-format-defaults
        * io.c (check_format): Use default widths for i, f and g when
        flag_dec_format_defaults is enabled.
        * lang.opt: Add new option.
        * options.c (set_dec_flags): Add SET_BITFLAG for
        flag_dec_format_defaults.


gcc/testsuite ChangeLog:

2019-05-22  Mark Eggleston  <mark.eggleston@codethink.com>

        PR fortran/89100
        * gfortran.dg/fmt_f_default_field_width_1.f90: New test.
        * gfortran.dg/fmt_f_default_field_width_2.f90: New test.
        * gfortran.dg/fmt_f_default_field_width_3.f90: New test.
        * gfortran.dg/fmt_g_default_field_width_1.f90: New test.
        * gfortran.dg/fmt_g_default_field_width_2.f90: New test.
        * gfortran.dg/fmt_g_default_field_width_3.f90: New test.
        * gfortran.dg/fmt_i_default_field_width_1.f90: New test.
        * gfortran.dg/fmt_i_default_field_width_2.f90: New test.
        * gfortran.dg/fmt_i_default_field_width_3.f90: New test.


libgfortran ChangeLog:

2019-05-22  Jeff Law  <law@redhat.com>

        PR fortran/89100
        * io/format.c (parse_format_list): set default width when the
        IOPARM_DT_DEC_EXT flag is set for i, f and g.
        * io/io.h: add default_width_for_integer, default_width_for_float
        and default_precision_for_float.
        * io/write.c (write_boz): extra parameter giving length of data
        corresponding to the type's kind.
        (write_b): pass data length as extra parameter in calls to
        write_boz.
        (write_o): pass data length as extra parameter in calls to
        write_boz.
        (write_z): pass data length as extra parameter in calls to
        write_boz.
        (size_from_kind): also set size is default width is set.
        * io/write_float.def (build_float_string): new paramter inserted
        before result parameter. If default width use values passed
        instead of the values in fnode.
        (FORMAT_FLOAT): macro modified to check for default width and
        calls to build_float_string to pass in default width.
        (get_float_string): set width and precision to defaults when
        needed.

From-SVN: r271511
parent fa70c221
2019-05-22 Jeff Law <law@redhat.com>
Mark Eggleston <mark.eggleston@codethink.com>
PR fortran/89100
* gfortran.texi: Add Default widths for F, G and I format
descriptors to Extensions section.
* invoke.texi: Add -fdec-format-defaults
* io.c (check_format): Use default widths for i, f and g when
flag_dec_format_defaults is enabled.
* lang.opt: Add new option.
* options.c (set_dec_flags): Add SET_BITFLAG for
flag_dec_format_defaults.
2019-05-21 Janne Blomqvist <jb@gcc.gnu.org> 2019-05-21 Janne Blomqvist <jb@gcc.gnu.org>
PR libfortran/90038 PR libfortran/90038
......
...@@ -1576,6 +1576,7 @@ additional compatibility extensions along with those enabled by ...@@ -1576,6 +1576,7 @@ additional compatibility extensions along with those enabled by
* X format descriptor without count field:: * X format descriptor without count field::
* Commas in FORMAT specifications:: * Commas in FORMAT specifications::
* Missing period in FORMAT specifications:: * Missing period in FORMAT specifications::
* Default widths for F@comma{} G and I format descriptors::
* I/O item lists:: * I/O item lists::
* @code{Q} exponent-letter:: * @code{Q} exponent-letter::
* BOZ literal constants:: * BOZ literal constants::
...@@ -1782,6 +1783,22 @@ discouraged. ...@@ -1782,6 +1783,22 @@ discouraged.
10 FORMAT ('F4') 10 FORMAT ('F4')
@end smallexample @end smallexample
@node Default widths for F@comma{} G and I format descriptors
@subsection Default widths for @code{F}, @code{G} and @code{I} format descriptors
To support legacy codes, GNU Fortran allows width to be omitted from format
specifications if and only if @option{-fdec-format-defaults} is given on the
command line. Default widths will be used. This is considered non-conforming
code and is discouraged.
@smallexample
REAL :: value1
INTEGER :: value2
WRITE(*,10) value1, value1, value2
10 FORMAT ('F, G, I')
@end smallexample
@node I/O item lists @node I/O item lists
@subsection I/O item lists @subsection I/O item lists
@cindex I/O item lists @cindex I/O item lists
......
...@@ -117,16 +117,16 @@ by type. Explanations are in the following sections. ...@@ -117,16 +117,16 @@ by type. Explanations are in the following sections.
@item Fortran Language Options @item Fortran Language Options
@xref{Fortran Dialect Options,,Options controlling Fortran dialect}. @xref{Fortran Dialect Options,,Options controlling Fortran dialect}.
@gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol @gccoptlist{-fall-intrinsics -fbackslash -fcray-pointer -fd-lines-as-code @gol
-fd-lines-as-comments @gol -fd-lines-as-comments -fdec -fdec-structure -fdec-intrinsic-ints @gol
-fdec -fdec-structure -fdec-intrinsic-ints -fdec-static -fdec-math @gol -fdec-static -fdec-math -fdec-include -fdec-format-defaults @gol
-fdec-include -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 @gol -fdefault-double-8 -fdefault-integer-8 -fdefault-real-8 -fdefault-real-10 @gol
-fdefault-real-10 -fdefault-real-16 -fdollar-ok -ffixed-line-length-@var{n} @gol -fdefault-real-16 -fdollar-ok -ffixed-line-length-@var{n} @gol
-ffixed-line-length-none -fpad-source -ffree-form -ffree-line-length-@var{n} @gol -ffixed-line-length-none -fpad-source -ffree-form @gol
-ffree-line-length-none -fimplicit-none -finteger-4-integer-8 @gol -ffree-line-length-@var{n} -ffree-line-length-none @gol
-fmax-identifier-length -fmodule-private -ffixed-form -fno-range-check @gol -fimplicit-none -finteger-4-integer-8 -fmax-identifier-length @gol
-fopenacc -fopenmp -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 @gol -fmodule-private -ffixed-form -fno-range-check -fopenacc -fopenmp @gol
-freal-8-real-10 -freal-8-real-16 -freal-8-real-4 -std=@var{std} -freal-4-real-10 -freal-4-real-16 -freal-4-real-8 -freal-8-real-10 @gol
-ftest-forall-temp -freal-8-real-16 -freal-8-real-4 -std=@var{std} -ftest-forall-temp
} }
@item Preprocessing Options @item Preprocessing Options
...@@ -283,6 +283,11 @@ Enable parsing of INCLUDE as a statement in addition to parsing it as ...@@ -283,6 +283,11 @@ Enable parsing of INCLUDE as a statement in addition to parsing it as
INCLUDE line. When parsed as INCLUDE statement, INCLUDE does not have to INCLUDE line. When parsed as INCLUDE statement, INCLUDE does not have to
be on a single line and can use line continuations. be on a single line and can use line continuations.
@item -fdec-format-defaults
@opindex @code{fdec-format-defaults}
Enable format specifiers F, G and I to be used without width specifiers,
default widths will be used instead.
@item -fdollar-ok @item -fdollar-ok
@opindex @code{fdollar-ok} @opindex @code{fdollar-ok}
@cindex @code{$} @cindex @code{$}
......
...@@ -903,6 +903,13 @@ data_desc: ...@@ -903,6 +903,13 @@ data_desc:
if (u != FMT_POSINT) if (u != FMT_POSINT)
{ {
if (flag_dec_format_defaults)
{
/* Assume a default width based on the variable size. */
saved_token = u;
break;
}
format_locus.nextc += format_string_pos; format_locus.nextc += format_string_pos;
gfc_error ("Positive width required in format " gfc_error ("Positive width required in format "
"specifier %s at %L", token_to_string (t), "specifier %s at %L", token_to_string (t),
...@@ -1027,6 +1034,13 @@ data_desc: ...@@ -1027,6 +1034,13 @@ data_desc:
goto fail; goto fail;
if (t != FMT_ZERO && t != FMT_POSINT) if (t != FMT_ZERO && t != FMT_POSINT)
{ {
if (flag_dec_format_defaults)
{
/* Assume the default width is expected here and continue lexing. */
value = 0; /* It doesn't matter what we set the value to here. */
saved_token = t;
break;
}
error = nonneg_required; error = nonneg_required;
goto syntax; goto syntax;
} }
...@@ -1096,9 +1110,18 @@ data_desc: ...@@ -1096,9 +1110,18 @@ data_desc:
goto fail; goto fail;
if (t != FMT_ZERO && t != FMT_POSINT) if (t != FMT_ZERO && t != FMT_POSINT)
{ {
if (flag_dec_format_defaults)
{
/* Assume the default width is expected here and continue lexing. */
value = 0; /* It doesn't matter what we set the value to here. */
saved_token = t;
}
else
{
error = nonneg_required; error = nonneg_required;
goto syntax; goto syntax;
} }
}
else if (is_input && t == FMT_ZERO) else if (is_input && t == FMT_ZERO)
{ {
error = posint_required; error = posint_required;
...@@ -4369,7 +4392,7 @@ get_io_list: ...@@ -4369,7 +4392,7 @@ get_io_list:
/* See if we want to use defaults for missing exponents in real transfers /* See if we want to use defaults for missing exponents in real transfers
and other DEC runtime extensions. */ and other DEC runtime extensions. */
if (flag_dec) if (flag_dec_format_defaults)
dt->dec_ext = 1; dt->dec_ext = 1;
/* A full IO statement has been matched. Check the constraints. spec_end is /* A full IO statement has been matched. Check the constraints. spec_end is
......
...@@ -452,6 +452,10 @@ fdec-include ...@@ -452,6 +452,10 @@ fdec-include
Fortran Var(flag_dec_include) Fortran Var(flag_dec_include)
Enable legacy parsing of INCLUDE as statement. Enable legacy parsing of INCLUDE as statement.
fdec-format-defaults
Fortran Var(flag_dec_format_defaults)
Enable default widths for i, f and g format specifiers.
fdec-intrinsic-ints fdec-intrinsic-ints
Fortran Var(flag_dec_intrinsic_ints) Fortran Var(flag_dec_intrinsic_ints)
Enable kind-specific variants of integer intrinsic functions. Enable kind-specific variants of integer intrinsic functions.
......
...@@ -74,6 +74,7 @@ set_dec_flags (int value) ...@@ -74,6 +74,7 @@ set_dec_flags (int value)
SET_BITFLAG (flag_dec_static, value, value); SET_BITFLAG (flag_dec_static, value, value);
SET_BITFLAG (flag_dec_math, value, value); SET_BITFLAG (flag_dec_math, value, value);
SET_BITFLAG (flag_dec_include, value, value); SET_BITFLAG (flag_dec_include, value, value);
SET_BITFLAG (flag_dec_format_defaults, value, value);
} }
/* Finalize DEC flags. */ /* Finalize DEC flags. */
......
2019-05-22 Mark Eggleston <mark.eggleston@codethink.com>
PR fortran/89100
* gfortran.dg/fmt_f_default_field_width_1.f90: New test.
* gfortran.dg/fmt_f_default_field_width_2.f90: New test.
* gfortran.dg/fmt_f_default_field_width_3.f90: New test.
* gfortran.dg/fmt_g_default_field_width_1.f90: New test.
* gfortran.dg/fmt_g_default_field_width_2.f90: New test.
* gfortran.dg/fmt_g_default_field_width_3.f90: New test.
* gfortran.dg/fmt_i_default_field_width_1.f90: New test.
* gfortran.dg/fmt_i_default_field_width_2.f90: New test.
* gfortran.dg/fmt_i_default_field_width_3.f90: New test.
2019-05-22 Martin Liska <mliska@suse.cz> 2019-05-22 Martin Liska <mliska@suse.cz>
PR testsuite/90564 PR testsuite/90564
......
! { dg-do run }
! { dg-options -fdec }
!
! Test case for the default field widths enabled by the -fdec-format-defaults flag.
!
! This feature is not part of any Fortran standard, but it is supported by the
! Oracle Fortran compiler and others.
!
program test
character(50) :: buffer
real(4) :: real_4
real(8) :: real_8
real(16) :: real_16
integer :: len
character(*), parameter :: fmt = "(A, F, A)"
real_4 = 4.18
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 4.1799998:") stop 1
real_4 = 0.00000018
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 0.0000002:") stop 2
real_8 = 4.18
write(buffer, fmt) ':',real_8,':'
print *,buffer
len = len_trim(buffer)
if (len /= 27) stop 3
real_16 = 4.18
write(buffer, fmt) ':',real_16,':'
print *,buffer
len = len_trim(buffer)
if (len /= 44) stop 4
end
! { dg-do run }
! { dg-options -fdec-format-defaults }
!
! Test case for the default field widths enabled by the -fdec-format-defaults flag.
!
! This feature is not part of any Fortran standard, but it is supported by the
! Oracle Fortran compiler and others.
!
! Test case added by Mark Eggleston <mark.eggleston@codethink.com> to check
! use of -fdec-format-defaults
!
program test
character(50) :: buffer
real(4) :: real_4
real(8) :: real_8
real(16) :: real_16
integer :: len
character(*), parameter :: fmt = "(A, F, A)"
real_4 = 4.18
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 4.1799998:") stop 1
real_4 = 0.00000018
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 0.0000002:") stop 2
real_8 = 4.18
write(buffer, fmt) ':',real_8,':'
print *,buffer
len = len_trim(buffer)
if (len /= 27) stop 3
real_16 = 4.18
write(buffer, fmt) ':',real_16,':'
print *,buffer
len = len_trim(buffer)
if (len /= 44) stop 4
end
! { dg-do compile }
! { dg-options "-fdec -fno-dec-format-defaults" }
!
! Test case for the default field widths not enabled.
!
! Test case added by Mark Eggleston <mark.eggleston@codethink.com> to check
! use of -fno-dec-format-defaults
!
program test
character(50) :: buffer
real*4 :: real_4
real*8 :: real_8
real*16 :: real_16
integer :: len
character(*), parameter :: fmt = "(A, F, A)"
real_4 = 4.18
write(buffer, fmt) ':',real_4,':' ! { dg-error "Nonnegative width required" }
real_4 = 0.00000018
write(buffer, fmt) ':',real_4,':' ! { dg-error "Nonnegative width required" }
real_8 = 4.18
write(buffer, fmt) ':',real_8,':' ! { dg-error "Nonnegative width required" }
real_16 = 4.18
write(buffer, fmt) ':',real_16,':' ! { dg-error "Nonnegative width required" }
end
! { dg-do run }
! { dg-options -fdec }
!
! Test case for the default field widths enabled by the -fdec-format-defaults flag.
!
! This feature is not part of any Fortran standard, but it is supported by the
! Oracle Fortran compiler and others.
!
program test
character(50) :: buffer
real(4) :: real_4
real(8) :: real_8
real(16) :: real_16
integer :: len
character(*), parameter :: fmt = "(A, G, A)"
real_4 = 4.18
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 4.180000 :") stop 1
real_4 = 0.00000018
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 0.1800000E-06:") stop 2
real_4 = 18000000.4
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 0.1800000E+08:") stop 3
real_8 = 4.18
write(buffer, fmt) ':',real_8,':'
print *,buffer
len = len_trim(buffer)
if (len /= 27) stop 4
real_16 = 4.18
write(buffer, fmt) ':',real_16,':'
print *,buffer
len = len_trim(buffer)
if (len /= 44) stop 5
end
! { dg-do run }
! { dg-options -fdec-format-defaults }
!
! Test case for the default field widths enabled by the -fdec-format-defaults flag.
!
! This feature is not part of any Fortran standard, but it is supported by the
! Oracle Fortran compiler and others.
!
! Test case added by Mark Eggleston <mark.eggleston@codethink.com> to check
! use of -fdec-format-defaults
!
program test
character(50) :: buffer
real(4) :: real_4
real(8) :: real_8
real(16) :: real_16
integer :: len
character(*), parameter :: fmt = "(A, G, A)"
real_4 = 4.18
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 4.180000 :") stop 1
real_4 = 0.00000018
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 0.1800000E-06:") stop 2
real_4 = 18000000.4
write(buffer, fmt) ':',real_4,':'
print *,buffer
if (buffer.ne.": 0.1800000E+08:") stop 3
real_8 = 4.18
write(buffer, fmt) ':',real_8,':'
print *,buffer
len = len_trim(buffer)
if (len /= 27) stop 4
real_16 = 4.18
write(buffer, fmt) ':',real_16,':'
print *,buffer
len = len_trim(buffer)
if (len /= 44) stop 5
end
! { dg-do compile }
! { dg-options "-fdec -fno-dec-format-defaults" }
!
! Test case for the default field widths not enabled.
!
! Test case added by Mark Eggleston <mark.eggleston@codethink.com> to check
! use of -fno-dec-format-defaults
!
program test
character(50) :: buffer
real(4) :: real_4
real(8) :: real_8
real(16) :: real_16
integer :: len
character(*), parameter :: fmt = "(A, G, A)"
real_4 = 4.18
write(buffer, fmt) ':',real_4,':' ! { dg-error "Positive width required" }
real_4 = 0.00000018
write(buffer, fmt) ':',real_4,':' ! { dg-error "Positive width required" }
real_4 = 18000000.4
write(buffer, fmt) ':',real_4,':' ! { dg-error "Positive width required" }
real_8 = 4.18
write(buffer, fmt) ':',real_8,':' ! { dg-error "Positive width required" }
real_16 = 4.18
write(buffer, fmt) ':',real_16,':' ! { dg-error "Positive width required" }
end
! { dg-do run }
! { dg-options -fdec }
!
! Test case for the default field widths enabled by the -fdec-format-defaults flag.
!
! This feature is not part of any Fortran standard, but it is supported by the
! Oracle Fortran compiler and others.
program test
character(50) :: buffer
character(1) :: colon
integer(2) :: integer_2
integer(4) :: integer_4
integer(8) :: integer_8
character(*), parameter :: fmt = "(A, I, A)"
write(buffer, fmt) ':',12340,':'
print *,buffer
if (buffer.ne.": 12340:") stop 1
read(buffer, "(1A, I, 1A)") colon, integer_4, colon
if ((integer_4.ne.12340).or.(colon.ne.":")) stop 2
integer_2 = -99
write(buffer, fmt) ':',integer_2,':'
print *,buffer
if (buffer.ne.": -99:") stop 3
integer_8 = -11112222
write(buffer, fmt) ':',integer_8,':'
print *,buffer
if (buffer.ne.": -11112222:") stop 4
! If the width is 7 and there are 7 leading zeroes, the result should be zero.
integer_2 = 789
buffer = '0000000789'
read(buffer, '(I)') integer_2
if (integer_2.ne.0) stop 5
end
! { dg-do run }
! { dg-options -fdec-format-defaults }
!
! Test case for the default field widths enabled by the -fdec-format-defaults flag.
!
! This feature is not part of any Fortran standard, but it is supported by the
! Oracle Fortran compiler and others.
!
! Test case added by Mark Eggleston <mark.eggleston@codethink.com> to check
! use of -fdec-format-defaults
!
program test
character(50) :: buffer
character(1) :: colon
integer(2) :: integer_2
integer(4) :: integer_4
integer(8) :: integer_8
character(*), parameter :: fmt = "(A, I, A)"
write(buffer, fmt) ':',12340,':'
print *,buffer
if (buffer.ne.": 12340:") stop 1
read(buffer, '(A1, I, A1)') colon, integer_4, colon
if ((integer_4.ne.12340).or.(colon.ne.":")) stop 2
integer_2 = -99
write(buffer, fmt) ':',integer_2,':'
print *,buffer
if (buffer.ne.": -99:") stop 3
integer_8 = -11112222
write(buffer, fmt) ':',integer_8,':'
print *,buffer
if (buffer.ne.": -11112222:") stop 4
! If the width is 7 and there are 7 leading zeroes, the result should be zero.
integer_2 = 789
buffer = '0000000789'
read(buffer, '(I)') integer_2
if (integer_2.ne.0) stop 5
end
! { dg-do compile }
! { dg-options "-fdec -fno-dec-format-defaults" }
!
! Test case for the default field widths enabled by the -fdec-format-defaults flag.
!
! This feature is not part of any Fortran standard, but it is supported by the
! Oracle Fortran compiler and others.
!
! Test case added by Mark Eggleston <mark.eggleston@codethink.com> to check
! use of -fdec-format-defaults
!
program test
character(50) :: buffer
character(1) :: colon
integer(2) :: integer_2
integer(4) :: integer_4
integer(8) :: integer_8
character(*), parameter :: fmt = "(A, I, A)"
write(buffer, fmt) ':',12340,':' ! { dg-error "Nonnegative width required" }
read(buffer, '(A1, I, A1)') colon, integer_4, colon ! { dg-error "Nonnegative width required" }
if (integer_4.ne.12340) stop 2
integer_2 = -99
write(buffer, fmt) ':',integer_2,':' ! { dg-error "Nonnegative width required" }
integer_8 = -11112222
write(buffer, fmt) ':',integer_8,':' ! { dg-error "Nonnegative width required" }
! If the width is 7 and there are 7 leading zeroes, the result should be zero.
integer_2 = 789
buffer = '0000000789'
read(buffer, '(I)') integer_2 ! { dg-error "Nonnegative width required" }
end
2019-05-22 Jeff Law <law@redhat.com>
PR fortran/89100
* io/format.c (parse_format_list): set default width when the
IOPARM_DT_DEC_EXT flag is set for i, f and g.
* io/io.h: add default_width_for_integer, default_width_for_float
and default_precision_for_float.
* io/write.c (write_boz): extra parameter giving length of data
corresponding to the type's kind.
(write_b): pass data length as extra parameter in calls to
write_boz.
(write_o): pass data length as extra parameter in calls to
write_boz.
(write_z): pass data length as extra parameter in calls to
write_boz.
(size_from_kind): also set size is default width is set.
* io/write_float.def (build_float_string): new paramter inserted
before result parameter. If default width use values passed
instead of the values in fnode.
(FORMAT_FLOAT): macro modified to check for default width and
calls to build_float_string to pass in default width.
(get_float_string): set width and precision to defaults when
needed.
2019-05-19 Janne Blomqvist <jb@gcc.gnu.org> 2019-05-19 Janne Blomqvist <jb@gcc.gnu.org>
PR libfortran/90038 PR libfortran/90038
......
...@@ -956,12 +956,33 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) ...@@ -956,12 +956,33 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
*seen_dd = true; *seen_dd = true;
if (u != FMT_POSINT && u != FMT_ZERO) if (u != FMT_POSINT && u != FMT_ZERO)
{ {
if (dtp->common.flags & IOPARM_DT_DEC_EXT)
{
tail->u.real.w = DEFAULT_WIDTH;
tail->u.real.d = 0;
tail->u.real.e = -1;
fmt->saved_token = u;
break;
}
fmt->error = nonneg_required; fmt->error = nonneg_required;
goto finished; goto finished;
} }
} }
else if (u == FMT_ZERO)
{
fmt->error = posint_required;
goto finished;
}
else if (u != FMT_POSINT) else if (u != FMT_POSINT)
{ {
if (dtp->common.flags & IOPARM_DT_DEC_EXT)
{
tail->u.real.w = DEFAULT_WIDTH;
tail->u.real.d = 0;
tail->u.real.e = -1;
fmt->saved_token = u;
break;
}
fmt->error = posint_required; fmt->error = posint_required;
goto finished; goto finished;
} }
...@@ -1100,6 +1121,13 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) ...@@ -1100,6 +1121,13 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
{ {
if (t != FMT_POSINT) if (t != FMT_POSINT)
{ {
if (dtp->common.flags & IOPARM_DT_DEC_EXT)
{
tail->u.integer.w = DEFAULT_WIDTH;
tail->u.integer.m = -1;
fmt->saved_token = t;
break;
}
fmt->error = posint_required; fmt->error = posint_required;
goto finished; goto finished;
} }
...@@ -1108,6 +1136,13 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd) ...@@ -1108,6 +1136,13 @@ parse_format_list (st_parameter_dt *dtp, bool *seen_dd)
{ {
if (t != FMT_ZERO && t != FMT_POSINT) if (t != FMT_ZERO && t != FMT_POSINT)
{ {
if (dtp->common.flags & IOPARM_DT_DEC_EXT)
{
tail->u.integer.w = DEFAULT_WIDTH;
tail->u.integer.m = -1;
fmt->saved_token = t;
break;
}
fmt->error = nonneg_required; fmt->error = nonneg_required;
goto finished; goto finished;
} }
......
...@@ -1011,6 +1011,56 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k) ...@@ -1011,6 +1011,56 @@ memset4 (gfc_char4_t *p, gfc_char4_t c, int k)
*p++ = c; *p++ = c;
} }
/* Used in width fields to indicate that the default should be used */
#define DEFAULT_WIDTH -1
/* Defaults for certain format field descriptors. These are decided based on
* the type of the value being formatted.
*
* The behaviour here is modelled on the Oracle Fortran compiler. At the time
* of writing, the details were available at this URL:
*
* https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnc3/index.html#z4000743746d
*/
static inline int
default_width_for_integer (int kind)
{
switch (kind)
{
case 1:
case 2: return 7;
case 4: return 12;
case 8: return 23;
case 16: return 44;
default: return 0;
}
}
static inline int
default_width_for_float (int kind)
{
switch (kind)
{
case 4: return 15;
case 8: return 25;
case 16: return 42;
default: return 0;
}
}
static inline int
default_precision_for_float (int kind)
{
switch (kind)
{
case 4: return 7;
case 8: return 16;
case 16: return 33;
default: return 0;
}
}
#endif #endif
extern void extern void
......
...@@ -635,6 +635,12 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length) ...@@ -635,6 +635,12 @@ read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
w = f->u.w; w = f->u.w;
/* This is a legacy extension, and the frontend will only allow such cases
* through when -fdec-format-defaults is passed.
*/
if (w == DEFAULT_WIDTH)
w = default_width_for_integer (length);
p = read_block_form (dtp, &w); p = read_block_form (dtp, &w);
if (p == NULL) if (p == NULL)
......
...@@ -685,9 +685,8 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len) ...@@ -685,9 +685,8 @@ write_l (st_parameter_dt *dtp, const fnode *f, char *source, int len)
p[wlen - 1] = (n) ? 'T' : 'F'; p[wlen - 1] = (n) ? 'T' : 'F';
} }
static void static void
write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n) write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n, int len)
{ {
int w, m, digits, nzero, nblank; int w, m, digits, nzero, nblank;
char *p; char *p;
...@@ -720,6 +719,9 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n) ...@@ -720,6 +719,9 @@ write_boz (st_parameter_dt *dtp, const fnode *f, const char *q, int n)
/* Select a width if none was specified. The idea here is to always /* Select a width if none was specified. The idea here is to always
print something. */ print something. */
if (w == DEFAULT_WIDTH)
w = default_width_for_integer (len);
if (w == 0) if (w == 0)
w = ((digits < m) ? m : digits); w = ((digits < m) ? m : digits);
...@@ -846,6 +848,8 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source, ...@@ -846,6 +848,8 @@ write_decimal (st_parameter_dt *dtp, const fnode *f, const char *source,
/* Select a width if none was specified. The idea here is to always /* Select a width if none was specified. The idea here is to always
print something. */ print something. */
if (w == DEFAULT_WIDTH)
w = default_width_for_integer (len);
if (w == 0) if (w == 0)
w = ((digits < m) ? m : digits) + nsign; w = ((digits < m) ? m : digits) + nsign;
...@@ -1206,13 +1210,13 @@ write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len) ...@@ -1206,13 +1210,13 @@ write_b (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{ {
p = btoa_big (source, itoa_buf, len, &n); p = btoa_big (source, itoa_buf, len, &n);
write_boz (dtp, f, p, n); write_boz (dtp, f, p, n, len);
} }
else else
{ {
n = extract_uint (source, len); n = extract_uint (source, len);
p = btoa (n, itoa_buf, sizeof (itoa_buf)); p = btoa (n, itoa_buf, sizeof (itoa_buf));
write_boz (dtp, f, p, n); write_boz (dtp, f, p, n, len);
} }
} }
...@@ -1227,13 +1231,13 @@ write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len) ...@@ -1227,13 +1231,13 @@ write_o (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{ {
p = otoa_big (source, itoa_buf, len, &n); p = otoa_big (source, itoa_buf, len, &n);
write_boz (dtp, f, p, n); write_boz (dtp, f, p, n, len);
} }
else else
{ {
n = extract_uint (source, len); n = extract_uint (source, len);
p = otoa (n, itoa_buf, sizeof (itoa_buf)); p = otoa (n, itoa_buf, sizeof (itoa_buf));
write_boz (dtp, f, p, n); write_boz (dtp, f, p, n, len);
} }
} }
...@@ -1247,13 +1251,13 @@ write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len) ...@@ -1247,13 +1251,13 @@ write_z (st_parameter_dt *dtp, const fnode *f, const char *source, int len)
if (len > (int) sizeof (GFC_UINTEGER_LARGEST)) if (len > (int) sizeof (GFC_UINTEGER_LARGEST))
{ {
p = ztoa_big (source, itoa_buf, len, &n); p = ztoa_big (source, itoa_buf, len, &n);
write_boz (dtp, f, p, n); write_boz (dtp, f, p, n, len);
} }
else else
{ {
n = extract_uint (source, len); n = extract_uint (source, len);
p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf)); p = gfc_xtoa (n, itoa_buf, sizeof (itoa_buf));
write_boz (dtp, f, p, n); write_boz (dtp, f, p, n, len);
} }
} }
...@@ -1491,7 +1495,7 @@ size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind) ...@@ -1491,7 +1495,7 @@ size_from_kind (st_parameter_dt *dtp, const fnode *f, int kind)
{ {
int size; int size;
if (f->format == FMT_F && f->u.real.w == 0) if ((f->format == FMT_F && f->u.real.w == 0) || f->u.real.w == DEFAULT_WIDTH)
{ {
switch (kind) switch (kind)
{ {
......
...@@ -113,7 +113,8 @@ determine_precision (st_parameter_dt * dtp, const fnode * f, int len) ...@@ -113,7 +113,8 @@ determine_precision (st_parameter_dt * dtp, const fnode * f, int len)
static void static void
build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer, build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
size_t size, int nprinted, int precision, int sign_bit, size_t size, int nprinted, int precision, int sign_bit,
bool zero_flag, int npad, char *result, size_t *len) bool zero_flag, int npad, int default_width, char *result,
size_t *len)
{ {
char *put; char *put;
char *digits; char *digits;
...@@ -132,8 +133,17 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer, ...@@ -132,8 +133,17 @@ build_float_string (st_parameter_dt *dtp, const fnode *f, char *buffer,
sign_t sign; sign_t sign;
ft = f->format; ft = f->format;
if (f->u.real.w == DEFAULT_WIDTH)
/* This codepath can only be reached with -fdec-format-defaults. */
{
w = default_width;
d = precision;
}
else
{
w = f->u.real.w; w = f->u.real.w;
d = f->u.real.d; d = f->u.real.d;
}
p = dtp->u.p.scale_factor; p = dtp->u.p.scale_factor;
*len = 0; *len = 0;
...@@ -960,6 +970,11 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f, ...@@ -960,6 +970,11 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
int save_scale_factor;\ int save_scale_factor;\
volatile GFC_REAL_ ## x temp;\ volatile GFC_REAL_ ## x temp;\
save_scale_factor = dtp->u.p.scale_factor;\ save_scale_factor = dtp->u.p.scale_factor;\
if (w == DEFAULT_WIDTH)\
{\
w = default_width;\
d = precision;\
}\
switch (dtp->u.p.current_unit->round_status)\ switch (dtp->u.p.current_unit->round_status)\
{\ {\
case ROUND_ZERO:\ case ROUND_ZERO:\
...@@ -1035,7 +1050,8 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f, ...@@ -1035,7 +1050,8 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
nprinted = FDTOA(y,precision,m);\ nprinted = FDTOA(y,precision,m);\
}\ }\
build_float_string (dtp, &newf, buffer, size, nprinted, precision,\ build_float_string (dtp, &newf, buffer, size, nprinted, precision,\
sign_bit, zero_flag, npad, result, res_len);\ sign_bit, zero_flag, npad, default_width,\
result, res_len);\
dtp->u.p.scale_factor = save_scale_factor;\ dtp->u.p.scale_factor = save_scale_factor;\
}\ }\
else\ else\
...@@ -1045,7 +1061,8 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f, ...@@ -1045,7 +1061,8 @@ determine_en_precision (st_parameter_dt *dtp, const fnode *f,
else\ else\
nprinted = DTOA(y,precision,m);\ nprinted = DTOA(y,precision,m);\
build_float_string (dtp, f, buffer, size, nprinted, precision,\ build_float_string (dtp, f, buffer, size, nprinted, precision,\
sign_bit, zero_flag, npad, result, res_len);\ sign_bit, zero_flag, npad, default_width,\
result, res_len);\
}\ }\
}\ }\
...@@ -1059,6 +1076,16 @@ get_float_string (st_parameter_dt *dtp, const fnode *f, const char *source, ...@@ -1059,6 +1076,16 @@ get_float_string (st_parameter_dt *dtp, const fnode *f, const char *source,
{ {
int sign_bit, nprinted; int sign_bit, nprinted;
bool zero_flag; bool zero_flag;
int default_width = 0;
if (f->u.real.w == DEFAULT_WIDTH)
/* This codepath can only be reached with -fdec-format-defaults. The default
* values are based on those used in the Oracle Fortran compiler.
*/
{
default_width = default_width_for_float (kind);
precision = default_precision_for_float (kind);
}
switch (kind) switch (kind)
{ {
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment