From 8f0d39a86b963ad0d39edb2e7bf633b5790432fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fran=C3=A7ois-Xavier=20Coudert?= Date: Sun, 19 Feb 2006 21:31:02 +0000 Subject: [PATCH] re PR libfortran/21303 (L edit descriptor without a width) PR libfortran/21303 * gfortran.h (notification): New enumeration. (gfc_notification_std): Prototype for the new function. * error.c (gfc_notification_std): New function. * io.c (check_format): Handle the case of a L format descriptor without a width. * runtime/error.c (notification_std): New function. * libgfortran.h (notification): New enumeration. * io/io.h (notification_std): Prototype for the new function. * io/format.c (parse_format_list): Handle the case of a L format descriptor without a width. * gcc/testsuite/gfortran.dg/fmt_l.f90: New test. From-SVN: r111281 --- gcc/fortran/error.c | 20 ++++++++- gcc/fortran/gfortran.h | 9 ++++ gcc/fortran/io.c | 22 ++++++++- gcc/testsuite/gfortran.dg/fmt_l.f90 | 69 +++++++++++++++++++++++++++++ libgfortran/io/format.c | 15 +++++-- libgfortran/io/io.h | 5 ++- libgfortran/libgfortran.h | 7 +++ libgfortran/runtime/error.c | 19 ++++++++ 8 files changed, 158 insertions(+), 8 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/fmt_l.f90 diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index aa23330020c0..4c82c4a5498a 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -1,6 +1,6 @@ /* Handle errors. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, - Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software + Foundation, Inc. Contributed by Andy Vaught & Niels Kristian Bech Jensen This file is part of GCC. @@ -483,6 +483,22 @@ gfc_warning (const char *nocmsgid, ...) } +/* Whether, for a feature included in a given standard set (GFC_STD_*), + we should issue an error or a warning, or be quiet. */ + +notification +gfc_notification_std (int std) +{ + bool warning; + + warning = ((gfc_option.warn_std & std) != 0) && !inhibit_warnings; + if ((gfc_option.allow_std & std) != 0 && !warning) + return SILENT; + + return warning ? WARNING : ERROR; +} + + /* Possibly issue a warning/error about use of a nonstandard (or deleted) feature. An error/warning will be issued if the currently selected standard does not contain the requested bits. Return FAILURE if diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index aa6698085cda..17e97779653d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -129,6 +129,14 @@ typedef enum { SUCCESS = 1, FAILURE } try; +/* This is returned by gfc_notification_std to know if, given the flags + that were given (-std=, -pedantic) we should issue an error, a warning + or nothing. */ + +typedef enum +{ SILENT, WARNING, ERROR } +notification; + /* Matchers return one of these three values. The difference between MATCH_NO and MATCH_ERROR is that MATCH_ERROR means that a match was successful, but that something non-syntactic is wrong and an error @@ -1737,6 +1745,7 @@ void gfc_internal_error (const char *, ...) ATTRIBUTE_NORETURN ATTRIBUTE_GCC_GFC void gfc_clear_error (void); int gfc_error_check (void); +notification gfc_notification_std (int); try gfc_notify_std (int, const char *, ...) ATTRIBUTE_GCC_GFC(2,3); /* A general purpose syntax error. */ diff --git a/gcc/fortran/io.c b/gcc/fortran/io.c index 618d056ce79c..b45e983a045f 100644 --- a/gcc/fortran/io.c +++ b/gcc/fortran/io.c @@ -569,8 +569,26 @@ data_desc: if (t == FMT_POSINT) break; - error = posint_required; - goto syntax; + switch (gfc_notification_std (GFC_STD_GNU)) + { + case WARNING: + gfc_warning + ("Extension: Missing positive width after L descriptor at %C"); + saved_token = t; + break; + + case ERROR: + error = posint_required; + goto syntax; + + case SILENT: + saved_token = t; + break; + + default: + gcc_unreachable (); + } + break; case FMT_A: t = format_lex (); diff --git a/gcc/testsuite/gfortran.dg/fmt_l.f90 b/gcc/testsuite/gfortran.dg/fmt_l.f90 new file mode 100644 index 000000000000..e03f63d8b3b0 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/fmt_l.f90 @@ -0,0 +1,69 @@ +! { dg-do run } +! { dg-options "-std=gnu -pedantic -ffree-line-length-none" } +! Test the GNU extension of a L format descriptor without width +! PR libfortran/21303 +program test_l + logical(kind=1) :: l1 + logical(kind=2) :: l2 + logical(kind=4) :: l4 + logical(kind=8) :: l8 + + character(len=20) :: str + + l1 = .true. + write (str,"(L)") l1 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l1 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l1 .neqv. .true.) call abort + + l2 = .true. + write (str,"(L)") l2 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l2 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l2 .neqv. .true.) call abort + + l4 = .true. + write (str,"(L)") l4 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l4 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l4 .neqv. .true.) call abort + + l8 = .true. + write (str,"(L)") l8 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l8 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l8 .neqv. .true.) call abort + + l1 = .false. + write (str,"(L)") l1 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l1 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l1 .neqv. .false.) call abort + + l2 = .false. + write (str,"(L)") l2 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l2 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l2 .neqv. .false.) call abort + + l4 = .false. + write (str,"(L)") l4 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l4 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l4 .neqv. .false.) call abort + + l8 = .false. + write (str,"(L)") l8 ! { dg-warning "Extension: Missing positive width after L descriptor" } + read (str,"(L)") l8 ! { dg-warning "Extension: Missing positive width after L descriptor" } + if (l8 .neqv. .false.) call abort + +end program test_l +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } +! { dg-output "Fortran runtime warning: Positive width required in format\n" } diff --git a/libgfortran/io/format.c b/libgfortran/io/format.c index 23ea3175dc41..9528dbad277e 100644 --- a/libgfortran/io/format.c +++ b/libgfortran/io/format.c @@ -1,4 +1,4 @@ -/* Copyright (C) 2002, 2003, 2004, 2005 +/* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -662,8 +662,17 @@ parse_format_list (st_parameter_dt *dtp) t = format_lex (fmt); if (t != FMT_POSINT) { - fmt->error = posint_required; - goto finished; + if (notification_std(GFC_STD_GNU) == ERROR) + { + fmt->error = posint_required; + goto finished; + } + else + { + fmt->saved_token = t; + fmt->value = 1; /* Default width */ + notify_std(GFC_STD_GNU, posint_required); + } } get_fnode (fmt, &head, &tail, FMT_L); diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index 0d2d795e1988..9b35ef916507 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -1,4 +1,4 @@ -/* Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. +/* Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of the GNU Fortran 95 runtime library (libgfortran). @@ -843,6 +843,9 @@ internal_proto(list_formatted_write); extern try notify_std (int, const char *); internal_proto(notify_std); +extern notification notification_std(int); +internal_proto(notification_std); + /* size_from_kind.c */ extern size_t size_from_real_kind (int); internal_proto(size_from_real_kind); diff --git a/libgfortran/libgfortran.h b/libgfortran/libgfortran.h index f1a1a3e7e1c7..524c57e37bcf 100644 --- a/libgfortran/libgfortran.h +++ b/libgfortran/libgfortran.h @@ -404,6 +404,13 @@ error_codes; #define GFC_FPE_UNDERFLOW (1<<4) #define GFC_FPE_PRECISION (1<<5) +/* This is returned by notification_std to know if, given the flags + that were given (-std=, -pedantic) we should issue an error, a warning + or nothing. */ +typedef enum +{ SILENT, WARNING, ERROR } +notification; + /* The filename and line number don't go inside the globals structure. They are set by the rest of the program and must be linked to. */ diff --git a/libgfortran/runtime/error.c b/libgfortran/runtime/error.c index b25cd0c8c160..e102449cec51 100644 --- a/libgfortran/runtime/error.c +++ b/libgfortran/runtime/error.c @@ -498,6 +498,25 @@ generate_error (st_parameter_common *cmp, int family, const char *message) } +/* Whether, for a feature included in a given standard set (GFC_STD_*), + we should issue an error or a warning, or be quiet. */ + +notification +notification_std (int std) +{ + int warning; + + if (!compile_options.pedantic) + return SILENT; + + warning = compile_options.warn_std & std; + if ((compile_options.allow_std & std) != 0 && !warning) + return SILENT; + + return warning ? WARNING : ERROR; +} + + /* Possibly issue a warning/error about use of a nonstandard (or deleted) feature. An error/warning will be issued if the currently selected