From patchwork Sat Jan 3 11:29:43 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Janus Weil X-Patchwork-Id: 425103 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id C0C7F140081 for ; Sat, 3 Jan 2015 22:29:54 +1100 (AEDT) DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:date:message-id:subject:from:to:content-type; q= dns; s=default; b=bVKj9w13zutAIK1+yIbS7gLM2GEHo+y8r0vGxnTGltM4DL Sd9iH3uMVIjR02B7W0k8ebsh8qlhtOtMCkDC4o8f4BNAecvCJ6rueLaCYog+vY/3 lBXNZ4nk8Y9UnuCgCGJ8yDzCjHJ7a1gqTKYaXX58bHgcCMiBBnSozB7+Vw2dw= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender :mime-version:date:message-id:subject:from:to:content-type; s= default; bh=/+22m9pCpjfpV4uUq/zvCc4jOjY=; b=t49aER2YtzbPogDN/pIm b3SpYkNrpakwsLzTnpem8neItLlzT1mtvX7M52n0VI4U5zVbYEOGJvh4llgCkrE5 5P8MHDEpDCPL9kGDa7DAlKL9ZrUsr811DCYTuuMIYmYunsiECnWWfXPynIF33q4E iv+bpI9T2bF5EtQuuFzUcMg= Received: (qmail 12226 invoked by alias); 3 Jan 2015 11:29:48 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 12208 invoked by uid 89); 3 Jan 2015 11:29:47 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-2.1 required=5.0 tests=AWL, BAYES_00, FREEMAIL_ENVFROM_END_DIGIT, FREEMAIL_FROM, RCVD_IN_DNSWL_LOW, SPF_PASS autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mail-qa0-f50.google.com Received: from mail-qa0-f50.google.com (HELO mail-qa0-f50.google.com) (209.85.216.50) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES128-SHA encrypted) ESMTPS; Sat, 03 Jan 2015 11:29:45 +0000 Received: by mail-qa0-f50.google.com with SMTP id dc16so13183274qab.23; Sat, 03 Jan 2015 03:29:43 -0800 (PST) MIME-Version: 1.0 X-Received: by 10.140.22.233 with SMTP id 96mr102850649qgn.86.1420284583273; Sat, 03 Jan 2015 03:29:43 -0800 (PST) Received: by 10.96.211.7 with HTTP; Sat, 3 Jan 2015 03:29:43 -0800 (PST) Date: Sat, 3 Jan 2015 12:29:43 +0100 Message-ID: Subject: [Patch, Fortran, OOP] PR 63552: Type-bound procedures rejected as actual argument to dummy procedure From: Janus Weil To: gfortran , gcc-patches Hi all, the attached patch allows type-bound procedures to be passed actual arguments to dummy procedures. When doing this, on has to transform the expression such that the corresponding procedure pointer from the vtab is used. The patch is regtested on x86_64-unknown-linux-gnu. Ok for trunk? Cheers, Janus 2015-01-03 Janus Weil PR fortran/63552 * primary.c (gfc_match_varspec): Handle type-bound procedures as actual argument to dummy procedure. 2015-01-03 Janus Weil PR fortran/63552 * gfortran.dg/typebound_proc_34.f90: New. Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (Revision 219159) +++ gcc/fortran/primary.c (Arbeitskopie) @@ -1826,6 +1826,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl gfc_ref *substring, *tail; gfc_component *component; gfc_symbol *sym = primary->symtree->n.sym; + gfc_symbol *dt = NULL; match m; bool unknown; @@ -1929,7 +1930,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl || gfc_match_char ('%') != MATCH_YES) goto check_substring; - sym = sym->ts.u.derived; + dt = sym->ts.u.derived; for (;;) { @@ -1942,8 +1943,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl if (m != MATCH_YES) return MATCH_ERROR; - if (sym->f2k_derived) - tbp = gfc_find_typebound_proc (sym, &t, name, false, &gfc_current_locus); + if (dt->f2k_derived) + tbp = gfc_find_typebound_proc (dt, &t, name, false, &gfc_current_locus); else tbp = NULL; @@ -1950,6 +1951,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl if (tbp) { gfc_symbol* tbp_sym; + gfc_actual_arglist *actual = NULL; if (!t) return MATCH_ERROR; @@ -1967,37 +1969,48 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl else tbp_sym = tbp->n.tb->u.specific->n.sym; - primary->expr_type = EXPR_COMPCALL; - primary->value.compcall.tbp = tbp->n.tb; - primary->value.compcall.name = tbp->name; - primary->value.compcall.ignore_pass = 0; - primary->value.compcall.assign = 0; - primary->value.compcall.base_object = NULL; - gcc_assert (primary->symtree->n.sym->attr.referenced); if (tbp_sym) primary->ts = tbp_sym->ts; else gfc_clear_ts (&primary->ts); - m = gfc_match_actual_arglist (tbp->n.tb->subroutine, - &primary->value.compcall.actual); + m = gfc_match_actual_arglist (tbp->n.tb->subroutine, &actual); if (m == MATCH_ERROR) return MATCH_ERROR; - if (m == MATCH_NO) + if (m == MATCH_YES || sub_flag) { - if (sub_flag) - primary->value.compcall.actual = NULL; - else - { - gfc_error ("Expected argument list at %C"); - return MATCH_ERROR; - } + primary->expr_type = EXPR_COMPCALL; + primary->value.compcall.tbp = tbp->n.tb; + primary->value.compcall.name = tbp->name; + primary->value.compcall.ignore_pass = 0; + primary->value.compcall.assign = 0; + primary->value.compcall.base_object = NULL; + primary->value.compcall.actual = actual; + gcc_assert (primary->symtree->n.sym->attr.referenced); } + else if (!matching_actual_arglist) + { + gfc_error ("Expected argument list at %C"); + return MATCH_ERROR; + } + else if (sym->ts.type == BT_CLASS) + { + gfc_add_vptr_component (primary); + gfc_add_component_ref (primary, name); + } + else if (sym->ts.type == BT_DERIVED) + { + gfc_symtree *symtree; + gfc_symbol *vtab = gfc_find_derived_vtab (dt); + gfc_find_sym_tree (vtab->name, NULL, 1, &symtree); + primary->symtree = symtree; + gfc_add_component_ref (primary, name); + } break; } - component = gfc_find_component (sym, name, false, false); + component = gfc_find_component (dt, name, false, false); if (component == NULL) return MATCH_ERROR; @@ -2005,7 +2018,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl tail->type = REF_COMPONENT; tail->u.c.component = component; - tail->u.c.sym = sym; + tail->u.c.sym = dt; primary->ts = component->ts; @@ -2058,12 +2071,12 @@ gfc_match_varspec (gfc_expr *primary, int equiv_fl || gfc_match_char ('%') != MATCH_YES) break; - sym = component->ts.u.derived; + dt = component->ts.u.derived; } check_substring: unknown = false; - if (primary->ts.type == BT_UNKNOWN && sym->attr.flavor != FL_DERIVED) + if (primary->ts.type == BT_UNKNOWN && !dt) { if (gfc_get_default_type (sym->name, sym->ns)->type == BT_CHARACTER) {