OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Fortran: frontend code for F2018 QUIET specifier to STOP and ERROR STOP

Browse Source 
Fortran 2018 allows for a QUIET specifier to the STOP and ERROR STOP
statements.  Whilst the gfortran library code provides support for this
specifier for quite some time, the frontend implementation was missing.

gcc/fortran/ChangeLog:

	PR fortran/84519
	* dump-parse-tree.cc (show_code_node): Dump QUIET specifier when
	present.
	* match.cc (gfc_match_stopcode): Implement parsing of F2018 QUIET
	specifier.  F2018 stopcodes may have non-default integer kind.
	* resolve.cc (gfc_resolve_code): Add checks for QUIET argument.
	* trans-stmt.cc (gfc_trans_stop): Pass QUIET specifier to call of
	library function.

gcc/testsuite/ChangeLog:

	PR fortran/84519
	* gfortran.dg/stop_1.f90: New test.
	* gfortran.dg/stop_2.f: New test.
	* gfortran.dg/stop_3.f90: New test.
	* gfortran.dg/stop_4.f90: New test.
This commit is contained in:
Harald Anlauf 2022-02-23 23:08:29 +01:00
parent 8645370af1
commit 916b809fbf
8 changed files with 190 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/fortran/dump-parse-tree.cc
View File

@ -2370,6 +2370,11 @@ show_code_node (int level, gfc_code *c)
show_expr (c->expr1);
else
fprintf (dumpfile, "%d", c->ext.stop_code);
if (c->expr2 != NULL)
{
fputs (" QUIET=", dumpfile);
show_expr (c->expr2);
}
break;

64
gcc/fortran/match.cc
View File

@ -2978,6 +2978,13 @@ Fortran 2008 has
R856 allstop-stmt is ALL STOP [ stop-code ]
R857 stop-code is scalar-default-char-constant-expr
or scalar-int-constant-expr
Fortran 2018 has
R1160 stop-stmt is STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
R1161 error-stop-stmt is
ERROR STOP [ stop-code ] [ , QUIET = scalar-logical-expr]
R1162 stop-code is scalar-default-char-expr
or scalar-int-expr
For free-form source code, all standards contain a statement of the form:
@ -2994,8 +3001,10 @@ static match
gfc_match_stopcode (gfc_statement st)
{
gfc_expr *e = NULL;
gfc_expr *quiet = NULL;
match m;
bool f95, f03, f08;
char c;
/* Set f95 for -std=f95. */
f95 = (gfc_option.allow_std == GFC_STD_OPT_F95);
@ -3006,11 +3015,16 @@ gfc_match_stopcode (gfc_statement st)
/* Set f08 for -std=f2008. */
f08 = (gfc_option.allow_std == GFC_STD_OPT_F08);
/* Look for a blank between STOP and the stop-code for F2008 or later. */
if (gfc_current_form != FORM_FIXED && !(f95 || f03))
{
char c = gfc_peek_ascii_char ();
/* Plain STOP statement? */
if (gfc_match_eos () == MATCH_YES)
goto checks;
/* Look for a blank between STOP and the stop-code for F2008 or later.
But allow for F2018's ,QUIET= specifier. */
c = gfc_peek_ascii_char ();
if (gfc_current_form != FORM_FIXED && !(f95 || f03) && c != ',')
{
/* Look for end-of-statement. There is no stop-code. */
if (c == '\n' || c == '!' || c == ';')
goto done;
@ -3023,7 +3037,12 @@ gfc_match_stopcode (gfc_statement st)
}
}
if (gfc_match_eos () != MATCH_YES)
if (c == ' ')
{
gfc_gobble_whitespace ();
c = gfc_peek_ascii_char ();
}
if (c != ',')
{
int stopcode;
locus old_locus;
@ -3053,11 +3072,20 @@ gfc_match_stopcode (gfc_statement st)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
if (gfc_match_eos () != MATCH_YES)
goto syntax;
}
if (gfc_match (" , quiet = %e", &quiet) == MATCH_YES)
{
if (!gfc_notify_std (GFC_STD_F2018, "QUIET= specifier for %s at %L",
gfc_ascii_statement (st), &quiet->where))
goto cleanup;
}
if (gfc_match_eos () != MATCH_YES)
goto syntax;
checks:
if (gfc_pure (NULL))
{
if (st == ST_ERROR_STOP)
@ -3133,10 +3161,22 @@ gfc_match_stopcode (gfc_statement st)
goto cleanup;
}
if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind)
if (e->ts.type == BT_INTEGER && e->ts.kind != gfc_default_integer_kind
&& !gfc_notify_std (GFC_STD_F2018,
"STOP code at %L must be default integer KIND=%d",
&e->where, (int) gfc_default_integer_kind))
goto cleanup;
}
if (quiet != NULL)
{
if (!gfc_simplify_expr (quiet, 0))
goto cleanup;
if (quiet->rank != 0)
{
gfc_error ("STOP code at %L must be default integer KIND=%d",
&e->where, (int) gfc_default_integer_kind);
gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
&quiet->where);
goto cleanup;
}
}
@ -3159,6 +3199,7 @@ done:
}
new_st.expr1 = e;
new_st.expr2 = quiet;
new_st.ext.stop_code = -1;
return MATCH_YES;
@ -3169,6 +3210,7 @@ syntax:
cleanup:
gfc_free_expr (e);
gfc_free_expr (quiet);
return MATCH_ERROR;
}

9
gcc/fortran/resolve.cc
View File

