From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 48) id 4797F3840C26; Wed, 22 Jul 2020 18:25:15 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 4797F3840C26 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1595442315; bh=OxaLOnVw9+DdggVgzjolWtNR/zha7V0atvKEoSKqXes=; h=From:To:Subject:Date:In-Reply-To:References:From; b=TufPbBX8nTL9fdKt+w0QjR1ap8jw79AJ/IIfxuewPcw6H37JkcdlMZmjGcfVLpQ5Z DVGAbCjwzH6UblfnBGroHhCKM+elAIaQQ7OCbH8TqP/DXf2kUQlru2lvydx/IhqKM9 BjsWPTKAnSLTUgJ+vFGFwTknbQNYiY0kW5yqPtQM= From: "kargl at gcc dot gnu.org" To: gcc-bugs@gcc.gnu.org Subject: [Bug fortran/96255] [F2018] Implement optional type spec for index in DO CONCURRENT Date: Wed, 22 Jul 2020 18:25:15 +0000 X-Bugzilla-Reason: CC X-Bugzilla-Type: changed X-Bugzilla-Watch-Reason: None X-Bugzilla-Product: gcc X-Bugzilla-Component: fortran X-Bugzilla-Version: 11.0 X-Bugzilla-Keywords: X-Bugzilla-Severity: normal X-Bugzilla-Who: kargl at gcc dot gnu.org X-Bugzilla-Status: NEW X-Bugzilla-Resolution: X-Bugzilla-Priority: P4 X-Bugzilla-Assigned-To: unassigned at gcc dot gnu.org X-Bugzilla-Target-Milestone: --- X-Bugzilla-Flags: X-Bugzilla-Changed-Fields: Message-ID: In-Reply-To: References: Content-Type: text/plain; charset="UTF-8" Content-Transfer-Encoding: quoted-printable X-Bugzilla-URL: http://gcc.gnu.org/bugzilla/ Auto-Submitted: auto-generated MIME-Version: 1.0 X-BeenThere: gcc-bugs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-bugs mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Wed, 22 Jul 2020 18:25:15 -0000 https://gcc.gnu.org/bugzilla/show_bug.cgi?id=3D96255 --- Comment #8 from kargl at gcc dot gnu.org --- New patch. This adds a bool component to gfc_forall_iterator so that an iterator with an index-name that shadows a variable from outer scope can be marked. Shadowing only occurs when a type-spec causes the kind type parameter to differ from the kind type=20 parameter of the outer scope variable. A fatal error occurs if shadowing is found. Someone needs to wlak the forall block (and by extension the do concurrent block) updating references to the outer scope variable to be those of the shadow variable. It might be beneficial to introduce a namespace for forall and do concurrent, but I won't go down that path. Index: gcc/fortran/gfortran.h =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D --- gcc/fortran/gfortran.h (revision 280157) +++ gcc/fortran/gfortran.h (working copy) @@ -2525,6 +2525,8 @@ gfc_dt; typedef struct gfc_forall_iterator { gfc_expr *var, *start, *end, *stride; + /* index-name shadows a variable from outer scope. */ + bool shadow; struct gfc_forall_iterator *next; } gfc_forall_iterator; Index: gcc/fortran/match.c =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D --- gcc/fortran/match.c (revision 280157) +++ gcc/fortran/match.c (working copy) @@ -2381,7 +2381,10 @@ cleanup: } -/* Match the header of a FORALL statement. */ +/* Match the header of a FORALL statement. In F2008 and F2018, the form of + the header is=20 + ([ type-spec :: ] concurrent-control-list [, scalar-mask-expr ] ) + where type-spec is INTEGER. */ static match match_forall_header (gfc_forall_iterator **phead, gfc_expr **mask) @@ -2389,6 +2392,9 @@ match_forall_header (gfc_forall_iterator **phead, gfc_ gfc_forall_iterator *head, *tail, *new_iter; gfc_expr *msk; match m; + gfc_typespec ts; + bool seen_ts =3D false; + locus loc; gfc_gobble_whitespace (); @@ -2398,12 +2404,76 @@ match_forall_header (gfc_forall_iterator **phead, g= fc_ if (gfc_match_char ('(') !=3D MATCH_YES) return MATCH_NO; + /* Check for an optional type-spec. */ + gfc_clear_ts (&ts); + loc =3D gfc_current_locus; + m =3D gfc_match_type_spec (&ts); + if (m =3D=3D MATCH_YES) + { + seen_ts =3D (gfc_match (" ::") =3D=3D MATCH_YES); + + if (seen_ts) + { + if (!gfc_notify_std (GFC_STD_F2008, "FORALL or DO CONCURRENT " + "construct includes type specification " + "at %L", &loc)) + goto cleanup; + + if (ts.type !=3D BT_INTEGER) + { + gfc_error ("Type-spec at %L must be an INTEGER type", &loc); + goto cleanup; + } + } + } + else if (m =3D=3D MATCH_ERROR) + goto syntax; + m =3D match_forall_iterator (&new_iter); if (m =3D=3D MATCH_ERROR) goto cleanup; if (m =3D=3D MATCH_NO) goto syntax; + if (seen_ts) + { + char *name; + gfc_expr *v; + gfc_symtree *st; + + /* If index-name does not have a type and type spec, then update the + type spec in both the expr and symtree. Otherwise, create a new + shadow index-name. */ + new_iter->shadow =3D false; + v =3D new_iter->var; + if (v->ts.type =3D=3D BT_UNKNOWN) + { + v->ts.type =3D v->symtree->n.sym->ts.type =3D BT_INTEGER; + v->ts.kind =3D v->symtree->n.sym->ts.kind =3D ts.kind; + } + else if (v->ts.kind !=3D ts.kind) + { + name =3D (char *) alloca (strlen (v->symtree->name) + 2); + strcpy (name, "_"); + strcat (name, v->symtree->name); + if (gfc_get_sym_tree (name, NULL, &st, false) !=3D 0) + gfc_internal_error ("whoops"); + + v =3D gfc_get_expr (); + v->where =3D gfc_current_locus; + v->expr_type =3D EXPR_VARIABLE; + v->ts.type =3D st->n.sym->ts.type =3D ts.type; + v->ts.kind =3D st->n.sym->ts.kind =3D ts.kind; + st->n.sym->forall_index =3D true; + v->symtree =3D st; + gfc_replace_expr (new_iter->var, v); + new_iter->shadow =3D true; + } + gfc_convert_type (new_iter->start, &ts, 1); + gfc_convert_type (new_iter->end, &ts, 1); + gfc_convert_type (new_iter->stride, &ts, 1); + } + head =3D tail =3D new_iter; for (;;) @@ -2417,6 +2487,44 @@ match_forall_header (gfc_forall_iterator **phead, gf= c_ if (m =3D=3D MATCH_YES) { + if (seen_ts) + { + char *name; + gfc_expr *v; + gfc_symtree *st; + + new_iter->shadow =3D false; + v =3D new_iter->var; + if (v->ts.type =3D=3D BT_UNKNOWN) + { + v->ts.type =3D v->symtree->n.sym->ts.type =3D BT_INTEGER; + v->ts.kind =3D v->symtree->n.sym->ts.kind =3D ts.kind; + } + else if (v->ts.kind !=3D ts.kind) + { + name =3D (char *) alloca (strlen (v->symtree->name) + 2); + strcpy (name, "_"); + strcat (name, v->symtree->name); + if (gfc_get_sym_tree (name, NULL, &st, false) !=3D 0) + gfc_internal_error ("whoops"); + + v =3D gfc_get_expr (); + v->expr_type =3D EXPR_VARIABLE; + v->ts.type =3D ts.type; + v->ts.kind =3D ts.kind; + v->where =3D gfc_current_locus; + st->n.sym->ts.type =3D ts.type; + st->n.sym->ts.kind =3D ts.kind; + st->n.sym->forall_index =3D true; + v->symtree =3D st; + gfc_replace_expr (new_iter->var, v); + new_iter->shadow =3D true; + } + gfc_convert_type (new_iter->start, &ts, 1); + gfc_convert_type (new_iter->end, &ts, 1); + gfc_convert_type (new_iter->stride, &ts, 1); + } + tail->next =3D new_iter; tail =3D new_iter; continue; Index: gcc/fortran/resolve.c =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D= =3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D --- gcc/fortran/resolve.c (revision 280157) +++ gcc/fortran/resolve.c (working copy) @@ -10322,11 +10322,10 @@ static void gfc_resolve_assign_in_forall (gfc_code *code, int nvar, gfc_expr **var_exp= r) { int n; + gfc_symbol *forall_index; for (n =3D 0; n < nvar; n++) { - gfc_symbol *forall_index; - forall_index =3D var_expr[n]->symtree->n.sym; /* Check whether the assignment target is one of the FORALL index @@ -10475,8 +10474,10 @@ gfc_count_forall_iterators (gfc_code *code) } -/* Given a FORALL construct, first resolve the FORALL iterator, then call - gfc_resolve_forall_body to resolve the FORALL body. */ +/* Given a FORALL construct. + 1) Resolve the FORALL iterator. + 2) Check for shadow index-name(s) and update code block. + 3) call gfc_resolve_forall_body to resolve the FORALL body. */ static void gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save) @@ -10486,6 +10487,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *= ns, static int nvar =3D 0; int i, old_nvar, tmp; gfc_forall_iterator *fa; + bool shadow =3D false; old_nvar =3D nvar; @@ -10503,8 +10505,9 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *= ns, var_expr =3D XCNEWVEC (gfc_expr *, total_var); } - /* The information about FORALL iterator, including FORALL indices start, end - and stride. An outer FORALL indice cannot appear in start, end or stride. */ + /* The information about FORALL iterator, including FORALL indices start, + end and stride. An outer FORALL indice cannot appear in start, end or + stride. Check for a shadow index-name. */ for (fa =3D code->ext.forall_iterator; fa; fa =3D fa->next) { /* Fortran 20008: C738 (R753). */ @@ -10524,6 +10527,9 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *= ns, "with this name %L", &fa->var->where); } + if (fa->shadow) + shadow =3D true; + /* Record the current FORALL index. */ var_expr[nvar] =3D gfc_copy_expr (fa->var); @@ -10532,6 +10538,12 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace = *ns, /* No memory leak. */ gcc_assert (nvar <=3D total_var); } + + /* Need to walk the code and replace references to the index-name with + references to the shadow index-name. */ + if (shadow) + gfc_fatal_error ("An index-name shadows a variable from outer scope, " + "which causes a wrong-code bug."); /* Resolve the FORALL body. */ gfc_resolve_forall_body (code, nvar, var_expr);=