From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mail-wm1-x330.google.com (mail-wm1-x330.google.com [IPv6:2a00:1450:4864:20::330]) by sourceware.org (Postfix) with ESMTPS id 0FD203858406; Sat, 6 Nov 2021 23:57:00 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 0FD203858406 Received: by mail-wm1-x330.google.com with SMTP id f7-20020a1c1f07000000b0032ee11917ceso9101366wmf.0; Sat, 06 Nov 2021 16:57:00 -0700 (PDT) X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:date:from:to:cc:subject:message-id:in-reply-to :references:mime-version; bh=QUkuzSvjQdxW4PXQ/EaI0RurDfW6RqBIP+v+yvPgZdo=; b=LOKt/VKvI1jzNa+hnOBiaa4hPDOiRSHDO8H2qNLwv8TTQOYgXwACKS5QZgTAM9hO1C Sevyzq4TGPCkYEg5BKKhfU6+T1Icblr7TTkveduLQO2Jr9sTaA7FqTUumkbFjsoCDNG7 0uCqg7ekRrmV+rV8BQQPCx5fm/j2cRcTPRnhzVK0Vq3e4n72pC/f0rDOZugiLz83aK5H T57qrZsWLTukpbXrqAXunceNgvBhFMcIDvn/f7JvvNACsm3rEGCarTfKox6owLfeZKAK kH5xmYHV7YhahWL6fU80DuhZvKg2MILNMnjKKdAv9mgM+84TGcw1jw+VpbWdApRr17jc duQg== X-Gm-Message-State: AOAM530P9lybaa04Hp6altN7I7EHIJUcZNZ1MtmyrlA5KK4EOqhTIakd 0JkzPgrYKeabQtTZBNAijKw= X-Google-Smtp-Source: ABdhPJzZUb7t38nrg3CYFBeUskkc/IrFGCGi8FvvV6W5ezJxZ0Yzd+G4WekoiE+buZD/VGm3kUY0sQ== X-Received: by 2002:a1c:5414:: with SMTP id i20mr41410314wmb.88.1636243018894; Sat, 06 Nov 2021 16:56:58 -0700 (PDT) Received: from nbbrfq (dynamic-2bq7di4u2lfl4qjka9-pd01.res.v6.highway.a1.net. [2001:871:227:33a8:f6a3:c58c:7641:e771]) by smtp.gmail.com with ESMTPSA id h18sm12808955wre.46.2021.11.06.16.56.57 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sat, 06 Nov 2021 16:56:58 -0700 (PDT) Date: Sun, 7 Nov 2021 00:56:55 +0100 From: Bernhard Reutner-Fischer To: Mikael Morin Cc: rep.dot.nop@gmail.com, Tobias Burnus , gcc-patches@gcc.gnu.org, fortran@gcc.gnu.org Subject: Re: [PATCH,FORTRAN] Fix memory leak in finalization wrappers Message-ID: <20211107005655.4bf8a07e@nbbrfq> In-Reply-To: <6d86c6ec-a9a5-431a-e2ed-a8a71baea830@orange.fr> References: <20181015082306.23083-1-rep.dot.nop@gmail.com> <20211027233943.082d66ed@nbbrfq> <20211029015857.14a80703@nbbrfq> <6683b641-0c67-814e-cf87-e164729b1cfe@orange.fr> <20211105230812.78ca344b@nbbrfq> <6d86c6ec-a9a5-431a-e2ed-a8a71baea830@orange.fr> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/vIG98AMecFoix2T4b7dZumc" X-Spam-Status: No, score=-9.2 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FREEMAIL_FROM, GIT_PATCH_0, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , X-List-Received-Date: Sat, 06 Nov 2021 23:57:03 -0000 --MP_/vIG98AMecFoix2T4b7dZumc Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Content-Disposition: inline On Sat, 6 Nov 2021 13:04:07 +0100 Mikael Morin wrote: > Le 05/11/2021 =C3=A0 23:08, Bernhard Reutner-Fischer a =C3=A9crit=C2=A0: > > On Fri, 5 Nov 2021 19:46:16 +0100 > > Mikael Morin wrote: > > =20 > >> Le 29/10/2021 =C3=A0 01:58, Bernhard Reutner-Fischer via Fortran a =C3= =A9crit=C2=A0: =20 > >>> On Wed, 27 Oct 2021 23:39:43 +0200 > >>> Bernhard Reutner-Fischer wrote: > >>> =20 > >>>> On Mon, 15 Oct 2018 10:23:06 +0200 > >>>> Bernhard Reutner-Fischer wrote: > >>>> =20 > >>>>> If a finalization is not required we created a namespace containing > >>>>> formal arguments for an internal interface definition but never used > >>>>> any of these. So the whole sub_ns namespace was not wired up to the > >>>>> program and consequently was never freed. The fix is to simply not > >>>>> generate any finalization wrappers if we know that it will be unuse= d. > >>>>> Note that this reverts back to the original r190869 > >>>>> (8a96d64282ac534cb597f446f02ac5d0b13249cc) handling for this case > >>>>> by reverting this specific part of r194075 > >>>>> (f1ee56b4be7cc3892e6ccc75d73033c129098e87) for PR fortran/37336. > >>>>> =20 > >> I=E2=80=99m a bit concerned by the loss of the null_expr=E2=80=99s typ= e interface. > >> I can=E2=80=99t convince myself that it=E2=80=99s either absolutely ne= cessary or > >> completely useless. =20 > >=20 > > It's a delicate spot, yes, but i do think they are completely useless. > > If we do NOT need a finalization, the initializer can (and has to be > > AFAIU) be a null_expr and AFAICS then does not need an interface. > > =20 > Well, the null pointer itself doesn=E2=80=99t need a type, but I think it= =E2=80=99s=20 > better if the pointer it=E2=80=99s assigned to has a type different from = void*. > It will (hopefully) help the middle-end optimizers downstream. I would not expect this to help all that much or at all TBH. So i compiled for i in $(grep -li final $(grep -L dg-error /scratch/src/gcc-12.mine/gcc/t= estsuite/gfortran.dg/*.f*)); do gfortran -O2 -fcoarray=3Dsingle -c $i -g -g= 3 -ggdb3 -fdump-tree-original -fdump-tree-optimized;done and diffed all .original and .optimized dumps against pristine trunk and they are identical. I inspected and ran the binary from finalize_14 and there is no change in the leaks compared to pristine trunk. The 3 shape_w in p leak as they used to. I do remember that finalize_14 was a good testcase, in sum i glared at it for quite some time ;) >=20 > I will see if I can manage to create a testcase where it makes a=20 > difference (don=E2=80=99t hold your breath, I don=E2=80=99t even have a b= ootstrapped=20 > compiler ready yet). >=20 That'd be great, TIA! [] btw.. Just because it's vagely related. I think f8add009ce300f24b75e9c2e2cc5dd944a020c28 for PR fortran/88009 (ICE in find_intrinsic_vtab, at fortran/class.c:2761) is incomplete in that i think all the internal class helpers should be flagged artificial. All these symbols built in gfc_build_class_symbol, generate_finalization_wrapper, gfc_find_derived_vtab etc. Looking at the history it seems the artificial bit often was forgotten. And most importantly i think it is not correct to ignore artificial in gfc_check_conflict! I'm attaching my notes on this to illustrate what i mean. Not a patch, even if it regtests cleanly.. The hunk in gfc_match_derived_decl() plugs another leak by first checking if the max extension level is reached before adding the component. Maybe i should split that hunk out. Similar to the removal of *head in gfc_match_derived_decl, there's another spot in gfc_match_decl_type_spec which should get rid of the *head and just wire the interface up as usual. Just cosmetics. Several tests do exercise this code: alloc_comp_class_1.f90, class_19.f03 and 62, unlimited_polymorphic_8.f90 and others. > >> The rest of the changes (appart from class.c) are mostly OK with the n= it > >> below and should be put in their own commit. > >> =20 > >> >>> @@ -3826,10 +3828,8 @@ free_tb_tree (gfc_symtree *t) > >> >>> > >> >>> free_tb_tree (t->left); > >> >>> free_tb_tree (t->right); > >> >>> - > >> >>> - /* TODO: Free type-bound procedure structs themselves; probab= ly =20 > >> needs some =20 > >> >>> - sort of ref-counting mechanism. */ > >> >>> free (t->n.tb); =20 > >> > >> Please keep a comment; it remains somehow valid but could be updated > >> maybe: gfc_typebound_proc=E2=80=99s u.generic field for example is now= here freed > >> as far as I know. =20 > >=20 > > Well that's a valid point, not sure where they are freed indeed. > > Do you have a specific testcase in mind that leaks tbp's u.generic (or > > specific for that matter) for me to look at? > > =20 > Any testcase with generic typebound procedures, I guess. > typebound_generic_3.f03 for example seems like a good candidate. I'll have a look at these later, thanks for the pointer. >=20 > > I'm happy to change the comment to > > TODO: Free type-bound procedure u.generic and u.specific fields > > to reflect the current state. Ok? > > =20 > I don=E2=80=99t think specific leaks because it=E2=80=99s one of gfc_name= space=E2=80=99s=20 > sym_root sub-nodes, and it=E2=80=99s freed with gfc_namespace. > OK without "and u.specific". Ah right. Done. Thanks so far! --MP_/vIG98AMecFoix2T4b7dZumc Content-Type: text/plain Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=gfc-class-artificial.02.txt diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 6b017667600..44fccced7b9 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -637,7 +637,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, gfc_array_spec **as) { char tname[GFC_MAX_SYMBOL_LEN+1]; - char *name; + const char *name; gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; @@ -665,17 +665,17 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, get_unique_hashed_string (tname, ts->u.derived); if ((*as) && attr->allocatable) - name = xasprintf ("__class_%s_%d_%da", tname, rank, (*as)->corank); + name = gfc_get_string ("__class_%s_%d_%da", tname, rank, (*as)->corank); else if ((*as) && attr->pointer) - name = xasprintf ("__class_%s_%d_%dp", tname, rank, (*as)->corank); + name = gfc_get_string ("__class_%s_%d_%dp", tname, rank, (*as)->corank); else if ((*as)) - name = xasprintf ("__class_%s_%d_%dt", tname, rank, (*as)->corank); + name = gfc_get_string ("__class_%s_%d_%dt", tname, rank, (*as)->corank); else if (attr->pointer) - name = xasprintf ("__class_%s_p", tname); + name = gfc_get_string ("__class_%s_p", tname); else if (attr->allocatable) - name = xasprintf ("__class_%s_a", tname); + name = gfc_get_string ("__class_%s_a", tname); else - name = xasprintf ("__class_%s_t", tname); + name = gfc_get_string ("__class_%s_t", tname); if (ts->u.derived->attr.unlimited_polymorphic) { @@ -695,7 +695,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, if (attr->dummy && !attr->codimension && (*as) && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK)) { - char *sname; + const char *sname; ns = gfc_current_ns; gfc_find_symbol (name, ns, 0, &fclass); /* If a local class type with this name already exists, update the @@ -703,8 +703,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, if (fclass) { fclass = NULL; - sname = xasprintf ("%s_%d", name, ++ctr); - free (name); + sname = gfc_get_string ("%s_%d", name, ++ctr); name = sname; } } @@ -735,6 +734,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.type = BT_DERIVED; c->attr.access = ACCESS_PRIVATE; c->ts.u.derived = ts->u.derived; + c->attr.artificial = 1; c->attr.class_pointer = attr->pointer; c->attr.pointer = attr->pointer || (attr->dummy && !attr->allocatable) || attr->select_type_temporary; @@ -742,7 +742,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.dimension = attr->dimension; c->attr.codimension = attr->codimension; c->attr.abstract = fclass->attr.abstract; - c->as = (*as); + c->as = *as; c->initializer = NULL; /* Add component '_vptr'. */ @@ -751,6 +751,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->ts.type = BT_DERIVED; c->attr.access = ACCESS_PRIVATE; c->attr.pointer = 1; + c->attr.artificial = 1; if (ts->u.derived->attr.unlimited_polymorphic) { @@ -792,8 +793,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, fclass->attr.is_class = 1; ts->u.derived = fclass; attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; - (*as) = NULL; - free (name); + *as = NULL; return true; } @@ -1600,7 +1600,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_component *comp; gfc_namespace *sub_ns; gfc_code *last_code, *block; - char *name; + const char *name; bool finalizable_comp = false; gfc_expr *ancestor_wrapper = NULL, *rank; gfc_iterator *iter; @@ -1681,7 +1681,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, sub_ns->resolved = 1; /* Set up the procedure symbol. */ - name = xasprintf ("__final_%s", tname); + name = gfc_get_string ("__final_%s", tname); gfc_get_symbol (name, sub_ns, &final); sub_ns->proc_name = final; final->attr.flavor = FL_PROCEDURE; @@ -2238,7 +2238,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_free_expr (rank); vtab_final->initializer = gfc_lval_expr_from_sym (final); vtab_final->ts.interface = final; - free (name); } @@ -2313,10 +2312,10 @@ gfc_find_derived_vtab (gfc_symbol *derived) if (ns) { char tname[GFC_MAX_SYMBOL_LEN+1]; - char *name; + const char *name; get_unique_hashed_string (tname, derived); - name = xasprintf ("__vtab_%s", tname); + name = gfc_get_string ("__vtab_%s", tname); /* Look for the vtab symbol in various namespaces. */ if (gsym && gsym->ns) @@ -2344,7 +2343,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) vtab->attr.vtab = 1; vtab->attr.access = ACCESS_PUBLIC; gfc_set_sym_referenced (vtab); - name = xasprintf ("__vtype_%s", tname); + name = gfc_get_string ("__vtype_%s", tname); gfc_find_symbol (name, ns, 0, &vtype); if (vtype == NULL) @@ -2372,6 +2371,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) goto cleanup; vtype->attr.access = ACCESS_PUBLIC; vtype->attr.vtype = 1; + vtype->attr.artificial = 1; gfc_set_sym_referenced (vtype); /* Add component '_hash'. */ @@ -2380,6 +2380,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->ts.type = BT_INTEGER; c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, derived->hash_value); @@ -2389,6 +2390,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) c->ts.type = BT_INTEGER; c->ts.kind = gfc_size_kind; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; /* Remember the derived type in ts.u.derived, so that the correct initializer can be set later on (in gfc_conv_structure). */ @@ -2401,6 +2403,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; if (!derived->attr.unlimited_polymorphic) parent = gfc_get_derived_super_type (derived); else @@ -2447,7 +2450,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) else { /* Construct default initialization variable. */ - name = xasprintf ("__def_init_%s", tname); + name = gfc_get_string ("__def_init_%s", tname); gfc_get_symbol (name, ns, &def_init); def_init->attr.target = 1; def_init->attr.artificial = 1; @@ -2467,6 +2470,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) goto cleanup; c->attr.proc_pointer = 1; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; if (derived->attr.unlimited_polymorphic @@ -2480,7 +2484,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up procedure symbol. */ - name = xasprintf ("__copy_%s", tname); + name = gfc_get_string ("__copy_%s", tname); gfc_get_symbol (name, sub_ns, ©); sub_ns->proc_name = copy; copy->attr.flavor = FL_PROCEDURE; @@ -2543,6 +2547,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) goto cleanup; c->attr.proc_pointer = 1; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; if (derived->attr.unlimited_polymorphic @@ -2558,7 +2563,7 @@ gfc_find_derived_vtab (gfc_symbol *derived) ns->contained = sub_ns; sub_ns->resolved = 1; /* Set up procedure symbol. */ - name = xasprintf ("__deallocate_%s", tname); + name = gfc_get_string ("__deallocate_%s", tname); gfc_get_symbol (name, sub_ns, &dealloc); sub_ns->proc_name = dealloc; dealloc->attr.flavor = FL_PROCEDURE; @@ -2607,7 +2612,6 @@ have_vtype: vtab->ts.u.derived = vtype; vtab->value = gfc_default_initializer (&vtab->ts); } - free (name); } found_sym = vtab; @@ -2700,13 +2704,13 @@ find_intrinsic_vtab (gfc_typespec *ts) if (ns) { char tname[GFC_MAX_SYMBOL_LEN+1]; - char *name; + const char *name; /* Encode all types as TYPENAME_KIND_ including especially character arrays, whose length is now consistently stored in the _len component of the class-variable. */ sprintf (tname, "%s_%d_", gfc_basic_typename (ts->type), ts->kind); - name = xasprintf ("__vtab_%s", tname); + name = gfc_get_string ("__vtab_%s", tname); /* Look for the vtab symbol in the top-level namespace only. */ gfc_find_symbol (name, ns, 0, &vtab); @@ -2722,8 +2726,9 @@ find_intrinsic_vtab (gfc_typespec *ts) vtab->attr.save = SAVE_IMPLICIT; vtab->attr.vtab = 1; vtab->attr.access = ACCESS_PUBLIC; + vtab->attr.artificial = 1; gfc_set_sym_referenced (vtab); - name = xasprintf ("__vtype_%s", tname); + name = gfc_get_string ("__vtype_%s", tname); gfc_find_symbol (name, ns, 0, &vtype); if (vtype == NULL) @@ -2740,6 +2745,7 @@ find_intrinsic_vtab (gfc_typespec *ts) &gfc_current_locus)) goto cleanup; vtype->attr.access = ACCESS_PUBLIC; + vtype->attr.artificial = 1; vtype->attr.vtype = 1; gfc_set_sym_referenced (vtype); @@ -2749,6 +2755,7 @@ find_intrinsic_vtab (gfc_typespec *ts) c->ts.type = BT_INTEGER; c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; hash = gfc_intrinsic_hash_value (ts); c->initializer = gfc_get_int_expr (gfc_default_integer_kind, NULL, hash); @@ -2759,6 +2766,7 @@ find_intrinsic_vtab (gfc_typespec *ts) c->ts.type = BT_INTEGER; c->ts.kind = gfc_size_kind; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; /* Build a minimal expression to make use of target-memory.c/gfc_element_size for 'size'. Special handling @@ -2782,6 +2790,7 @@ find_intrinsic_vtab (gfc_typespec *ts) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; c->ts.type = BT_VOID; c->initializer = gfc_get_null_expr (NULL); @@ -2790,6 +2799,7 @@ find_intrinsic_vtab (gfc_typespec *ts) goto cleanup; c->attr.pointer = 1; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; c->ts.type = BT_VOID; c->initializer = gfc_get_null_expr (NULL); @@ -2798,16 +2808,17 @@ find_intrinsic_vtab (gfc_typespec *ts) goto cleanup; c->attr.proc_pointer = 1; c->attr.access = ACCESS_PRIVATE; + c->attr.artificial = 1; c->tb = XCNEW (gfc_typebound_proc); c->tb->ppc = 1; if (ts->type != BT_CHARACTER) - name = xasprintf ("__copy_%s", tname); + name = gfc_get_string ("__copy_%s", tname); else { /* __copy is always the same for characters. Check to see if copy function already exists. */ - name = xasprintf ("__copy_character_%d", ts->kind); + name = gfc_get_string ("__copy_character_%d", ts->kind); contained = ns->contained; for (; contained; contained = contained->sibling) if (contained->proc_name @@ -2829,6 +2840,7 @@ find_intrinsic_vtab (gfc_typespec *ts) copy->attr.flavor = FL_PROCEDURE; copy->attr.subroutine = 1; copy->attr.pure = 1; + copy->attr.artificial = 1; copy->attr.if_source = IFSRC_DECL; /* This is elemental so that arrays are automatically treated correctly by the scalarizer. */ @@ -2851,6 +2863,7 @@ find_intrinsic_vtab (gfc_typespec *ts) dst->ts.kind = ts->kind; dst->attr.flavor = FL_VARIABLE; dst->attr.dummy = 1; + dst->attr.artificial = 1; dst->attr.intent = INTENT_INOUT; gfc_set_sym_referenced (dst); copy->formal->next = gfc_get_formal_arglist (); @@ -2877,7 +2890,6 @@ find_intrinsic_vtab (gfc_typespec *ts) vtab->ts.u.derived = vtype; vtab->value = gfc_default_initializer (&vtab->ts); } - free (name); } found_sym = vtab; diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index ab88ab5e9c1..04aa43af1d5 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -4458,7 +4458,7 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag) upe->attr.zero_comp = 1; if (!gfc_add_flavor (&upe->attr, FL_DERIVED, NULL, &gfc_current_locus)) - return MATCH_ERROR; + return MATCH_ERROR; } else { @@ -8342,7 +8342,7 @@ gfc_match_end (gfc_statement *st) case COMP_SUBROUTINE: *st = ST_END_SUBROUTINE; if (!abreviated_modproc_decl) - target = " subroutine"; + target = " subroutine"; else target = " procedure"; eos_ok = !contained_procedure (); @@ -8351,7 +8351,7 @@ gfc_match_end (gfc_statement *st) case COMP_FUNCTION: *st = ST_END_FUNCTION; if (!abreviated_modproc_decl) - target = " function"; + target = " function"; else target = " procedure"; eos_ok = !contained_procedure (); @@ -10473,7 +10473,7 @@ gfc_match_derived_decl (void) match m; match is_type_attr_spec = MATCH_NO; bool seen_attr = false; - gfc_interface *intr = NULL, *head; + gfc_interface *intr = NULL; bool parameterized_type = false; bool seen_colons = false; @@ -10498,16 +10498,15 @@ gfc_match_derived_decl (void) been added to 'attr' but now the parent type must be found and checked. */ if (parent[0]) - extended = check_extended_derived_type (parent); - - if (parent[0] && !extended) - return MATCH_ERROR; + { + extended = check_extended_derived_type (parent); + if (extended == NULL) + return MATCH_ERROR; + } m = gfc_match (" ::"); if (m == MATCH_YES) - { - seen_colons = true; - } + seen_colons = true; else if (seen_attr) { gfc_error ("Expected :: in TYPE definition at %C"); @@ -10582,7 +10581,7 @@ gfc_match_derived_decl (void) if (gensym->attr.dummy) { gfc_error ("Dummy argument %qs at %L cannot be a derived type at %C", - name, &gensym->declared_at); + gensym->name, &gensym->declared_at); return MATCH_ERROR; } @@ -10599,13 +10598,12 @@ gfc_match_derived_decl (void) { /* Use upper case to save the actual derived-type symbol. */ gfc_get_symbol (gfc_dt_upper_string (gensym->name), NULL, &sym); - sym->name = gfc_get_string ("%s", gensym->name); - head = gensym->generic; + sym->name = gensym->name; + sym->declared_at = gfc_current_locus; intr = gfc_get_interface (); intr->sym = sym; intr->where = gfc_current_locus; - intr->sym->declared_at = gfc_current_locus; - intr->next = head; + intr->next = gensym->generic; gensym->generic = intr; gensym->attr.if_source = IFSRC_DECL; } @@ -10662,15 +10660,6 @@ gfc_match_derived_decl (void) gfc_component *p; gfc_formal_arglist *f, *g, *h; - /* Add the extended derived type as the first component. */ - gfc_add_component (sym, parent, &p); - extended->refs++; - gfc_set_sym_referenced (extended); - - p->ts.type = BT_DERIVED; - p->ts.u.derived = extended; - p->initializer = gfc_default_initializer (&p->ts); - /* Set extension level. */ if (extended->attr.extension == 255) { @@ -10680,6 +10669,16 @@ gfc_match_derived_decl (void) extended->name, &extended->declared_at); return MATCH_ERROR; } + + /* Add the extended derived type as the first component. */ + gfc_add_component (sym, parent, &p); + extended->refs++; + gfc_set_sym_referenced (extended); + + p->ts.type = BT_DERIVED; + p->ts.u.derived = extended; + p->initializer = gfc_default_initializer (&p->ts); + sym->attr.extension = extended->attr.extension + 1; /* Provide the links between the extended type and its extension. */ diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 12aa80ec45c..fcbff0c1dcf 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3581,6 +3581,7 @@ parse_derived (void) { case ST_NONE: unexpected_eof (); + break; /* never reached */ case ST_DATA_DECL: case ST_PROCEDURE: @@ -3640,9 +3641,7 @@ endType: "TYPE statement"); if (seen_sequence) - { - gfc_error ("Duplicate SEQUENCE statement at %C"); - } + gfc_error ("Duplicate SEQUENCE statement at %C"); seen_sequence = 1; gfc_add_sequence (&gfc_current_block ()->attr, diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 1f4abd08720..a9a1103e049 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -2588,7 +2588,7 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub) gsym = gfc_get_gsymbol (sym->binding_label ? sym->binding_label : sym->name, sym->binding_label != NULL); - if ((gsym->type != GSYM_UNKNOWN && gsym->type != type)) + if (gsym->type != GSYM_UNKNOWN && gsym->type != type) gfc_global_used (gsym, where); if ((sym->attr.if_source == IFSRC_UNKNOWN diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 91798f2a3a5..1a1e4551355 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -440,9 +440,6 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) const char *a1, *a2; int standard; - if (attr->artificial) - return true; - if (where == NULL) where = &gfc_current_locus; @@ -1773,7 +1770,7 @@ gfc_add_flavor (symbol_attribute *attr, sym_flavor f, const char *name, /* Copying a procedure dummy argument for a module procedure in a submodule results in the flavor being copied and would result in an error without this. */ - if (attr->flavor == f && f == FL_PROCEDURE + if (f == FL_PROCEDURE && attr->flavor == f && gfc_new_block && gfc_new_block->abr_modproc_decl) return true; @@ -3155,7 +3152,6 @@ gfc_new_symbol (const char *name, gfc_namespace *ns) gfc_symbol *p; p = XCNEW (gfc_symbol); - gfc_clear_ts (&p->ts); gfc_clear_attr (&p->attr); p->ns = ns; @@ -3397,7 +3393,6 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result, p = gfc_new_symbol (name, ns); /* Add to the list of tentative symbols. */ - p->old_symbol = NULL; p->mark = 1; p->gfc_new = 1; latest_undo_chgset->syms.safe_push (p); @@ -3405,7 +3400,6 @@ gfc_get_sym_tree (const char *name, gfc_namespace *ns, gfc_symtree **result, st = gfc_new_symtree (&ns->sym_root, name); st->n.sym = p; p->refs++; - } else { @@ -4835,9 +4829,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, gfc_derived_types->dt_next = tmp_sym; } else - { - tmp_sym->dt_next = tmp_sym; - } + tmp_sym->dt_next = tmp_sym; gfc_derived_types = tmp_sym; } @@ -5013,9 +5005,7 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s, gfc_derived_types->dt_next = dt_sym; } else - { - dt_sym->dt_next = dt_sym; - } + dt_sym->dt_next = dt_sym; gfc_derived_types = dt_sym; gfc_add_component (dt_sym, "c_address", &tmp_comp); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index e7aec3845d3..56ddb6629bc 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -9033,7 +9033,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, gfc_add_expr_to_block (&block, tmp); } } - else if (!cm->attr.artificial) + else { /* Scalar component (excluding deferred parameters). */ gfc_init_se (&se, NULL); --MP_/vIG98AMecFoix2T4b7dZumc--