From patchwork Wed Aug 4 19:28:38 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Daniel Kraft X-Patchwork-Id: 60889 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]) by ozlabs.org (Postfix) with SMTP id E62AA100823 for ; Thu, 5 Aug 2010 05:23:48 +1000 (EST) Received: (qmail 28802 invoked by alias); 4 Aug 2010 19:23:44 -0000 Received: (qmail 28770 invoked by uid 22791); 4 Aug 2010 19:23:40 -0000 X-SWARE-Spam-Status: No, hits=-2.5 required=5.0 tests=AWL, BAYES_00, RCVD_IN_DNSWL_LOW, SPF_HELO_PASS X-Spam-Check-By: sourceware.org Received: from taro.utanet.at (HELO taro.utanet.at) (213.90.36.45) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 04 Aug 2010 19:23:31 +0000 Received: from plenty.xoc.tele2net.at ([213.90.36.8]) by taro.utanet.at with esmtp (Exim 4.71) (envelope-from ) id 1OgjYm-0003Q9-Sw; Wed, 04 Aug 2010 21:23:28 +0200 Received: from d86-33-197-26.cust.tele2.at ([86.33.197.26] helo=[192.168.1.18]) by plenty.xoc.tele2net.at with esmtpa (Exim 4.71) (envelope-from ) id 1OgjYm-00078o-Ap; Wed, 04 Aug 2010 21:23:28 +0200 Message-ID: <4C59BF66.6070200@domob.eu> Date: Wed, 04 Aug 2010 21:28:38 +0200 From: Daniel Kraft User-Agent: Thunderbird 2.0.0.0 (X11/20070425) MIME-Version: 1.0 To: Fortran List CC: gcc-patches Subject: [Patch, Fortran] ASSOCIATE to array-expressions 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 Hi, the attached patch fixes some problems that turned up during ASSOCIATE work (like the expr.c and trans-decl.c change). But most notably, it implements association to array expressions; still in a somewhat limited fashin, unfortunately. However, for instance Tobias' original PR example works now. In general I see two "problems" with associate that are partially touched and handled by this patch, which may need further work to implement them better: * It may not be known until resolution if a variable is an array or of what type it is. This is handled for arrays in the current patch; I believe however, that for association to derived-types this may be a huge problem and need some substantial rework and thinking about. I may be wrong, though. * The variables backing an associate-name are currently built as AS_EXPLICIT arrays, and the bounds set as LBOUND/UBOUND of the target expression. Since my last patch, the simplifier is able to reduce a lot of these to constants or simple expressions, but not all. If it is not able to do so, the target expression is actually evaluated a lot of times (instead just once -- this might still be strictly standard conforming, but surely not the way to go); additionally in this case, an error is issued if the expression is not a valid initialization-expression. See the XFAIL'ed test-case for instance -- it works, but with two calls to func instead of one; if func is declared non-PURE there, it does not even compile. I think we will have to rework this and introduce some way to mark array variables as "temporaries" for some expression, and let trans-* do the bounds stuff. This will be also useful for FINAL, I think. (And maybe other front-end lowering.) But for now I think that this patch is worthwhile introducing, even if we still have to find a "final" solution to some issues in the future. Regtesting on GNU/Linux-x86-32 at the moment. Ok if successful? Yours, Daniel Index: gcc/fortran/symbol.c =================================================================== --- gcc/fortran/symbol.c (revision 162841) +++ gcc/fortran/symbol.c (working copy) @@ -4744,3 +4744,19 @@ gfc_type_compatible (gfc_typespec *ts1, else return 0; } + + +/* Find the parent-namespace of the current function. If we're inside + BLOCK constructs, it may not be the current one. */ + +gfc_namespace* +gfc_find_proc_namespace (gfc_namespace* ns) +{ + while (ns->construct_entities) + { + ns = ns->parent; + gcc_assert (ns); + } + + return ns; +} Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (revision 162841) +++ gcc/fortran/gfortran.h (working copy) @@ -2577,6 +2577,7 @@ void gfc_copy_formal_args_ppc (gfc_compo void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */ gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus); +gfc_namespace* gfc_find_proc_namespace (gfc_namespace*); /* intrinsic.c -- true if working in an init-expr, false otherwise. */ extern bool gfc_init_expr_flag; Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (revision 162841) +++ gcc/fortran/expr.c (working copy) @@ -4221,7 +4221,6 @@ gfc_build_intrinsic_call (const char* na result->expr_type = EXPR_FUNCTION; result->ts = isym->ts; result->where = where; - gfc_get_ha_sym_tree (isym->name, &result->symtree); result->value.function.name = name; result->value.function.isym = isym; Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (revision 162841) +++ gcc/fortran/resolve.c (working copy) @@ -4705,11 +4705,26 @@ resolve_variable (gfc_expr *e) if (e->symtree == NULL) return FAILURE; + sym = e->symtree->n.sym; + + /* If this is an associate-name, it may be parsed with references in error + even though the target is scalar. Fail directly in this case. */ + if (sym->assoc && !sym->attr.dimension && e->ref) + return FAILURE; + + /* On the other hand, the parser may not have known this is an array; + in this case, we have to add a FULL reference. */ + if (sym->assoc && sym->attr.dimension && !e->ref) + { + e->ref = gfc_get_ref (); + e->ref->type = REF_ARRAY; + e->ref->u.ar.type = AR_FULL; + e->ref->u.ar.dimen = 0; + } if (e->ref && resolve_ref (e) == FAILURE) return FAILURE; - sym = e->symtree->n.sym; if (sym->attr.flavor == FL_PROCEDURE && (!sym->attr.function || (sym->attr.function && sym->result @@ -8155,11 +8170,43 @@ gfc_resolve_forall (gfc_code *code, gfc_ static void resolve_block_construct (gfc_code* code) { - /* For an ASSOCIATE block, the associations (and their targets) are already - resolved during gfc_resolve_symbol. */ - /* Resolve the BLOCK's namespace. */ gfc_resolve (code->ext.block.ns); + + /* For an ASSOCIATE block, the associations (and their targets) are already + resolved during gfc_resolve_symbol. Here, we have to add code + to assign expression values to the variables associated to expressions. */ + if (code->ext.block.assoc) + { + gfc_association_list* a; + gfc_code* assignTail; + gfc_code* assignHead; + + assignHead = assignTail = NULL; + for (a = code->ext.block.assoc; a; a = a->next) + if (!a->variable) + { + gfc_code* newAssign; + + newAssign = gfc_get_code (); + newAssign->op = EXEC_ASSIGN; + newAssign->loc = gfc_current_locus; + newAssign->expr1 = gfc_lval_expr_from_sym (a->st->n.sym); + newAssign->expr2 = a->target; + + if (!assignHead) + assignHead = newAssign; + else + { + gcc_assert (assignTail); + assignTail->next = newAssign; + } + assignTail = newAssign; + } + + assignTail->next = code->ext.block.ns->code; + code->ext.block.ns->code = assignHead; + } } @@ -8644,7 +8691,7 @@ resolve_code (gfc_code *code, gfc_namesp break; case EXEC_BLOCK: - gfc_resolve (code->ext.block.ns); + resolve_block_construct (code); break; case EXEC_DO: @@ -11530,6 +11577,54 @@ resolve_symbol (gfc_symbol *sym) sym->ts = sym->assoc->target->ts; gcc_assert (sym->ts.type != BT_UNKNOWN); + + if (sym->attr.dimension && sym->assoc->target->rank == 0) + { + gfc_error ("Associate-name '%s' at %L is used as array", + sym->name, &sym->declared_at); + sym->attr.dimension = 0; + return; + } + if (sym->assoc->target->rank > 0) + sym->attr.dimension = 1; + + if (sym->attr.dimension) + { + int dim; + + sym->as = gfc_get_array_spec (); + sym->as->rank = sym->assoc->target->rank; + sym->as->type = AS_EXPLICIT; + + /* Target must not be coindexed, thus the associate-variable + has no corank. */ + sym->as->corank = 0; + + for (dim = 0; dim < sym->assoc->target->rank; ++dim) + { + gfc_expr* dim_expr; + gfc_expr* e; + + dim_expr = gfc_get_constant_expr (BT_INTEGER, + gfc_default_integer_kind, + &sym->declared_at); + mpz_set_si (dim_expr->value.integer, dim + 1); + + e = gfc_build_intrinsic_call ("lbound", sym->declared_at, 3, + gfc_copy_expr (sym->assoc->target), + gfc_copy_expr (dim_expr), NULL); + gfc_resolve_expr (e); + sym->as->lower[dim] = e; + + e = gfc_build_intrinsic_call ("ubound", sym->declared_at, 3, + gfc_copy_expr (sym->assoc->target), + gfc_copy_expr (dim_expr), NULL); + gfc_resolve_expr (e); + sym->as->upper[dim] = e; + + gfc_free_expr (dim_expr); + } + } } /* Assign default type to symbols that need one and don't have one. */ Index: gcc/fortran/trans-decl.c =================================================================== --- gcc/fortran/trans-decl.c (revision 162841) +++ gcc/fortran/trans-decl.c (working copy) @@ -658,6 +658,7 @@ gfc_build_qualified_array (tree decl, gf tree type; int dim; int nest; + gfc_namespace* procns; type = TREE_TYPE (decl); @@ -666,7 +667,8 @@ gfc_build_qualified_array (tree decl, gf return; gcc_assert (GFC_ARRAY_TYPE_P (type)); - nest = (sym->ns->proc_name->backend_decl != current_function_decl) + procns = gfc_find_proc_namespace (sym->ns); + nest = (procns->proc_name->backend_decl != current_function_decl) && !sym->attr.contained; for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++) Index: gcc/fortran/parse.c =================================================================== --- gcc/fortran/parse.c (revision 162841) +++ gcc/fortran/parse.c (working copy) @@ -3214,7 +3214,6 @@ parse_associate (void) gfc_state_data s; gfc_statement st; gfc_association_list* a; - gfc_code* assignTail; gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C"); @@ -3224,46 +3223,24 @@ parse_associate (void) new_st.ext.block.ns = my_ns; gcc_assert (new_st.ext.block.assoc); - /* Add all associations to expressions as BLOCK variables, and create - assignments to them giving their values. */ + /* Add all associate-names as BLOCK variables. There values will be assigned + to them during resolution of the ASSOCIATE construct. */ gfc_current_ns = my_ns; - assignTail = NULL; for (a = new_st.ext.block.assoc; a; a = a->next) - if (!a->variable) - { - gfc_code* newAssign; - - if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) - gcc_unreachable (); - - /* Note that in certain cases, the target-expression's type is not yet - known and so we have to adapt the symbol's ts also during resolution - for these cases. */ - a->st->n.sym->ts = a->target->ts; - a->st->n.sym->attr.flavor = FL_VARIABLE; - a->st->n.sym->assoc = a; - gfc_set_sym_referenced (a->st->n.sym); - - /* Create the assignment to calculate the expression and set it. */ - newAssign = gfc_get_code (); - newAssign->op = EXEC_ASSIGN; - newAssign->loc = gfc_current_locus; - newAssign->expr1 = gfc_get_variable_expr (a->st); - newAssign->expr2 = a->target; - - /* Hang it in. */ - if (assignTail) - assignTail->next = newAssign; - else - gfc_current_ns->code = newAssign; - assignTail = newAssign; - } - else - { - gfc_error ("Association to variables is not yet supported at %C"); - return; - } - gcc_assert (assignTail); + { + if (a->variable) + { + gfc_error ("Association to variables is not yet supported at %C"); + return; + } + + if (gfc_get_sym_tree (a->name, NULL, &a->st, false)) + gcc_unreachable (); + + a->st->n.sym->attr.flavor = FL_VARIABLE; + a->st->n.sym->assoc = a; + gfc_set_sym_referenced (a->st->n.sym); + } accept_statement (ST_ASSOCIATE); push_state (&s, COMP_ASSOCIATE, my_ns->proc_name); @@ -3277,7 +3254,7 @@ loop: case_end: accept_statement (st); - assignTail->next = gfc_state_stack->head; + my_ns->code = gfc_state_stack->head; break; default: Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (revision 162841) +++ gcc/fortran/primary.c (working copy) @@ -1748,6 +1748,13 @@ gfc_match_varspec (gfc_expr *primary, in } } + /* For associate names, we may not yet know whether they are arrays or not. + Thus if we have one and parentheses follow, we have to assume that it + actually is one for now. The final decision will be made at + resolution time, of course. */ + if (sym->assoc && gfc_peek_ascii_char () == '(') + sym->attr.dimension = 1; + if ((equiv_flag && gfc_peek_ascii_char () == '(') || gfc_peek_ascii_char () == '[' || sym->attr.codimension || (sym->attr.dimension && !sym->attr.proc_pointer Index: gcc/testsuite/gfortran.dg/associate_3.f03 =================================================================== --- gcc/testsuite/gfortran.dg/associate_3.f03 (revision 162841) +++ gcc/testsuite/gfortran.dg/associate_3.f03 (working copy) @@ -2,7 +2,7 @@ ! { dg-options "-std=f2003" } ! PR fortran/38936 -! Check for errors with ASSOCIATE. +! Check for errors with ASSOCIATE during parsing. PROGRAM main IMPLICIT NONE Index: gcc/testsuite/gfortran.dg/associate_5.f03 =================================================================== --- gcc/testsuite/gfortran.dg/associate_5.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/associate_5.f03 (revision 0) @@ -0,0 +1,13 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } + +! PR fortran/38936 +! Check for errors with ASSOCIATE during resolution. + +PROGRAM main + IMPLICIT NONE + + ASSOCIATE (a => 5) ! { dg-error "is used as array" } + PRINT *, a(3) + END ASSOCIATE +END PROGRAM main Index: gcc/testsuite/gfortran.dg/associate_6.f03 =================================================================== --- gcc/testsuite/gfortran.dg/associate_6.f03 (revision 0) +++ gcc/testsuite/gfortran.dg/associate_6.f03 (revision 0) @@ -0,0 +1,38 @@ +! { dg-do compile } +! { dg-options "-std=f2003 -fdump-tree-original" } + +! PR fortran/38936 +! Check that array expression association (with correct bounds) works for +! complicated expressions. + +! Contributed by Daniel Kraft, d@domob.eu. + +! FIXME: XFAIL'ed because this is not yet implemented 'correctly'. + +MODULE m + IMPLICIT NONE + +CONTAINS + + PURE FUNCTION func (n) + INTEGER, INTENT(IN) :: n + INTEGER :: func(2 : n+1) + + INTEGER :: i + + func = (/ (i, i = 1, n) /) + END FUNCTION func + +END MODULE m + +PROGRAM main + USE :: m + IMPLICIT NONE + + ASSOCIATE (arr => func (4)) + ! func should only be called once here, not again for the bounds! + END ASSOCIATE +END PROGRAM main +! { dg-final { cleanup-modules "m" } } +! { dg-final { scan-tree-dump-times "func" 2 "original" { xfail *-*-* } } } +! { dg-final { cleanup-tree-dump "original" } } Index: gcc/testsuite/gfortran.dg/associate_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/associate_1.f03 (revision 162841) +++ gcc/testsuite/gfortran.dg/associate_1.f03 (working copy) @@ -24,13 +24,15 @@ PROGRAM main ! TODO: Test association to derived types. ! Test association to arrays. - ! TODO: Enable when working. - !ALLOCATE (arr(3)) - !arr = (/ 1, 2, 3 /) - !ASSOCIATE (doubled => 2 * arr) - ! IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) & - ! CALL abort () - !END ASSOCIATE + ALLOCATE (arr(3)) + arr = (/ 1, 2, 3 /) + ASSOCIATE (doubled => 2 * arr, xyz => func ()) + IF (SIZE (doubled) /= SIZE (arr)) CALL abort () + IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) & + CALL abort () + + IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort () + END ASSOCIATE ! Named and nested associate. myname: ASSOCIATE (x => a - b * c) @@ -46,4 +48,12 @@ PROGRAM main IF (x /= 2 .OR. y /= 1) CALL abort () END ASSOCIATE END ASSOCIATE + +CONTAINS + + FUNCTION func () + INTEGER :: func(3) + func = (/ 1, 3, 5 /) + END FUNCTION func + END PROGRAM main