From 158f58e7d3865cf286b6ad8c2874c1029e2d7a03 Mon Sep 17 00:00:00 2001
From: fxcoudert <fxcoudert@138bc75d-0d04-0410-961f-82ee72b054a4>
Date: Sun, 19 Feb 2006 21:31:02 +0000
Subject: [PATCH] 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.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111281 138bc75d-0d04-0410-961f-82ee72b054a4
---
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
--
GitLab