2012-08-08 Tobias Burnus <burnus@net-b.de>
PR fortran/40881
* error.c (gfc_notify_std): Reset cur_error_buffer->flag flag
when the error/warning has been printed.
* gfortran.h (gfc_sl_type): Add ST_LABEL_DO_TARGET and
ST_LABEL_ENDDO_TARGET.
* match.c (gfc_match_do): Use ST_LABEL_DO_TARGET.
* parse.c (check_statement_label): Use ST_LABEL_ENDDO_TARGET.
(parse_executable): Add obsolescence check for DATA.
* resolve.c (resolve_branch): Handle ST_LABEL_DO_TARGET.
* symbol.c (gfc_define_st_label, gfc_reference_st_label):
Add obsolescence diagnostics.
* trans-stmt.c (gfc_trans_label_assign): Handle ST_LABEL_DO_TARGET.
2012-08-08 Tobias Burnus <burnus@net-b.de>
PR fortran/40881
* gfortran.dg/data_constraints_3.f90: New.
* gfortran.dg/data_constraints_1.f90: Update dg-warning.
* gfortran.dg/pr37243.f: Ditto.
* gfortran.dg/g77/19990826-3.f: Ditto.
* gfortran.dg/g77/20020307-1.f : Ditto.
* gfortran.dg/g77/980310-3.f: Ditto.
@@ -875,6 +875,7 @@ gfc_notify_std (int std, const char *gmsgid, ...)
warnings++;
else
gfc_increment_error_count();
+ cur_error_buffer->flag = 0;
}
return (warning && !warnings_are_errors) ? SUCCESS : FAILURE;
@@ -146,8 +146,8 @@ ar_type;
/* Statement label types. */
typedef enum
-{ ST_LABEL_UNKNOWN = 1, ST_LABEL_TARGET,
- ST_LABEL_BAD_TARGET, ST_LABEL_FORMAT
+{ ST_LABEL_UNKNOWN = 1, ST_LABEL_TARGET, ST_LABEL_DO_TARGET,
+ ST_LABEL_ENDDO_TARGET, ST_LABEL_BAD_TARGET, ST_LABEL_FORMAT
}
gfc_sl_type;
@@ -2400,7 +2400,7 @@ gfc_match_do (void)
goto concurr_cleanup;
if (label != NULL
- && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
+ && gfc_reference_st_label (label, ST_LABEL_DO_TARGET) == FAILURE)
goto concurr_cleanup;
new_st.label1 = label;
@@ -2454,7 +2454,7 @@ concurr_cleanup:
done:
if (label != NULL
- && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE)
+ && gfc_reference_st_label (label, ST_LABEL_DO_TARGET) == FAILURE)
goto cleanup;
new_st.label1 = label;
@@ -1168,7 +1168,10 @@ check_statement_label (gfc_statement st)
case ST_END_ASSOCIATE:
case_executable:
case_exec_markers:
- type = ST_LABEL_TARGET;
+ if (st == ST_ENDDO || st == ST_CONTINUE)
+ type = ST_LABEL_ENDDO_TARGET;
+ else
+ type = ST_LABEL_TARGET;
break;
case ST_FORMAT:
@@ -3825,8 +3828,11 @@ parse_executable (gfc_statement st)
case ST_NONE:
unexpected_eof ();
- case ST_FORMAT:
case ST_DATA:
+ gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
+ "first executable statement");
+ /* Fall through. */
+ case ST_FORMAT:
case ST_ENTRY:
case_executable:
accept_statement (st);
@@ -8767,7 +8767,8 @@ resolve_branch (gfc_st_label *label, gfc_code *code)
return;
}
- if (label->defined != ST_LABEL_TARGET)
+ if (label->defined != ST_LABEL_TARGET
+ && label->defined != ST_LABEL_ENDDO_TARGET)
{
gfc_error ("Statement at %L is not a valid branch target statement "
"for the branch statement at %L", &label->where, &code->loc);
@@ -2204,7 +2204,8 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
switch (type)
{
case ST_LABEL_FORMAT:
- if (lp->referenced == ST_LABEL_TARGET)
+ if (lp->referenced == ST_LABEL_TARGET
+ || lp->referenced == ST_LABEL_DO_TARGET)
gfc_error ("Label %d at %C already referenced as branch target",
labelno);
else
@@ -2213,12 +2214,19 @@ gfc_define_st_label (gfc_st_label *lp, gfc_sl_type type, locus *label_locus)
break;
case ST_LABEL_TARGET:
+ case ST_LABEL_ENDDO_TARGET:
if (lp->referenced == ST_LABEL_FORMAT)
gfc_error ("Label %d at %C already referenced as a format label",
labelno);
else
lp->defined = ST_LABEL_TARGET;
+ if (lp->referenced == ST_LABEL_DO_TARGET
+ && type != ST_LABEL_ENDDO_TARGET
+ && gfc_notify_std (GFC_STD_F95_OBS, "DO termination statement "
+ "which is not END DO or CONTINUE with label "
+ "%d at %C", labelno) == FAILURE)
+ return;
break;
default:
@@ -2254,14 +2262,16 @@ gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
lp->where = gfc_current_locus;
}
- if (label_type == ST_LABEL_FORMAT && type == ST_LABEL_TARGET)
+ if (label_type == ST_LABEL_FORMAT
+ && (type == ST_LABEL_TARGET || type == ST_LABEL_DO_TARGET))
{
gfc_error ("Label %d at %C previously used as a FORMAT label", labelno);
rc = FAILURE;
goto done;
}
- if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_BAD_TARGET)
+ if ((label_type == ST_LABEL_TARGET || label_type == ST_LABEL_DO_TARGET
+ || label_type == ST_LABEL_BAD_TARGET)
&& type == ST_LABEL_FORMAT)
{
gfc_error ("Label %d at %C previously used as branch target", labelno);
@@ -2269,7 +2279,13 @@ gfc_reference_st_label (gfc_st_label *lp, gfc_sl_type type)
goto done;
}
- lp->referenced = type;
+ if (lp->referenced == ST_LABEL_DO_TARGET && type == ST_LABEL_DO_TARGET
+ && gfc_notify_std (GFC_STD_F95_OBS, "Shared DO termination label %d "
+ "at %C", labelno) == FAILURE)
+ return FAILURE;
+
+ if (lp->referenced != ST_LABEL_DO_TARGET)
+ lp->referenced = type;
rc = SUCCESS;
done:
@@ -109,7 +109,8 @@ gfc_trans_label_assign (gfc_code * code)
label_tree = gfc_get_label_decl (code->label1);
- if (code->label1->defined == ST_LABEL_TARGET)
+ if (code->label1->defined == ST_LABEL_TARGET
+ || code->label1->defined == ST_LABEL_ENDDO_TARGET)
{
label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
len_tree = integer_minus_one_node;
@@ -14,9 +14,10 @@
n = foo (n)
contains
function foo (m) result (bar)
- integer p (m), bar
+ integer p (m), bar, i
integer, allocatable :: l(:)
allocate (l(1))
+ data i /55/ ! { dg-warning "Obsolescent feature: DATA statement at .1. after the first executable statement" }
data l /42/ ! { dg-error "conflicts with ALLOCATABLE" }
data p(1) /1/ ! { dg-error "non-constant array in DATA" }
data q /1/ ! { dg-error "Host associated variable" }
@@ -13,10 +13,10 @@
DO 160 I = 1,M
DUMI = ZERO
DO 100 K = 1,N
- 100 DUMI = DUMI+V(K,I)*V(K,I)
+ 100 DUMI = DUMI+V(K,I)*V(K,I) ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
DUMI = ONE/ SQRT(DUMI)
DO 120 K = 1,N
- 120 V(K,I) = V(K,I)*DUMI
+ 120 V(K,I) = V(K,I)*DUMI ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
IF (I .EQ. M) GO TO 160
I1 = I+1
DO 140 J = I1,M
@@ -34,15 +34,15 @@
220 J = J+1
IF (J .GT. N) GO TO 320
DO 240 K = 1,N
- 240 V(K,I) = ZERO
+ 240 V(K,I) = ZERO ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
CALL DAXPY(N,DUM,V(1,I),1,V(1,I),1)
260 CONTINUE
DUMI = ZERO
DO 280 K = 1,N
- 280 DUMI = DUMI+V(K,I)*V(K,I)
+ 280 DUMI = DUMI+V(K,I)*V(K,I) ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
IF ( ABS(DUMI) .LT. TOL) GO TO 220
DO 300 K = 1,N
- 300 V(K,I) = V(K,I)*DUMI
+ 300 V(K,I) = V(K,I)*DUMI ! { dg-warning "Obsolescent feature: DO termination statement which is not END DO or CONTINUE" }
GO TO 200
320 END
program main
@@ -64,7 +64,7 @@ C
IF(M2.LT.64)INDE=5
IF(M2.LT.32)INDE=4
DO 3 NUN =3,INUN
- DO 3 NDE=3,INDE
+ DO 3 NDE=3,INDE ! { dg-warning "Obsolescent feature: Shared DO termination" }
N10=2**NUN
N20=2**NDE
NDIF=(N10-N20)
@@ -6,7 +6,7 @@ c { dg-do compile }
DIMENSION BNORM(MAXVEC),BINV(MAXVEC),WT(MAXVEC),W0(MAXVEC)
DIMENSION C1(MAXVEC),C2(MAXVEC),R1(MAXVEC),R2(MAXVEC)
DO 200 ILAT=1,2**IDIM
- DO 200 I1=1,IDIM
+ DO 200 I1=1,IDIM ! { dg-warning "Obsolescent feature: Shared DO termination" }
DO 220 I2=1,IDIM
CALL INTACT(ILAT,I1,I1,W1)
220 CONTINUE
@@ -128,7 +128,7 @@ c compute right side vector in resulting linear equations
c
basl = dlog10(2.0d0)
do 240 i = low,igh
- do 240 j = low,igh
+ do 240 j = low,igh ! { dg-warning "Obsolescent feature: Shared DO termination" }
tb = b(i,j)
ta = a(i,j)
if (ta .eq. 0.0d0) go to 220
@@ -242,7 +242,7 @@ c
ir = wk(i,1)
fi = 2.0d0**ir
if (i .lt. low) fi = 1.0d0
- do 400 j =low,n
+ do 400 j =low,n ! { dg-warning "Obsolescent feature: Shared DO termination" }
jc = cscale(j)
fj = 2.0d0**jc
if (j .le. igh) go to 390
@@ -0,0 +1,8 @@
+! { dg-do compile }
+!
+! PR fortran/40881
+!
+integer :: a(3)
+print *, 'Hello'
+data a/3*5/ ! { dg-warning "Obsolescent feature: DATA statement at .1. after the first executable statement" }
+end