From patchwork Sun Nov 14 22:17:48 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Bernhard Reutner-Fischer X-Patchwork-Id: 47638 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id 3912F385841D for ; Sun, 14 Nov 2021 22:18:42 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 3912F385841D DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gcc.gnu.org; s=default; t=1636928322; bh=L9VRnEDqWyG7RsyrYr/VKr4x8TeHbLG4l8RYDnTlik4=; h=Date:To:Subject:List-Id:List-Unsubscribe:List-Archive:List-Post: List-Help:List-Subscribe:From:Reply-To:Cc:From; b=tzyMU3c3CNaxlLcrQck2bHydoAYdYtDm2PqsjW2Te5sQibiyActnGtG5b/FrZ0QZc oyv7kiLYAS8AApBjKhZ7ky7cER4UoL4uFKEGa+yVQ612ev//GeEyOLPEAlC6MsOIzp AEuViOxOxBwINaC/feaKh1CRqpERv7onlB60B1DE= X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-wr1-x435.google.com (mail-wr1-x435.google.com [IPv6:2a00:1450:4864:20::435]) by sourceware.org (Postfix) with ESMTPS id B9E7E3858D39; Sun, 14 Nov 2021 22:17:52 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org B9E7E3858D39 Received: by mail-wr1-x435.google.com with SMTP id t30so26743645wra.10; Sun, 14 Nov 2021 14:17:52 -0800 (PST) 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:mime-version; bh=L9VRnEDqWyG7RsyrYr/VKr4x8TeHbLG4l8RYDnTlik4=; b=1qkEY1UMwn/SUoE8VNVHoCyMgS7VppkgDJhdoArjvhiR/spqMZBvqTafZPIauDYBfD 3Io2i/OXmTWKYcMmTGHubOz9NaShSfDPdiBurC7gdC0BEFR76+WZYKUR6LxsHnZZoCxJ QqQqEaRaou6zwpkRENDrM5DBOwjU8soxTaU/zR+GDtCkdCAl1r2HxN2lXbPeY03148nI ZSGoHiMd+uke1Fb4ILKZY6poMHHYsnNNKkcA9mkcAUdIFXpszBWJ7+oyG1QAPXgHz2p7 w4JL/Zg5mZ+pY4DPBB+4MMhKzDOfcCoJhmt5fDoWp4L0Y/s5H+DSa2ui6pAco8l02I9s 3qUg== X-Gm-Message-State: AOAM532WNh0PFoSZdfS3ABuNJvx280mdZt51SPKYQXPtxVPmLFgGggwc 89Ao59mDLJlamxGMMQHHvNU= X-Google-Smtp-Source: ABdhPJy0QbtwTp0HfbZsL39SNL/s/1NRnoThclxQTSGeO0sFYXDFJ7FdmqbybovP9kNZ7IT1oL02HQ== X-Received: by 2002:adf:e882:: with SMTP id d2mr41348434wrm.389.1636928271394; Sun, 14 Nov 2021 14:17:51 -0800 (PST) Received: from nbbrfq (62-46-115-185.adsl.highway.telekom.at. [62.46.115.185]) by smtp.gmail.com with ESMTPSA id 8sm10309414wmg.24.2021.11.14.14.17.50 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Sun, 14 Nov 2021 14:17:51 -0800 (PST) Date: Sun, 14 Nov 2021 23:17:48 +0100 To: gfortran , gcc-patches Subject: [PATCH] Fortran: Mark internal symbols as artificial [PR88009,PR68800] Message-ID: <20211114231748.376086cd@nbbrfq> MIME-Version: 1.0 X-Spam-Status: No, score=-9.1 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-Patchwork-Original-From: Bernhard Reutner-Fischer via Gcc-patches From: Bernhard Reutner-Fischer Reply-To: Bernhard Reutner-Fischer Cc: Bernhard Reutner-Fischer Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" Hi! Amend fix for PR88009 to mark all these class components as artificial. gcc/fortran/ChangeLog: * class.c (gfc_build_class_symbol, generate_finalization_wrapper, (gfc_find_derived_vtab, find_intrinsic_vtab): Use stringpool for names. Mark internal symbols as artificial. * decl.c (gfc_match_decl_type_spec, gfc_match_end): Fix indentation. (gfc_match_derived_decl): Fix indentation. Check extension level before incrementing refs counter. * parse.c (parse_derived): Fix style. * resolve.c (resolve_global_procedure): Likewise. * symbol.c (gfc_check_conflict): Do not ignore artificial symbols. (gfc_add_flavor): Reorder condition, cheapest first. (gfc_new_symbol, gfc_get_sym_tree, generate_isocbinding_symbol): Fix style. * trans-expr.c (gfc_trans_subcomponent_assign): Remove restriction on !artificial. * match.c (gfc_match_equivalence): Special-case CLASS_DATA for warnings. --- gfc_match_equivalence(), too, should not bail-out early on the first error but should diagnose all errors. I.e. not goto cleanup but set err=true and continue in order to diagnose all constraints of a statement. Maybe Sandra or somebody else will eventually find time to tweak that. I think it also plugs a very minor leak of name in gfc_find_derived_vtab so i also tagged it [PR68800]. At least that was the initial motiviation to look at that spot. We were doing - name = xasprintf ("__vtab_%s", tname); ... gfc_set_sym_referenced (vtab); - name = xasprintf ("__vtype_%s", tname); Bootstrapped and regtested without regressions on x86_64-unknown-linux. Ok for trunk? From 764a41d4afc1a03e1e8a380f4f92242a5bc9bd65 Mon Sep 17 00:00:00 2001 From: Bernhard Reutner-Fischer Date: Sun, 7 Nov 2021 11:15:56 +0100 Subject: [PATCH] Fortran: Mark internal symbols as artificial To: fortran@gcc.gnu.org Amend fix for PR88009 to mark all these as artificial. gcc/fortran/ChangeLog: * class.c (gfc_build_class_symbol, generate_finalization_wrapper, (gfc_find_derived_vtab, find_intrinsic_vtab): Use stringpool for names. Mark internal symbols as artificial. * decl.c (gfc_match_decl_type_spec, gfc_match_end): Fix indentation. (gfc_match_derived_decl): Fix indentation. Check extension level before incrementing refs counter. * parse.c (parse_derived): Fix style. * resolve.c (resolve_global_procedure): Likewise. * symbol.c (gfc_check_conflict): Do not ignore artificial symbols. (gfc_add_flavor): Reorder condition, cheapest first. (gfc_new_symbol, gfc_get_sym_tree, generate_isocbinding_symbol): Fix style. * trans-expr.c (gfc_trans_subcomponent_assign): Remove restriction on !artificial. * match.c (gfc_match_equivalence): Special-case CLASS_DATA for warnings. --- gfc_match_equivalence(), too, should not bail-out early on the first error but should diagnose all errors. I.e. not goto cleanup but set err=true and continue in order to diagnose all constraints of a statement. --- gcc/fortran/class.c | 70 +++++++++++++++++++++++----------------- gcc/fortran/decl.c | 49 ++++++++++++++-------------- gcc/fortran/match.c | 21 +++++++++--- gcc/fortran/parse.c | 5 ++- gcc/fortran/resolve.c | 2 +- gcc/fortran/symbol.c | 20 ++++-------- gcc/fortran/trans-expr.c | 2 +- 7 files changed, 92 insertions(+), 77 deletions(-) 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/match.c b/gcc/fortran/match.c index 2bf21434a42..94e7dce1675 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5706,11 +5706,22 @@ gfc_match_equivalence (void) if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL)) goto cleanup; - if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym) - && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr, - sym->name, NULL)) - goto cleanup; + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + { + bool ret; + /* The check above should have seen allocatable and some more. + But gfc_build_class_symbol clears + allocatable, pointer, dimension, codimension on the + base symbol. Cheat by temporarily pretending our class data + has the real symbol's attribs. + */ + CLASS_DATA (sym)->attr.artificial = 0; + ret = gfc_add_in_equivalence (&CLASS_DATA (sym)->attr, + sym->name, NULL); + CLASS_DATA (sym)->attr.artificial = 1; + if (!ret) + goto cleanup; + } if (sym->attr.in_common) { 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..9df23f314df 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; @@ -901,6 +898,10 @@ gfc_check_conflict (symbol_attribute *attr, const char *name, locus *where) return true; conflict: + /* It would be wrong to complain about artificial code. */ + if (attr->artificial) + return false; + if (name == NULL) gfc_error ("%s attribute conflicts with %s attribute at %L", a1, a2, where); @@ -1773,7 +1774,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 +3156,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 +3397,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 +3404,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 +4833,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 +5009,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); diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 2bf21434a42..94e7dce1675 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -5706,11 +5706,22 @@ gfc_match_equivalence (void) if (!gfc_add_in_equivalence (&sym->attr, sym->name, NULL)) goto cleanup; - if (sym->ts.type == BT_CLASS - && CLASS_DATA (sym) - && !gfc_add_in_equivalence (&CLASS_DATA (sym)->attr, - sym->name, NULL)) - goto cleanup; + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) + { + bool ret; + /* The check above should have seen allocatable and some more. + But gfc_build_class_symbol clears + allocatable, pointer, dimension, codimension on the + base symbol. Cheat by temporarily pretending our class data + has the real symbol's attribs. + */ + CLASS_DATA (sym)->attr.artificial = 0; + ret = gfc_add_in_equivalence (&CLASS_DATA (sym)->attr, + sym->name, NULL); + CLASS_DATA (sym)->attr.artificial = 1; + if (!ret) + goto cleanup; + } if (sym->attr.in_common) {