@ -11944,8 +11944,17 @@ start:
case EXEC_END_NESTED_BLOCK:
case EXEC_CYCLE:
case EXEC_PAUSE:
break;
case EXEC_STOP:
case EXEC_ERROR_STOP:
if (code->expr2 != NULL
&& (code->expr2->ts.type != BT_LOGICAL
|| code->expr2->rank != 0))
gfc_error ("QUIET specifier at %L must be a scalar LOGICAL",
&code->expr2->where);
break;
case EXEC_EXIT:
case EXEC_CONTINUE:
case EXEC_DT_END:

15
gcc/fortran/trans-stmt.cc
View File

@ -652,11 +652,20 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
{
gfc_se se;
tree tmp;
tree quiet;
/* Start a new block for this statement. */
gfc_init_se (&se, NULL);
gfc_start_block (&se.pre);
if (code->expr2)
{
gfc_conv_expr_val (&se, code->expr2);
quiet = fold_convert (boolean_type_node, se.expr);
}
else
quiet = boolean_false_node;
if (code->expr1 == NULL)
{
tmp = build_int_cst (size_type_node, 0);
@ -669,7 +678,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
? gfor_fndecl_caf_stop_str
: gfor_fndecl_stop_string),
3, build_int_cst (pchar_type_node, 0), tmp,
boolean_false_node);
quiet);
}
else if (code->expr1->ts.type == BT_INTEGER)
{
@ -683,7 +692,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
? gfor_fndecl_caf_stop_numeric
: gfor_fndecl_stop_numeric), 2,
fold_convert (integer_type_node, se.expr),
boolean_false_node);
quiet);
}
else
{
@ -698,7 +707,7 @@ gfc_trans_stop (gfc_code *code, bool error_stop)
: gfor_fndecl_stop_string),
3, se.expr, fold_convert (size_type_node,
se.string_length),
boolean_false_node);
quiet);
}
gfc_add_expr_to_block (&se.pre, tmp);

44
gcc/testsuite/gfortran.dg/stop_1.f90 Normal file
View File

@ -0,0 +1,44 @@
! { dg-do compile }
! { dg-options "-std=f2018" }
implicit none
logical :: q = .false.
integer(2) :: p = 99
real :: x = 0.
character(5) :: s = "stopp"
print *, "Hello"
stop 1, quiet=.false.
stop 2, quiet=q
stop 3, quiet=f(x)
stop; stop!
stop ;stop 4!
stop 5; stop 6
stop 7 ;stop 8
stop 1_1; stop 2_2; stop 4_4; stop 8_8
stop&!
&;stop;&!
stop&!
s&
; stop "x";&!
; st&!
&op&!
p
stop s
if(f(x))then;stop 9,quiet=.false.;else;stop 10;endif
error stop 4, quiet=.true.
error stop 5 , quiet=.true.
error stop s, quiet=.true.
stop "last " // s, quiet=.false._2
stop, quiet=any([.false.])
stop , quiet=any([f(x)])
stop "stopp" , quiet=any([f(x)])
stop s, quiet=all([f(x)])
stop42, quiet=.false. ! { dg-error "Blank required" }
stop"stopp" , quiet=any([f(x)]) ! { dg-error "Blank required" }
stop 8, quiet=([f(x)]) ! { dg-error "must be a scalar LOGICAL" }
contains
logical function f(x)
real, intent(in) :: x
f = .false.
end function f
end

31
gcc/testsuite/gfortran.dg/stop_2.f Normal file
View File

@ -0,0 +1,31 @@
! { dg-do compile }
! { dg-options "-std=f2018" }
implicit none
logical :: q = .false.
integer(2) :: p = 99
real :: x = 0.
character(5) :: s = "stopp"
stop 1, quiet=.false.
stop 2, quiet=q
stop 3, quiet=f(x)
stop42,quiet=.false.
error stop 4, quiet=.true.
error stop 5 , quiet=.true.
stop1_1;stop2_2;stop4_4;stop8_8
stopp;stops
st
&op42
stop, quiet=any([.false.])
stop , quiet=any([f(x)])
stop"stopp",quiet=any([f(x)])
stop "stopp" , quiet=any([f(x)])
s to ps,quiet=all([f(x)])
e r r o r s t o p 4 3 , q u i e t = . t r u e .
errorstop"stopp",quiet=.not.f(x)
contains
logical function f(x)
real, intent(in) :: x
f = .false.
end function f
end

22
gcc/testsuite/gfortran.dg/stop_3.f90 Normal file
View File

@ -0,0 +1,22 @@
! { dg-do compile }
! { dg-options "-std=f2003" }
! F95 and F2003 do not require a blank after STOP
implicit none
integer, parameter :: p = 99
character(*), parameter :: s = "stopp"
stop1
stop2!
stop3;stop4!
stopp
stop&!
&;stop;&!
stop&!
s&
;stop"x";&!
;st&!
&op&!
p
stops
stop"last " // s
end

14
gcc/testsuite/gfortran.dg/stop_4.f90 Normal file
View File

@ -0,0 +1,14 @@
! { dg-do run }
! { dg-additional-options "-fdump-tree-original -std=f2018" }
! Check that the QUIET specifier to shut up a STOP statement is passed properly
program p
logical(1) :: q = .true. ! using kind=1 to simplify scanning of tree dump
stop 0, quiet=q
stop 1, quiet=.true.
stop 2 ! the "noisy" default
end program p
! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(0, q\\)" "original" } }
! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(1, 1\\)" "original" } }
! { dg-final { scan-tree-dump "_gfortran_stop_numeric \\(2, 0\\)" "original" } }