From patchwork Sat Jan 6 17:26:16 2024 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 83455 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 DA6FC38618B9 for ; Sat, 6 Jan 2024 17:27:16 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from mail-pj1-x1031.google.com (mail-pj1-x1031.google.com [IPv6:2607:f8b0:4864:20::1031]) by sourceware.org (Postfix) with ESMTPS id 6D34B3858C31; Sat, 6 Jan 2024 17:26:30 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.2 sourceware.org 6D34B3858C31 Authentication-Results: sourceware.org; dmarc=pass (p=none dis=none) header.from=gmail.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=gmail.com ARC-Filter: OpenARC Filter v1.0.0 sourceware.org 6D34B3858C31 Authentication-Results: server2.sourceware.org; arc=none smtp.remote-ip=2607:f8b0:4864:20::1031 ARC-Seal: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1704561996; cv=none; b=uzOxEg9Wi9RCQKXjvy7HPb9PNIflMu+txqkHN6KttXi9XaOe8hkc9xjoRzTizo9cCrdY+a3ZZChfD/KZwBRSByjg4I0l4/zWgyaWlmzfA3ASPr8itNDo0880KipkAooSv8ciR69DP5/56c5Xl3+7T7g/5AzXHicn+9y1HYf9qVA= ARC-Message-Signature: i=1; a=rsa-sha256; d=sourceware.org; s=key; t=1704561996; c=relaxed/simple; bh=7EgTvm1RZqPDFXXVpp7aOGPRuyrO54UDZl56E+c9gWQ=; h=DKIM-Signature:MIME-Version:From:Date:Message-ID:Subject:To; b=dSSIpdlbJroYCdiXcJ3hBYxQHrpDQvS7PaUjyUkccNy2P8frYK6p7w1MrAusWVgp0xgj8hdF69Al28w46H3BJWLk5416B4BtCqGa8HSpRJRfsaTdFUTe++Q12w4cmYVg+fQnHOGM2u3r/1E3T3GzU31twnK9QX7EBSsYGuV688c= ARC-Authentication-Results: i=1; server2.sourceware.org Received: by mail-pj1-x1031.google.com with SMTP id 98e67ed59e1d1-28bcc273833so517527a91.1; Sat, 06 Jan 2024 09:26:30 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20230601; t=1704561989; x=1705166789; darn=gcc.gnu.org; h=to:subject:message-id:date:from:mime-version:from:to:cc:subject :date:message-id:reply-to; bh=v/sVbe9mBObbK2AQ1cegHiQAd9bxB2TlaqpEh5cn3EI=; b=drcPjNQHKtqVwxpU0gJVl7hNjKSr7Ddeyrz5PGGbg+BPZ9jYWDunX92zhiWulU1MXY m9yuKd9vnkdqlP/KMKlQTcc9ecWXq3DsaODgE2sJyJe+bOWznkHIUaVDxaxk79NBnCzo vvyblx9MhT8SQsyCwV9dNTG4x5eqRrCuN7G6xkzKNtDqlSN9vKTqN8VVp/5JaZEi7QRf jeZy6wHRnpNtoLNQ67dTR/cyhxjk4O+0XQmPeb5sGzT+pp/m137f5yQ2JsoB0U14cUWX AnvPuOgxAsr5kPufzmrwmYAhZchl+HXf/5JIPzvOEgyTMv6A5CQmdcUUgK+LD4NR/iMZ gmtw== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1704561989; x=1705166789; h=to:subject:message-id:date:from:mime-version:x-gm-message-state :from:to:cc:subject:date:message-id:reply-to; bh=v/sVbe9mBObbK2AQ1cegHiQAd9bxB2TlaqpEh5cn3EI=; b=CdzgtEnxfLiBNNRc7rOlbKHLIbL59/vvxm/o2Np2IHYthKGkxG0McRTLa6TpkJPSnK oQslJfPrtnTynMcW76CLYiW95XKfbcfa/dkdk9id+K6qwlS0W713ZVKWe9Bmeq3KSMBb MzBemYzA9b+b3Ov+Je1Cpxue5x29FBBbsBJme0zthbtKajjQb32o1ep8OapYru3gahQ8 XVKAwMAAIl8+kqbaFh6cX7jApEEsr8bgZIvyo9N1f2mfi54tAcsCGoqHxw00wwnrVPiG pHsxYDTqMQ0+patmMeSKVL28Hun1FRW2r2lv9AlEmRS0D/+isbv6KVWnTiB6DD2OTz1v boCA== X-Gm-Message-State: AOJu0YwBaqy4zoFUf1+1/4PQez6eKKx+IAdpDUFjju5zhLJ+5Hye4IIR zHSte23L4/JhRGIm2cLyzR1k+hAm0e1OqAEm3WdIQgl82Yw= X-Google-Smtp-Source: AGHT+IHwYj/J4F1BBFS1A6NpuGKDSvkTgBTuS3WyMWLGPejYQ0zboFsHTKBqQkZA7vzhx7qwHPSJhaSXlHCe3wZCF+c= X-Received: by 2002:a17:90a:fd11:b0:28c:1eff:ac4a with SMTP id cv17-20020a17090afd1100b0028c1effac4amr719309pjb.90.1704561988808; Sat, 06 Jan 2024 09:26:28 -0800 (PST) MIME-Version: 1.0 From: Paul Richard Thomas Date: Sat, 6 Jan 2024 17:26:16 +0000 Message-ID: Subject: [Patch, fortran PR89645/99065 No IMPLICIT type error with: ASSOCIATE( X => function() ) To: "fortran@gcc.gnu.org" , gcc-patches X-Spam-Status: No, score=-6.7 required=5.0 tests=BAYES_00, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, DKIM_VALID_EF, FILL_THIS_FORM, FREEMAIL_FROM, GIT_PATCH_0, HTML_MESSAGE, RCVD_IN_DNSWL_NONE, SPF_HELO_NONE, SPF_PASS, TXREP, T_SCC_BODY_TEXT_LINE, URIBL_BLACK autolearn=ham autolearn_force=no version=3.4.6 X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.30 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org These PRs come about because of gfortran's single pass parsing. If the function in the title is parsed after the associate construct, then its type and rank are not known. The point at which this becomes a problem is when expressions within the associate block are parsed. primary.cc (gfc_match_varspec) could already deal with intrinsic types and so component references were the trigger for the problem. The two major parts of this patch are the fixup needed in gfc_match_varspec and the resolution of expressions with references in resolve.cc (gfc_fixup_inferred_type_refs). The former relies on the two new functions in symbol.cc to search for derived types with an appropriate component to match the component reference and then set the associate name to have a matching derived type. gfc_fixup_inferred_type_refs is called in resolution and so the type of the selector function is known. gfc_fixup_inferred_type_refs ensures that the component references use this derived type and that array references occur in the right place in expressions and match preceding array specs. Most of the work in preparing the patch was sorting out cases where the selector was not a derived type but, instead, a class function. If it were not for this, the patch would have been submitted six months ago :-( The patch is relatively safe because most of the chunks are guarded by testing for the associate name being an inferred type, which is set in gfc_match_varspec. For this reason, I do not think it likely that the patch will cause regressions. However, it is more than possible that variants not appearing in the submitted testcase will throw up new bugs. Jerry has already given the patch a whirl and found that it applies cleanly, regtests OK and works as advertised. OK for trunk? Paul Fortran: Fix class/derived type function associate selectors [PR87477] 2024-01-06 Paul Thomas gcc/fortran PR fortran/87477 PR fortran/89645 PR fortran/99065 * class.cc (gfc_change_class): New function needed for associate names, when rank changes or a derived type is produced by resolution * dump-parse-tree.cc (show_code_node): Make output for SELECT TYPE more comprehensible. * gfortran.h : Add 'gfc_association_list' to structure 'gfc_association_list'. Add prototypes for 'gfc_find_derived_types', 'gfc_fixup_inferred_type_refs' and 'gfc_change_class'. Add macro IS_INFERRED_TYPE. * match.cc (copy_ts_from_selector_to_associate): Add bolean arg 'select_type' with default false. If this is a select type name and the selector is a inferred type, build the class type and apply it to the associate name. (build_associate_name): Pass true to 'select_type' in call to previous. * parse.cc (parse_associate): If the selector is a inferred type the associate name is too. Make sure that function selector class and rank, if known, are passed to the associate name. If a function result exists, pass its typespec to the associate name. * primary.cc (gfc_match_varspec): If a scalar derived type select type temporary has an array reference, match the array reference, treating this in the same way as an equivalence member. If this is a inferred type with a component reference, call 'gfc_find_derived_types' to find a suitable derived type. * resolve.cc (resolve_variable): Call new function below. (gfc_fixup_inferred_type_refs): New function to ensure that the expression references for a inferred type are consistent with the now fixed up selector. (resolve_assoc_var): Ensure that derived type or class function selectors transmit the correct arrayspec to the associate name. (resolve_select_type): If the selector is an associate name of inferred type and has no component references, the associate name should have its typespec. * symbol.cc (gfc_set_default_type): If an associate name with unknown type has a selector expression, try resolving the expr. (find_derived_types, gfc_find_derived_types): New functions that search for a derived type with a given name. * trans-expr.cc (gfc_conv_variable): Some inferred type exprs escape resolution so call 'gfc_fixup_inferred_type_refs'. * trans-stmt.cc (trans_associate_var): Tidy up expression for 'class_target'. Correctly handle selectors that are class array references, passed as derived types. gcc/testsuite/ PR fortran/87477 PR fortran/89645 PR fortran/99065 * gfortran.dg/associate_64.f90 : New test diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc index 5c43b77dba3..7db1ecbd264 100644 --- a/gcc/fortran/class.cc +++ b/gcc/fortran/class.cc @@ -815,6 +815,56 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, } +/* Change class, using gfc_build_class_symbol. This is needed for associate + names, when rank changes or a derived type is produced by resolution. */ + +void +gfc_change_class (gfc_typespec *ts, symbol_attribute *sym_attr, + gfc_array_spec *sym_as, int rank, int corank) +{ + symbol_attribute attr; + gfc_component *c; + gfc_array_spec *as = NULL; + gfc_symbol *der = ts->u.derived; + + ts->type = BT_CLASS; + attr = *sym_attr; + attr.class_ok = 0; + attr.associate_var = 1; + attr.class_pointer = 1; + attr.allocatable = 0; + attr.pointer = 1; + attr.dimension = rank ? 1 : 0; + if (rank) + { + if (sym_as) + as = gfc_copy_array_spec (sym_as); + else + { + as = gfc_get_array_spec (); + as->rank = rank; + as->type = AS_DEFERRED; + as->corank = corank; + } + } + if (as && as->corank != 0) + attr.codimension = 1; + + if (!gfc_build_class_symbol (ts, &attr, &as)) + gcc_unreachable (); + + gfc_set_sym_referenced (ts->u.derived); + + /* Make sure the _vptr is set. */ + c = gfc_find_component (ts->u.derived, "_vptr", true, true, NULL); + if (c->ts.u.derived == NULL) + c->ts.u.derived = gfc_find_derived_vtab (der); + /* _vptr now has the _vtab in it, change it to the _vtype. */ + if (c->ts.u.derived->attr.vtab) + c->ts.u.derived = c->ts.u.derived->ts.u.derived; +} + + /* Add a procedure pointer component to the vtype to represent a specific type-bound procedure. */ diff --git a/gcc/fortran/dump-parse-tree.cc b/gcc/fortran/dump-parse-tree.cc index ecf71036444..a233f9f1110 100644 --- a/gcc/fortran/dump-parse-tree.cc +++ b/gcc/fortran/dump-parse-tree.cc @@ -2690,11 +2690,20 @@ show_code_node (int level, gfc_code *c) case EXEC_BLOCK: { - const char* blocktype; + const char *blocktype, *sname = NULL; gfc_namespace *saved_ns; gfc_association_list *alist; - if (c->ext.block.assoc) + if (c->ext.block.ns && c->ext.block.ns->code + && c->ext.block.ns->code->op == EXEC_SELECT_TYPE) + { + gfc_expr *fcn = c->ext.block.ns->code->expr1; + blocktype = "SELECT TYPE"; + /* expr1 is _loc(assoc_name->vptr) */ + if (fcn && fcn->expr_type == EXPR_FUNCTION) + sname = fcn->value.function.actual->expr->symtree->n.sym->name; + } + else if (c->ext.block.assoc) blocktype = "ASSOCIATE"; else blocktype = "BLOCK"; @@ -2702,7 +2711,7 @@ show_code_node (int level, gfc_code *c) fprintf (dumpfile, "%s ", blocktype); for (alist = c->ext.block.assoc; alist; alist = alist->next) { - fprintf (dumpfile, " %s = ", alist->name); + fprintf (dumpfile, " %s = ", sname ? sname : alist->name); show_expr (alist->target); } @@ -2733,7 +2742,7 @@ show_code_node (int level, gfc_code *c) if (c->op == EXEC_SELECT_RANK) fputs ("SELECT RANK ", dumpfile); else if (c->op == EXEC_SELECT_TYPE) - fputs ("SELECT TYPE ", dumpfile); + fputs ("SELECT CASE ", dumpfile); // Preceded by SELECT TYPE construct else fputs ("SELECT CASE ", dumpfile); show_expr (c->expr1); diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index b5e1b4c9d4b..13d5c5b2244 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -2963,6 +2963,11 @@ typedef struct gfc_association_list locus where; gfc_expr *target; + + /* Used for inferring the derived type of an associate name, whose selector + is a sibling derived type function that has not yet been parsed. */ + gfc_symbol *derived_types; + unsigned inferred_type:1; } gfc_association_list; #define gfc_get_association_list() XCNEW (gfc_association_list) @@ -3529,6 +3534,7 @@ bool gfc_add_component (gfc_symbol *, const char *, gfc_component **); gfc_symbol *gfc_use_derived (gfc_symbol *); gfc_component *gfc_find_component (gfc_symbol *, const char *, bool, bool, gfc_ref **); +int gfc_find_derived_types (gfc_symbol *, gfc_namespace *, const char *); gfc_st_label *gfc_get_st_label (int); void gfc_free_st_label (gfc_st_label *); @@ -3794,6 +3800,7 @@ void gfc_free_association_list (gfc_association_list *); void gfc_expression_rank (gfc_expr *); bool gfc_op_rank_conformable (gfc_expr *, gfc_expr *); bool gfc_resolve_ref (gfc_expr *); +void gfc_fixup_inferred_type_refs (gfc_expr *); bool gfc_resolve_expr (gfc_expr *); void gfc_resolve (gfc_namespace *); void gfc_resolve_code (gfc_code *, gfc_namespace *); @@ -3987,6 +3994,8 @@ unsigned int gfc_hash_value (gfc_symbol *); gfc_expr *gfc_get_len_component (gfc_expr *e, int); bool gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, gfc_array_spec **); +void gfc_change_class (gfc_typespec *, symbol_attribute *, + gfc_array_spec *, int, int); gfc_symbol *gfc_find_derived_vtab (gfc_symbol *); gfc_symbol *gfc_find_vtab (gfc_typespec *); gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, bool*, @@ -4017,6 +4026,10 @@ bool gfc_may_be_finalized (gfc_typespec); #define IS_PROC_POINTER(sym) \ (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \ ? CLASS_DATA (sym)->attr.proc_pointer : sym->attr.proc_pointer) +#define IS_INFERRED_TYPE(expr) \ + (expr && expr->expr_type == EXPR_VARIABLE \ + && expr->symtree->n.sym->assoc \ + && expr->symtree->n.sym->assoc->inferred_type) /* frontend-passes.cc */ diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index df9adb359a0..6a523d5ab6e 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -6322,7 +6322,8 @@ gfc_match_select (void) /* Transfer the selector typespec to the associate name. */ static void -copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) +copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector, + bool select_type = false) { gfc_ref *ref; gfc_symbol *assoc_sym; @@ -6405,12 +6406,30 @@ copy_ts_from_selector_to_associate (gfc_expr *associate, gfc_expr *selector) assoc_sym->as = NULL; build_class_sym: - if (selector->ts.type == BT_CLASS) + /* Deal with the very specific case of a SELECT_TYPE selector being an + associate_name whose type has been identified by component references. + It must be assumed that it will be identified as a CLASS expression, + so convert it now. */ + if (select_type + && IS_INFERRED_TYPE (selector) + && selector->ts.type == BT_DERIVED) + { + gfc_find_derived_vtab (selector->ts.u.derived); + /* The correct class container has to be available. */ + assoc_sym->ts.u.derived = selector->ts.u.derived; + assoc_sym->ts.type = BT_CLASS; + assoc_sym->attr.pointer = 1; + if (!selector->ts.u.derived->attr.is_class) + gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as); + associate->ts = assoc_sym->ts; + } + else if (selector->ts.type == BT_CLASS) { /* The correct class container has to be available. */ assoc_sym->ts.type = BT_CLASS; assoc_sym->ts.u.derived = CLASS_DATA (selector) - ? CLASS_DATA (selector)->ts.u.derived : selector->ts.u.derived; + ? CLASS_DATA (selector)->ts.u.derived + : selector->ts.u.derived; assoc_sym->attr.pointer = 1; gfc_build_class_symbol (&assoc_sym->ts, &assoc_sym->attr, &assoc_sym->as); } @@ -6438,7 +6457,7 @@ build_associate_name (const char *name, gfc_expr **e1, gfc_expr **e2) if (expr2->ts.type == BT_UNKNOWN) sym->attr.untyped = 1; else - copy_ts_from_selector_to_associate (expr1, expr2); + copy_ts_from_selector_to_associate (expr1, expr2, true); sym->attr.flavor = FL_VARIABLE; sym->attr.referenced = 1; diff --git a/gcc/fortran/parse.cc b/gcc/fortran/parse.cc index 042a6ad5e59..8c7d269ab96 100644 --- a/gcc/fortran/parse.cc +++ b/gcc/fortran/parse.cc @@ -5149,6 +5149,17 @@ parse_associate (void) sym->declared_at = a->where; gfc_set_sym_referenced (sym); + /* If the selector is a inferred type then the associate_name had better + be as well. Use array references, if present, to identify it as an + array. */ + if (IS_INFERRED_TYPE (a->target)) + { + sym->assoc->inferred_type = 1; + for (gfc_ref *r = a->target->ref; r; r = r->next) + if (r->type == REF_ARRAY) + sym->attr.dimension = 1; + } + /* Initialize the typespec. It is not available in all cases, however, as it may only be set on the target during resolution. Still, sometimes it helps to have it right now -- especially @@ -5175,21 +5186,41 @@ parse_associate (void) && sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)) sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL); + /* If the function has been parsed, go straight to the result to + obtain the expression rank. */ + if (target->expr_type == EXPR_FUNCTION + && target->symtree + && target->symtree->n.sym) + { + tsym = target->symtree->n.sym; + if (!tsym->result) + tsym->result = tsym; + sym->ts = tsym->result->ts; + if (sym->ts.type == BT_CLASS) + { + if (CLASS_DATA (sym)->as) + target->rank = CLASS_DATA (sym)->as->rank; + sym->attr.class_ok = 1; + } + else + target->rank = tsym->result->as ? tsym->result->as->rank : 0; + } + /* Check if the target expression is array valued. This cannot be done by calling gfc_resolve_expr because the context is unavailable. However, the references can be resolved and the rank of the target expression set. */ - if (target->ref && gfc_resolve_ref (target) + if (!sym->assoc->inferred_type + && target->ref && gfc_resolve_ref (target) && target->expr_type != EXPR_ARRAY && target->expr_type != EXPR_COMPCALL) gfc_expression_rank (target); /* Determine whether or not function expressions with unknown type are structure constructors. If so, the function result can be converted - to be a derived type. - TODO: Deal with references to sibling functions that have not yet been - parsed (PRs 89645 and 99065). */ - if (target->expr_type == EXPR_FUNCTION && target->ts.type == BT_UNKNOWN) + to be a derived type. */ + if (target->expr_type == EXPR_FUNCTION + && target->ts.type == BT_UNKNOWN) { gfc_symbol *derived; /* The derived type has a leading uppercase character. */ @@ -5199,16 +5230,7 @@ parse_associate (void) { sym->ts.type = BT_DERIVED; sym->ts.u.derived = derived; - } - else if (target->symtree && (tsym = target->symtree->n.sym)) - { - sym->ts = tsym->result ? tsym->result->ts : tsym->ts; - if (sym->ts.type == BT_CLASS) - { - if (CLASS_DATA (sym)->as) - target->rank = CLASS_DATA (sym)->as->rank; - sym->attr.class_ok = 1; - } + sym->assoc->inferred_type = 0; } } diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index f8a1c09d190..17710b1f99d 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -2057,6 +2057,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, bool unknown; bool inquiry; bool intrinsic; + bool inferred_type; locus old_loc; char sep; @@ -2087,6 +2088,18 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, if (sym->assoc && sym->assoc->target) tgt_expr = sym->assoc->target; + inferred_type = IS_INFERRED_TYPE (primary); + + /* SELECT TYPE and SELECT RANK temporaries within an ASSOCIATE block, whose + selector has not been parsed, can generate errors with array and component + refs.. Use 'inferred_type' as a flag to suppress these errors. */ + if (!inferred_type + && (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) + && !sym->attr.codimension + && sym->attr.select_type_temporary + && !sym->attr.select_rank_temporary) + inferred_type = true; + /* For associate names, we may not yet know whether they are arrays or not. If the selector expression is unambiguously an array; eg. a full array or an array section, then the associate name must be an array and we can @@ -2136,7 +2149,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, sym->ts.u.derived = tgt_expr->ts.u.derived; } - if ((equiv_flag && gfc_peek_ascii_char () == '(') + if ((inferred_type && !sym->as && gfc_peek_ascii_char () == '(') + || (equiv_flag && gfc_peek_ascii_char () == '(') || gfc_peek_ascii_char () == '[' || sym->attr.codimension || (sym->attr.dimension && sym->ts.type != BT_CLASS && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary) @@ -2194,7 +2208,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, inquiry = false; if (m == MATCH_YES && sep == '%' && primary->ts.type != BT_CLASS - && primary->ts.type != BT_DERIVED) + && (primary->ts.type != BT_DERIVED || inferred_type)) { match mm; old_loc = gfc_current_locus; @@ -2209,7 +2223,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, gfc_set_default_type (sym, 0, sym->ns); /* See if there is a usable typespec in the "no IMPLICIT type" error. */ - if (sym->ts.type == BT_UNKNOWN && m == MATCH_YES) + if ((sym->ts.type == BT_UNKNOWN || inferred_type) + && m == MATCH_YES) { bool permissible; @@ -2228,9 +2243,34 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, sym->ts = tgt_expr->ts; } + /* If this hasn't done the trick and the target expression is a function, + then this must be a derived type if 'name' matches an accessible type + both in this namespace and the as yet unparsed sibling function. */ + if (tgt_expr && tgt_expr->expr_type == EXPR_FUNCTION + && (sym->ts.type == BT_UNKNOWN || inferred_type) + && gfc_find_derived_types (sym, gfc_current_ns, name)) + { + sym->assoc->inferred_type = 1; + /* The first returned type is as good as any at this stage. */ + gfc_symbol **dts = &sym->assoc->derived_types; + tgt_expr->ts.type = BT_DERIVED; + tgt_expr->ts.kind = 0; + tgt_expr->ts.u.derived = *dts; + sym->ts = tgt_expr->ts; + /* Delete the dt list to prevent interference with trans-type.cc's + treatment of derived type decls, even if this process has to be + done again for another primary expression. */ + while (*dts && (*dts)->dt_next) + { + gfc_symbol **tmp = &(*dts)->dt_next; + *dts = NULL; + dts = tmp; + } + } + if (sym->ts.type == BT_UNKNOWN) { - gfc_error ("Symbol %qs at %C has no IMPLICIT type", sym->name); + gfc_error ("Symbol %qs at %C has no IMPLICIT type(primary)", sym->name); return MATCH_ERROR; } } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 2925f7da28c..dcf8750ba97 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -5866,6 +5866,13 @@ resolve_variable (gfc_expr *e) return false; } + /* Guessed type variables are associate_names whose selector had not been + parsed at the time that the construct was parsed. Now the namespace is + being resolved, the TKR of the selector will be available for fixup of + the associate_name. */ + if (IS_INFERRED_TYPE (e) && e->ref) + gfc_fixup_inferred_type_refs (e); + /* For variables that are used in an associate (target => object) where the object's basetype is array valued while the target is scalar, the ts' type of the component refs is still array valued, which @@ -6171,6 +6178,124 @@ resolve_procedure: } +/* 'sym' was initially guessed to be derived type but has been corrected + in resolve_assoc_var to be a class entity or the derived type correcting. + If a class entity it will certainly need the _data reference or the + reference derived type symbol correcting in the first component ref if + a derived type. */ + +void +gfc_fixup_inferred_type_refs (gfc_expr *e) +{ + gfc_ref *ref; + gfc_symbol *sym, *derived; + + sym = e->symtree->n.sym; + + /* This is an associate_name whose selector is a component ref of a selector + that is a inferred type associate_name. */ + if (sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS) + { + e->rank = sym->as ? sym->as->rank : 0; + sym->attr.dimension = e->rank ? 1 : 0; + if (!e->rank && e->ref->type == REF_ARRAY) + { + ref = e->ref; + e->ref = ref->next; + free (ref); + } + return; + } + + derived = sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->ts.u.derived + : sym->ts.u.derived; + + /* Ensure that class symbols have an array spec and ensure that there + is a _data field reference following class type references. */ + if (sym->ts.type == BT_CLASS + && sym->assoc->target->ts.type == BT_CLASS) + { + e->rank = CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->rank : 0; + sym->attr.dimension = 0; + CLASS_DATA (sym)->attr.dimension = e->rank ? 1 : 0; + if (e->ref && (e->ref->type != REF_COMPONENT + || e->ref->u.c.component->name[0] != '_')) + { + ref = gfc_get_ref (); + ref->type = REF_COMPONENT; + ref->next = e->ref; + e->ref = ref; + ref->u.c.component = gfc_find_component (sym->ts.u.derived, "_data", + true, true, NULL); + ref->u.c.sym = sym->ts.u.derived; + } + } + + /* Proceed as far as the first component reference and ensure that the + correct derived type is being used. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + { + if (ref->u.c.component->name[0] != '_') + ref->u.c.sym = derived; + else + ref->u.c.sym = sym->ts.u.derived; + break; + } + + gfc_expr *target = sym->assoc->target; + if (sym->ts.type == BT_CLASS + && IS_INFERRED_TYPE (target) + && target->ts.type == BT_DERIVED + && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived + && target->ref && target->ref->next + && target->ref->next->type == REF_ARRAY) + target->ts = target->symtree->n.sym->ts; + + /* Verify that the type inferrence mechanism has not introduced a spurious + array reference. This can happen with an associate name, whose selector + is an element of another inferred type. */ + if (!(sym->ts.type == BT_CLASS ? CLASS_DATA (sym)->as : sym->as) + && e != e->symtree->n.sym->assoc->target + && !e->symtree->n.sym->assoc->target->rank) + { + /* First case: array ref after the scalar class or derived associate_name. */ + if (e->ref && e->ref->type == REF_ARRAY + && e->ref->u.ar.type != AR_ELEMENT) + { + ref = e->ref; + e->ref = ref->next; + free (ref); + + /* If it hasn't a ref to the '_data' field supply one. */ + if (sym->ts.type == BT_CLASS + && !(e->ref->type == REF_COMPONENT + && strcmp (e->ref->u.c.component->name, "_data"))) + { + gfc_ref *new_ref; + gfc_find_component (e->symtree->n.sym->ts.u.derived, + "_data", true, true, &new_ref); + new_ref->next = e->ref; + e->ref = new_ref; + } + } + /* 2nd case: a ref to the '_data' field followed by an array ref. */ + else if (e->ref && e->ref->type == REF_COMPONENT + && strcmp (e->ref->u.c.component->name, "_data") == 0 + && e->ref->next && e->ref->next->type == REF_ARRAY + && e->ref->next->u.ar.type != AR_ELEMENT) + { + ref = e->ref->next; + e->ref->next = e->ref->next->next; + free (ref); + } + } + + /* Now that all the references are OK, get the expression rank. */ + gfc_expression_rank (e); +} + + /* Checks to see that the correct symbol has been host associated. The only situations where this arises are: (i) That in which a twice contained function is parsed after @@ -9263,6 +9388,46 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) return; } + if (sym->assoc->inferred_type || IS_INFERRED_TYPE (target)) + { + symbol_attribute attr; + + /* By now, the type of the target has been fixed up. */ + if (sym->ts.type == BT_DERIVED + && target->ts.type == BT_CLASS + && !UNLIMITED_POLY (target)) + { + sym->ts = CLASS_DATA (target)->ts; + if (!sym->as) + sym->as = gfc_copy_array_spec (CLASS_DATA (target)->as); + attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; + sym->attr.dimension = target->rank ? 1 : 0; + gfc_change_class (&sym->ts, &attr, sym->as, + target->rank, gfc_get_corank (target)); + sym->as = NULL; + } + else if (target->ts.type == BT_DERIVED + && target->symtree->n.sym->ts.type == BT_CLASS + && IS_INFERRED_TYPE (target) + && target->ref && target->ref->next + && target->ref->next->type == REF_ARRAY + && !target->ref->next->next) + { + sym->ts = target->ts; + attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; + sym->attr.dimension = target->rank ? 1 : 0; + gfc_change_class (&sym->ts, &attr, sym->as, + target->rank, gfc_get_corank (target)); + sym->as = NULL; + target->ts = sym->ts; + } + else if ((target->ts.type == BT_DERIVED) + || (sym->ts.type == BT_CLASS && target->ts.type == BT_CLASS + && CLASS_DATA (target)->as && !CLASS_DATA (sym)->as)) + sym->ts = target->ts; + } + + if (target->expr_type == EXPR_NULL) { gfc_error ("Selector at %L cannot be NULL()", &target->where); @@ -9289,15 +9454,50 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) || gfc_is_ptr_fcn (target)); /* Finally resolve if this is an array or not. */ + if (target->expr_type == EXPR_FUNCTION + && (sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED)) + { + gfc_expression_rank (target); + if (target->ts.type == BT_DERIVED + && !sym->as + && target->symtree->n.sym->as) + { + sym->as = gfc_copy_array_spec (target->symtree->n.sym->as); + sym->attr.dimension = 1; + } + else if (target->ts.type == BT_CLASS + && CLASS_DATA (target)->as) + { + target->rank = CLASS_DATA (target)->as->rank; + if (!(sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as)) + { + sym->ts = target->ts; + sym->attr.dimension = 0; + } + } + } + + if (sym->attr.dimension && target->rank == 0) { /* primary.cc makes the assumption that a reference to an associate name followed by a left parenthesis is an array reference. */ - if (sym->ts.type != BT_CHARACTER) - gfc_error ("Associate-name %qs at %L is used as array", - sym->name, &sym->declared_at); - sym->attr.dimension = 0; - return; + if (sym->assoc->inferred_type && sym->ts.type != BT_CLASS) + { + gfc_expression_rank (sym->assoc->target); + sym->attr.dimension = sym->assoc->target->rank ? 1 : 0; + if (!sym->attr.dimension && sym->as) + sym->as = NULL; + } + + if (sym->attr.dimension && target->rank == 0) + { + if (sym->ts.type != BT_CHARACTER) + gfc_error ("Associate-name %qs at %L is used as array", + sym->name, &sym->declared_at); + sym->attr.dimension = 0; + return; + } } /* We cannot deal with class selectors that need temporaries. */ @@ -9356,7 +9556,7 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) correct this now. */ gfc_typespec *ts = &target->ts; gfc_ref *ref; - gfc_component *c; + for (ref = target->ref; ref != NULL; ref = ref->next) { switch (ref->type) @@ -9374,32 +9574,15 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) } /* Create a scalar instance of the current class type. Because the rank of a class array goes into its name, the type has to be - rebuild. The alternative of (re-)setting just the attributes + rebuilt. The alternative of (re-)setting just the attributes and as in the current type, destroys the type also in other places. */ as = NULL; sym->ts = *ts; sym->ts.type = BT_CLASS; attr = CLASS_DATA (sym) ? CLASS_DATA (sym)->attr : sym->attr; - attr.class_ok = 0; - attr.associate_var = 1; - attr.dimension = attr.codimension = 0; - attr.class_pointer = 1; - if (!gfc_build_class_symbol (&sym->ts, &attr, &as)) - gcc_unreachable (); - /* Make sure the _vptr is set. */ - c = gfc_find_component (sym->ts.u.derived, "_vptr", true, true, NULL); - if (c->ts.u.derived == NULL) - c->ts.u.derived = gfc_find_derived_vtab (sym->ts.u.derived); - CLASS_DATA (sym)->attr.pointer = 1; - CLASS_DATA (sym)->attr.class_pointer = 1; - gfc_set_sym_referenced (sym->ts.u.derived); - gfc_commit_symbol (sym->ts.u.derived); - /* _vptr now has the _vtab in it, change it to the _vtype. */ - if (c->ts.u.derived->attr.vtab) - c->ts.u.derived = c->ts.u.derived->ts.u.derived; - c->ts.u.derived->ns->types_resolved = 0; - resolve_types (c->ts.u.derived->ns); + gfc_change_class (&sym->ts, &attr, as, 0, 0); + sym->as = NULL; } } @@ -9443,6 +9626,14 @@ resolve_assoc_var (gfc_symbol* sym, bool resolve_target) } } + if (sym->ts.type == BT_CLASS + && IS_INFERRED_TYPE (target) + && target->ts.type == BT_DERIVED + && CLASS_DATA (sym)->ts.u.derived == target->ts.u.derived + && target->ref && target->ref->next + && target->ref->next->type == REF_ARRAY) + target->ts = target->symtree->n.sym->ts; + /* If the target is a good class object, so is the associate variable. */ if (sym->ts.type == BT_CLASS && gfc_expr_attr (target).class_ok) sym->attr.class_ok = 1; diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index a6078bc608a..f66831df15f 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -291,6 +291,19 @@ bool gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) { gfc_typespec *ts; + gfc_expr *e; + + /* Check to see if a function selector of unknown type can be resolved. */ + if (sym->assoc + && (e = sym->assoc->target) + && e->expr_type == EXPR_FUNCTION) + { + if (e->ts.type == BT_UNKNOWN) + gfc_resolve_expr (e); + sym->ts = e->ts; + if (sym->ts.type != BT_UNKNOWN) + return true; + } if (sym->ts.type != BT_UNKNOWN) gfc_internal_error ("gfc_set_default_type(): symbol already has a type"); @@ -307,7 +320,7 @@ gfc_set_default_type (gfc_symbol *sym, int error_flag, gfc_namespace *ns) "; did you mean %qs?", sym->name, &sym->declared_at, guessed); else - gfc_error ("Symbol %qs at %L has no IMPLICIT type", + gfc_error ("Symbol %qs at %L has no IMPLICIT type(symbol)", sym->name, &sym->declared_at); sym->attr.untyped = 1; /* Ensure we only give an error once. */ } @@ -2402,6 +2415,66 @@ bad: } +/* Find all derived types in the uppermost namespace that have a component + a component called name and stash them in the assoc field of an + associate name variable. + This is used to infer the derived type of an associate name, whose selector + is a sibling derived type function that has not yet been parsed. Either + the derived type is use associated in both contained and sibling procedures + or it appears in the uppermost namespace. */ + +static int cts = 0; +static void +find_derived_types (gfc_symbol *sym, gfc_symtree *st, const char *name, + bool contained) +{ + if (st->n.sym && st->n.sym->attr.flavor == FL_DERIVED + && !st->n.sym->attr.is_class + && ((contained && st->n.sym->attr.use_assoc) || !contained) + && gfc_find_component (st->n.sym, name, true, true, NULL)) + { + /* Do the stashing. */ + cts++; + if (sym->assoc->derived_types) + st->n.sym->dt_next = sym->assoc->derived_types; + sym->assoc->derived_types = st->n.sym; + } + + if (st->left) + find_derived_types (sym, st->left, name, contained); + + if (st->right) + find_derived_types (sym, st->right, name, contained); +} + +int +gfc_find_derived_types (gfc_symbol *sym, gfc_namespace *ns, const char *name) +{ + gfc_namespace *encompassing = NULL; + gcc_assert (sym->assoc); + + cts = 0; + while (ns->parent) + { + if (!ns->parent->parent && ns->proc_name + && (ns->proc_name->attr.function || ns->proc_name->attr.subroutine)) + encompassing = ns; + ns = ns->parent; + } + + if (!ns->contained) + return cts; + + /* Search the top level namespace first. */ + find_derived_types (sym, ns->sym_root, name, false); + + /* Then the encompassing namespace. */ + if (encompassing) + find_derived_types (sym, encompassing->sym_root, name, true); + + return cts; +} + /* Find the component with the given name in the union type symbol. If ref is not NULL it will be set to the chain of components through which the component can actually be accessed. This is necessary for unions because diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc index f4185db5b7f..3dac9d990f0 100644 --- a/gcc/fortran/trans-expr.cc +++ b/gcc/fortran/trans-expr.cc @@ -3134,6 +3134,10 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr) gcc_assert (se->string_length); } + /* Some expressions leak through that haven't been fixed up. */ + if (IS_INFERRED_TYPE (expr) && expr->ref) + gfc_fixup_inferred_type_refs (expr); + gfc_typespec *ts = &sym->ts; while (ref) { diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 517b7aaa898..bf4f1876969 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -1746,9 +1746,9 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) e = sym->assoc->target; class_target = (e->expr_type == EXPR_VARIABLE) - && e->ts.type == BT_CLASS - && (gfc_is_class_scalar_expr (e) - || gfc_is_class_array_ref (e, NULL)); + && e->ts.type == BT_CLASS + && (gfc_is_class_scalar_expr (e) + || gfc_is_class_array_ref (e, NULL)); unlimited = UNLIMITED_POLY (e); @@ -2156,26 +2156,36 @@ trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) { tree stmp; tree dtmp; + tree ctmp; - se.expr = ctree; + ctmp = ctree; dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl)); ctree = gfc_create_var (dtmp, "class"); - stmp = gfc_class_data_get (se.expr); + if (IS_INFERRED_TYPE (e) + && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))) + stmp = se.expr; + else + stmp = gfc_class_data_get (ctmp); + /* Coarray scalar component expressions can emerge from the front end as array elements of the _data field. */ if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp))) stmp = gfc_conv_descriptor_data_get (stmp); + + if (!POINTER_TYPE_P (TREE_TYPE (stmp))) + stmp = gfc_build_addr_expr (NULL, stmp); + dtmp = gfc_class_data_get (ctree); stmp = fold_convert (TREE_TYPE (dtmp), stmp); gfc_add_modify (&se.pre, dtmp, stmp); - stmp = gfc_class_vptr_get (se.expr); + stmp = gfc_class_vptr_get (ctmp); dtmp = gfc_class_vptr_get (ctree); stmp = fold_convert (TREE_TYPE (dtmp), stmp); gfc_add_modify (&se.pre, dtmp, stmp); if (UNLIMITED_POLY (sym)) { - stmp = gfc_class_len_get (se.expr); + stmp = gfc_class_len_get (ctmp); dtmp = gfc_class_len_get (ctree); stmp = fold_convert (TREE_TYPE (dtmp), stmp); gfc_add_modify (&se.pre, dtmp, stmp);