From patchwork Mon Dec 31 14:11:55 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 208862 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 600662C00A9 for ; Tue, 1 Jan 2013 01:12:23 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1357567944; h=Comment: DomainKey-Signature:Received:Received:Received:Received: Message-ID:Date:From:User-Agent:MIME-Version:To:Subject: Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe: List-Archive:List-Post:List-Help:Sender:Delivered-To; bh=UAdTOgC 64VVNip5/ReE/AkwUE/U=; b=aQwpcoCURVQb0+jA5Vkn7D2QL3RGkn4hN3TUj8n xpxqseCX0ez2YX4b6X2qjKIQkckWvW4TRPBG7+q/wDicbm9ycAFFQME8MHT4va2G LsKr8gXJvxSMj/HIYVuP+gxWU+Lj/puYlFmBBJzwv+xGT70GmbrXPkNQ/f49UgWX uvhM= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Message-ID:Date:From:User-Agent:MIME-Version:To:Subject:Content-Type:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=Tw9DIk6wkTr9v6hm0hN8qi8qYL3sAoEFctjryzpXXTpQqvTZlZhlS9MsniosZj 8i86HMWfCDG++YDbaZpwBgm1w80k0PE/qOTOI3cGRllf11b9rm02VqQRd93cuQlQ KXFJM7as84+pnCdH438nXpdFnuShDZYLNGMWDMllORkgA=; Received: (qmail 20251 invoked by alias); 31 Dec 2012 14:12:09 -0000 Received: (qmail 20232 invoked by uid 22791); 31 Dec 2012 14:12:08 -0000 X-SWARE-Spam-Status: No, hits=-1.4 required=5.0 tests=AWL, BAYES_00, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx02.qsc.de (HELO mx02.qsc.de) (213.148.130.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 31 Dec 2012 14:11:57 +0000 Received: from archimedes.net-b.de (port-92-195-100-21.dynamic.qsc.de [92.195.100.21]) by mx02.qsc.de (Postfix) with ESMTP id 64F5C242F4; Mon, 31 Dec 2012 15:11:55 +0100 (CET) Message-ID: <50E19D2B.9000004@net-b.de> Date: Mon, 31 Dec 2012 15:11:55 +0100 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:17.0) Gecko/17.0 Thunderbird/17.0 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] FINAL (prep patches 4/5): Support noncontiguous arrays in the finalization wrapper function 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 Dear all, this lengthy patch supports noncontiguous arrays in the finalization wrapper. That encompasses bother the scalarizer (used for finalizing the components and for an ELEMENTAL FINAL subroutine) and calling array FINAL subroutines. For the latter, the subroutine is directly called if possible. Namely, when the element size of the actual type is the same as the one of the declared type - and the the FINAL subroutine is either assumed-shape without the contiguous attribute or the actual argument is contiguous. Otherwise, the code packs the array. The code is written such that it works for any array rank. I explicitly avoided using GFC_MAX_DIMENSIONS to allow for more ranks without breaking the ABI. The code consists of two new blocks of code. The new function "finalization_get_offset" which generates the code to translate from an element index to the byte offset - and in generate_finalization_wrapper to fill the array "strides" and "sizes", where the latter contains the multiplied up size, i.e. sizes(0) == 1, sizes(1) = size(array,dim=1), sizes(2) = sizes(1)*size(array,dim=2) etc. Note: Without patch 5/5, this code is never executed. Build and regtested on x86-64-gnu-linux - and tested (with the not submitted patch for invoking the finalizer). OK for the trunk? Tobias 2012-12-31 Tobias Burnus * class.c (finalize_component): Used passed offset expr. (finalization_get_offset): New static function. (finalizer_insert_packed_call, generate_finalization_wrapper): Use it to handle noncontiguous arrays. diff --git a/gcc/fortran/class.c b/gcc/fortran/class.c index 61d65e7..dae1adc 100644 --- a/gcc/fortran/class.c +++ b/gcc/fortran/class.c @@ -924,14 +924,14 @@ finalize_component (gfc_expr *expr, gfc_symbol *derived, gfc_component *comp, /* Generate code equivalent to CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * stride, c_ptr), ptr). */ + + offset, c_ptr), ptr). */ static gfc_code * -finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, - gfc_expr *stride, gfc_namespace *sub_ns) +finalization_scalarizer (gfc_symbol *array, gfc_symbol *ptr, + gfc_expr *offset, gfc_namespace *sub_ns) { gfc_code *block; - gfc_expr *expr, *expr2, *expr3; + gfc_expr *expr, *expr2; /* C_F_POINTER(). */ block = XCNEW (gfc_code); @@ -961,6 +961,7 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, = gfc_intrinsic_function_by_id (GFC_ISYM_TRANSFER); /* Set symtree for -fdump-parse-tree. */ gfc_get_sym_tree ("transfer", sub_ns, &expr2->symtree, false); + expr2->symtree->n.sym->intmod_sym_id = GFC_ISYM_TRANSFER; expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE; expr2->symtree->n.sym->attr.intrinsic = 1; gfc_commit_symbol (expr2->symtree->n.sym); @@ -995,21 +996,12 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, expr->ts.kind = gfc_index_integer_kind; expr2->value.function.actual->expr = expr; - /* Offset calculation: idx * stride (in bytes). */ - block->ext.actual->expr = gfc_get_expr (); - expr3 = block->ext.actual->expr; - expr3->expr_type = EXPR_OP; - expr3->value.op.op = INTRINSIC_TIMES; - expr3->value.op.op1 = gfc_lval_expr_from_sym (idx); - expr3->value.op.op2 = stride; - expr3->ts = expr->ts; - /* + . */ block->ext.actual->expr = gfc_get_expr (); block->ext.actual->expr->expr_type = EXPR_OP; block->ext.actual->expr->value.op.op = INTRINSIC_PLUS; block->ext.actual->expr->value.op.op1 = expr2; - block->ext.actual->expr->value.op.op2 = expr3; + block->ext.actual->expr->value.op.op2 = offset; block->ext.actual->expr->ts = expr->ts; /* C_F_POINTER's 2nd arg: ptr -- and its absent shape=. */ @@ -1021,39 +1013,183 @@ finalization_scalarizer (gfc_symbol *idx, gfc_symbol *array, gfc_symbol *ptr, } +/* Calculates the offset to the (idx+1)th element of an array, taking the + stride into account. It generates the code: + offset = 0 + do idx2 = 1, rank + offset = offset + mod (idx, sizes(idx2)) / size(idx2-1) * strides(idx2) + end do + offset = offset * byte_stride. */ + +static gfc_code* +finalization_get_offset (gfc_symbol *idx, gfc_symbol *idx2, gfc_symbol *offset, + gfc_symbol *strides, gfc_symbol *sizes, + gfc_symbol *byte_stride, gfc_expr *rank, + gfc_code *block, gfc_namespace *sub_ns) +{ + gfc_iterator *iter; + gfc_expr *expr, *expr2; + + /* offset = 0. */ + block->next = XCNEW (gfc_code); + block = block->next; + block->op = EXEC_ASSIGN; + block->loc = gfc_current_locus; + block->expr1 = gfc_lval_expr_from_sym (offset); + block->expr2 = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + + /* Create loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx2); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + iter->end = gfc_copy_expr (rank); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + block->next = XCNEW (gfc_code); + block = block->next; + block->op = EXEC_DO; + block->loc = gfc_current_locus; + block->ext.iterator = iter; + block->block = gfc_get_code (); + block->block->op = EXEC_DO; + + /* Loop body: offset = offset + mod (idx, sizes(idx2)) / sizes(idx2-1) + * strides(idx2). */ + + /* mod (idx, sizes(idx2)). */ + expr = gfc_get_expr (); + expr->expr_type = EXPR_FUNCTION; + expr->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_MOD); + gfc_get_sym_tree ("mod", sub_ns, &expr->symtree, false); + expr->symtree->n.sym->intmod_sym_id = GFC_ISYM_MOD; + expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; + expr->symtree->n.sym->attr.intrinsic = 1; + gfc_commit_symbol (expr->symtree->n.sym); + expr->value.function.actual = gfc_get_actual_arglist (); + expr->value.function.actual->expr = gfc_lval_expr_from_sym (idx); + expr->value.function.actual->next = gfc_get_actual_arglist (); + expr->value.function.actual->next->expr = gfc_lval_expr_from_sym (sizes); + expr->value.function.actual->next->expr->ref = gfc_get_ref (); + expr->value.function.actual->next->expr->ref->type = REF_ARRAY; + expr->value.function.actual->next->expr->ref->u.ar.as = sizes->as; + expr->value.function.actual->next->expr->ref->u.ar.type = AR_ELEMENT; + expr->value.function.actual->next->expr->ref->u.ar.dimen = 1; + expr->value.function.actual->next->expr->ref->u.ar.dimen_type[0] + = DIMEN_ELEMENT; + expr->value.function.actual->next->expr->ref->u.ar.start[0] + = gfc_lval_expr_from_sym (idx2); + expr->ts = idx->ts; + + /* (...) / sizes(idx2-1). */ + expr2 = gfc_get_expr (); + expr2->expr_type = EXPR_OP; + expr2->value.op.op = INTRINSIC_DIVIDE; + expr2->value.op.op1 = expr; + expr2->value.op.op2 = gfc_lval_expr_from_sym (sizes); + expr2->value.op.op2->ref = gfc_get_ref (); + expr2->value.op.op2->ref->type = REF_ARRAY; + expr2->value.op.op2->ref->u.ar.as = sizes->as; + expr2->value.op.op2->ref->u.ar.type = AR_ELEMENT; + expr2->value.op.op2->ref->u.ar.dimen = 1; + expr2->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + expr2->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); + expr2->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; + expr2->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; + expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1 + = gfc_lval_expr_from_sym (idx2); + expr2->value.op.op2->ref->u.ar.start[0]->value.op.op2 + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + expr2->value.op.op2->ref->u.ar.start[0]->ts + = expr2->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; + expr2->ts = idx->ts; + + /* ... * strides(idx2). */ + expr = gfc_get_expr (); + expr->expr_type = EXPR_OP; + expr->value.op.op = INTRINSIC_TIMES; + expr->value.op.op1 = expr2; + expr->value.op.op2 = gfc_lval_expr_from_sym (strides); + expr->value.op.op2->ref = gfc_get_ref (); + expr->value.op.op2->ref->type = REF_ARRAY; + expr->value.op.op2->ref->u.ar.type = AR_ELEMENT; + expr->value.op.op2->ref->u.ar.dimen = 1; + expr->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + expr->value.op.op2->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx2); + expr->value.op.op2->ref->u.ar.as = strides->as; + expr->ts = idx->ts; + + /* offset = offset + ... */ + block->block->next = XCNEW (gfc_code); + block->block->next->op = EXEC_ASSIGN; + block->block->next->loc = gfc_current_locus; + block->block->next->expr1 = gfc_lval_expr_from_sym (offset); + block->block->next->expr2 = gfc_get_expr (); + block->block->next->expr2->expr_type = EXPR_OP; + block->block->next->expr2->value.op.op = INTRINSIC_PLUS; + block->block->next->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); + block->block->next->expr2->value.op.op2 = expr; + block->block->next->expr2->ts = idx->ts; + + /* After the loop: offset = offset * byte_stride. */ + block->next = XCNEW (gfc_code); + block = block->next; + block->op = EXEC_ASSIGN; + block->loc = gfc_current_locus; + block->expr1 = gfc_lval_expr_from_sym (offset); + block->expr2 = gfc_get_expr (); + block->expr2->expr_type = EXPR_OP; + block->expr2->value.op.op = INTRINSIC_TIMES; + block->expr2->value.op.op1 = gfc_lval_expr_from_sym (offset); + block->expr2->value.op.op2 = gfc_lval_expr_from_sym (byte_stride); + block->expr2->ts = block->expr2->value.op.op1->ts; + return block; +} + + /* Insert code of the following form: - if (stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE - || 0 == STORAGE_SIZE (array)) then - call final_rank3 (array) - else - block - type(t) :: tmp(shape (array)) - - do i = 0, size (array)-1 - addr = transfer (c_loc (array), addr) + i * stride - call c_f_pointer (transfer (addr, cptr), ptr) - - addr = transfer (c_loc (tmp), addr) - + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE - call c_f_pointer (transfer (addr, cptr), ptr2) - ptr2 = ptr - end do - call final_rank3 (tmp) - end block - end if */ + block + integer(c_intptr_t) :: i + + if ((byte_stride == STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE + && (is_contiguous || !final_rank3->attr.contiguous + || final_rank3->as->type != AS_ASSUMED_SHAPE)) + || 0 == STORAGE_SIZE (array)) then + call final_rank3 (array) + else + block + integer(c_intptr_t) :: offset, j + type(t) :: tmp(shape (array)) + + do i = 0, size (array)-1 + offset = obtain_offset(i, strides, sizes, byte_stride) + addr = transfer (c_loc (array), addr) + offset + call c_f_pointer (transfer (addr, cptr), ptr) + + addr = transfer (c_loc (tmp), addr) + + i * STORAGE_SIZE (array)/NUMERIC_STORAGE_SIZE + call c_f_pointer (transfer (addr, cptr), ptr2) + ptr2 = ptr + end do + call final_rank3 (tmp) + end block + end if + block */ static void finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, - gfc_symbol *array, gfc_symbol *stride, + gfc_symbol *array, gfc_symbol *byte_stride, gfc_symbol *idx, gfc_symbol *ptr, gfc_symbol *nelem, gfc_symtree *size_intr, + gfc_symbol *strides, gfc_symbol *sizes, + gfc_symbol *idx2, gfc_symbol *offset, + gfc_symbol *is_contiguous, gfc_expr *rank, gfc_namespace *sub_ns) { gfc_symbol *tmp_array, *ptr2; - gfc_expr *size_expr; + gfc_expr *size_expr, *offset2, *expr; gfc_namespace *ns; gfc_iterator *iter; + gfc_code *block2; int i; block->next = XCNEW (gfc_code); @@ -1080,6 +1216,8 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, = gfc_intrinsic_function_by_id (GFC_ISYM_STORAGE_SIZE); gfc_get_sym_tree ("storage_size", sub_ns, &size_expr->value.op.op1->symtree, false); + size_expr->value.op.op1->symtree->n.sym->intmod_sym_id + = GFC_ISYM_STORAGE_SIZE; size_expr->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE; size_expr->value.op.op1->symtree->n.sym->attr.intrinsic = 1; gfc_commit_symbol (size_expr->value.op.op1->symtree->n.sym); @@ -1096,32 +1234,53 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, size_expr->value.op.op1->ts = size_expr->value.op.op2->ts; size_expr->ts = size_expr->value.op.op1->ts; - /* IF condition: stride == size_expr || 0 == size_expr. */ + /* IF condition: (stride == size_expr + && ((fini's as->ASSUMED_SIZE && !fini's attr.contiguous) + || is_contiguous) + || 0 == size_expr. */ block->expr1 = gfc_get_expr (); block->expr1->expr_type = EXPR_FUNCTION; block->expr1->ts.type = BT_LOGICAL; - block->expr1->ts.kind = 4; + block->expr1->ts.kind = gfc_default_logical_kind; block->expr1->expr_type = EXPR_OP; block->expr1->where = gfc_current_locus; block->expr1->value.op.op = INTRINSIC_OR; - /* stride == size_expr */ - block->expr1->value.op.op1 = gfc_get_expr (); - block->expr1->value.op.op1->expr_type = EXPR_FUNCTION; - block->expr1->value.op.op1->ts.type = BT_LOGICAL; - block->expr1->value.op.op1->ts.kind = 4; - block->expr1->value.op.op1->expr_type = EXPR_OP; - block->expr1->value.op.op1->where = gfc_current_locus; - block->expr1->value.op.op1->value.op.op = INTRINSIC_EQ; - block->expr1->value.op.op1->value.op.op1 = gfc_lval_expr_from_sym (stride); - block->expr1->value.op.op1->value.op.op2 = size_expr; + /* byte_stride == size_expr */ + expr = gfc_get_expr (); + expr->ts.type = BT_LOGICAL; + expr->ts.kind = gfc_default_logical_kind; + expr->expr_type = EXPR_OP; + expr->where = gfc_current_locus; + expr->value.op.op = INTRINSIC_EQ; + expr->value.op.op1 + = gfc_lval_expr_from_sym (byte_stride); + expr->value.op.op2 = size_expr; + + /* If strides aren't allowd (not assumed shape or CONTIGUOUS), + add is_contiguous check. */ + if (fini->proc_tree->n.sym->formal->sym->as->type != AS_ASSUMED_SHAPE + || fini->proc_tree->n.sym->formal->sym->attr.contiguous) + { + gfc_expr *expr2; + expr2 = gfc_get_expr (); + expr2->ts.type = BT_LOGICAL; + expr2->ts.kind = gfc_default_logical_kind; + expr2->expr_type = EXPR_OP; + expr2->where = gfc_current_locus; + expr2->value.op.op = INTRINSIC_AND; + expr2->value.op.op1 = expr; + expr2->value.op.op2 = gfc_lval_expr_from_sym (is_contiguous); + expr = expr2; + } + + block->expr1->value.op.op1 = expr; /* 0 == size_expr */ block->expr1->value.op.op2 = gfc_get_expr (); - block->expr1->value.op.op2->expr_type = EXPR_FUNCTION; block->expr1->value.op.op2->ts.type = BT_LOGICAL; - block->expr1->value.op.op2->ts.kind = 4; + block->expr1->value.op.op2->ts.kind = gfc_default_logical_kind; block->expr1->value.op.op2->expr_type = EXPR_OP; block->expr1->value.op.op2->where = gfc_current_locus; block->expr1->value.op.op2->value.op.op = INTRINSIC_EQ; @@ -1168,7 +1327,6 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, tmp_array->ts.type = BT_DERIVED; tmp_array->ts.u.derived = array->ts.u.derived; tmp_array->attr.flavor = FL_VARIABLE; - tmp_array->attr.contiguous = 1; tmp_array->attr.dimension = 1; tmp_array->attr.artificial = 1; tmp_array->as = gfc_get_array_spec(); @@ -1217,22 +1375,36 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, block->block = gfc_get_code (); block->block->op = EXEC_DO; + /* Offset calculation for the new array: idx * size of type (in bytes). */ + offset2 = gfc_get_expr (); + offset2 = block->ext.actual->expr; + offset2->expr_type = EXPR_OP; + offset2->value.op.op = INTRINSIC_TIMES; + offset2->value.op.op1 = gfc_lval_expr_from_sym (idx); + offset2->value.op.op2 = gfc_copy_expr (size_expr); + offset2->ts = byte_stride->ts; + + /* Offset calculation of "array". */ + block2 = finalization_get_offset (idx, idx2, offset, strides, sizes, + byte_stride, rank, block->block, sub_ns); + /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + idx * stride, c_ptr), ptr). */ - block->block->next = finalization_scalarizer (idx, array, ptr, - gfc_lval_expr_from_sym (stride), - sub_ns); - block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2, - gfc_copy_expr (size_expr), - sub_ns); + block2->next = finalization_scalarizer (array, ptr, + gfc_lval_expr_from_sym (offset), + sub_ns); + block2 = block2->next; + block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); + /* ptr2 = ptr. */ - block->block->next->next->next = XCNEW (gfc_code); - block->block->next->next->next->op = EXEC_ASSIGN; - block->block->next->next->next->loc = gfc_current_locus; - block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr2); - block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr); + block2->next = XCNEW (gfc_code); + block2->next->op = EXEC_ASSIGN; + block2->next->loc = gfc_current_locus; + block2->next->expr1 = gfc_lval_expr_from_sym (ptr2); + block2->next->expr2 = gfc_lval_expr_from_sym (ptr); + /* Call now the user's final subroutine. */ block->next = XCNEW (gfc_code); block = block->next; block->op = EXEC_CALL; @@ -1262,21 +1434,26 @@ finalizer_insert_packed_call (gfc_code *block, gfc_finalizer *fini, block->block = gfc_get_code (); block->block->op = EXEC_DO; + /* Offset calculation of "array". */ + block2 = finalization_get_offset (idx, idx2, offset, strides, sizes, + byte_stride, rank, block->block, sub_ns); + /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * stride, c_ptr), ptr). */ - block->block->next = finalization_scalarizer (idx, array, ptr, - gfc_lval_expr_from_sym (stride), - sub_ns); - block->block->next->next = finalization_scalarizer (idx, tmp_array, ptr2, - gfc_copy_expr (size_expr), - sub_ns); + + offset, c_ptr), ptr). */ + block2->next = finalization_scalarizer (array, ptr, + gfc_lval_expr_from_sym (offset), + sub_ns); + block2 = block2->next; + block2->next = finalization_scalarizer (tmp_array, ptr2, offset2, sub_ns); + block2 = block2->next; + /* ptr = ptr2. */ - block->block->next->next->next = XCNEW (gfc_code); - block->block->next->next->next->op = EXEC_ASSIGN; - block->block->next->next->next->loc = gfc_current_locus; - block->block->next->next->next->expr1 = gfc_lval_expr_from_sym (ptr); - block->block->next->next->next->expr2 = gfc_lval_expr_from_sym (ptr2); + block2->next = XCNEW (gfc_code); + block2->next->op = EXEC_ASSIGN; + block2->next->loc = gfc_current_locus; + block2->next->expr1 = gfc_lval_expr_from_sym (ptr); + block2->next->expr2 = gfc_lval_expr_from_sym (ptr2); } @@ -1300,16 +1477,17 @@ static void generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, const char *tname, gfc_component *vtab_final) { - gfc_symbol *final, *array, *nelem, *fini_coarray, *stride; - gfc_symbol *ptr = NULL, *idx = NULL; + gfc_symbol *final, *array, *fini_coarray, *byte_stride, *sizes, *strides; + gfc_symbol *ptr = NULL, *idx, *idx2, *is_contiguous, *offset, *nelem; gfc_symtree *size_intr; gfc_component *comp; gfc_namespace *sub_ns; - gfc_code *last_code; + gfc_code *last_code, *block; char name[GFC_MAX_SYMBOL_LEN+1]; bool finalizable_comp = false; bool expr_null_wrapper = false; - gfc_expr *ancestor_wrapper = NULL; + gfc_expr *ancestor_wrapper = NULL, *rank; + gfc_iterator *iter; /* Search for the ancestor's finalizers. */ if (derived->attr.extension && derived->components @@ -1423,22 +1601,22 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_commit_symbol (array); /* Set up formal argument. */ - gfc_get_symbol ("stride", sub_ns, &stride); - stride->ts.type = BT_INTEGER; - stride->ts.kind = gfc_index_integer_kind; - stride->attr.flavor = FL_VARIABLE; - stride->attr.dummy = 1; - stride->attr.value = 1; - stride->attr.artificial = 1; - gfc_set_sym_referenced (stride); + gfc_get_symbol ("byte_stride", sub_ns, &byte_stride); + byte_stride->ts.type = BT_INTEGER; + byte_stride->ts.kind = gfc_index_integer_kind; + byte_stride->attr.flavor = FL_VARIABLE; + byte_stride->attr.dummy = 1; + byte_stride->attr.value = 1; + byte_stride->attr.artificial = 1; + gfc_set_sym_referenced (byte_stride); final->formal->next = gfc_get_formal_arglist (); - final->formal->next->sym = stride; - gfc_commit_symbol (stride); + final->formal->next->sym = byte_stride; + gfc_commit_symbol (byte_stride); /* Set up formal argument. */ gfc_get_symbol ("fini_coarray", sub_ns, &fini_coarray); fini_coarray->ts.type = BT_LOGICAL; - fini_coarray->ts.kind = 4; + fini_coarray->ts.kind = 1; fini_coarray->attr.flavor = FL_VARIABLE; fini_coarray->attr.dummy = 1; fini_coarray->attr.value = 1; @@ -1457,6 +1635,90 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, return; } + /* Local variables. */ + + gfc_get_symbol ("idx", sub_ns, &idx); + idx->ts.type = BT_INTEGER; + idx->ts.kind = gfc_index_integer_kind; + idx->attr.flavor = FL_VARIABLE; + idx->attr.artificial = 1; + gfc_set_sym_referenced (idx); + gfc_commit_symbol (idx); + + gfc_get_symbol ("idx2", sub_ns, &idx2); + idx2->ts.type = BT_INTEGER; + idx2->ts.kind = gfc_index_integer_kind; + idx2->attr.flavor = FL_VARIABLE; + idx2->attr.artificial = 1; + gfc_set_sym_referenced (idx2); + gfc_commit_symbol (idx2); + + gfc_get_symbol ("offset", sub_ns, &offset); + offset->ts.type = BT_INTEGER; + offset->ts.kind = gfc_index_integer_kind; + offset->attr.flavor = FL_VARIABLE; + offset->attr.artificial = 1; + gfc_set_sym_referenced (offset); + gfc_commit_symbol (offset); + + /* Create RANK expression. */ + rank = gfc_get_expr (); + rank->expr_type = EXPR_FUNCTION; + rank->value.function.isym = gfc_intrinsic_function_by_id (GFC_ISYM_RANK); + gfc_get_sym_tree ("rank", sub_ns, &rank->symtree, false); + rank->symtree->n.sym->intmod_sym_id = GFC_ISYM_RANK; + rank->symtree->n.sym->attr.flavor = FL_PROCEDURE; + rank->symtree->n.sym->attr.intrinsic = 1; + gfc_commit_symbol (rank->symtree->n.sym); + rank->value.function.actual = gfc_get_actual_arglist (); + rank->value.function.actual->expr = gfc_lval_expr_from_sym (array); + rank->ts = rank->value.function.isym->ts; + gfc_convert_type (rank, &idx->ts, 2); + + /* Create is_contiguous variable. */ + gfc_get_symbol ("is_contiguous", sub_ns, &is_contiguous); + is_contiguous->ts.type = BT_LOGICAL; + is_contiguous->ts.kind = gfc_default_logical_kind; + is_contiguous->attr.flavor = FL_VARIABLE; + is_contiguous->attr.artificial = 1; + gfc_set_sym_referenced (is_contiguous); + gfc_commit_symbol (is_contiguous); + + /* Create "sizes(0..rank)" variable, which contains the multiplied + up extent of the dimensions, i.e. sizes(0) = 1, sizes(1) = extent(dim=1), + sizes(2) = sizes(1) * extent(dim=2) etc. */ + gfc_get_symbol ("sizes", sub_ns, &sizes); + sizes->ts.type = BT_INTEGER; + sizes->ts.kind = gfc_index_integer_kind; + sizes->attr.flavor = FL_VARIABLE; + sizes->attr.dimension = 1; + sizes->attr.artificial = 1; + sizes->as = gfc_get_array_spec(); + sizes->attr.intent = INTENT_INOUT; + sizes->as->type = AS_EXPLICIT; + sizes->as->rank = 1; + sizes->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + sizes->as->upper[0] = gfc_copy_expr (rank); + gfc_set_sym_referenced (sizes); + gfc_commit_symbol (sizes); + + /* Create "strides(1..rank)" variable, which contains the strides per + dimension. */ + gfc_get_symbol ("strides", sub_ns, &strides); + strides->ts.type = BT_INTEGER; + strides->ts.kind = gfc_index_integer_kind; + strides->attr.flavor = FL_VARIABLE; + strides->attr.dimension = 1; + strides->attr.artificial = 1; + strides->as = gfc_get_array_spec(); + strides->attr.intent = INTENT_INOUT; + strides->as->type = AS_EXPLICIT; + strides->as->rank = 1; + strides->as->lower[0] = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + strides->as->upper[0] = gfc_copy_expr (rank); + gfc_set_sym_referenced (strides); + gfc_commit_symbol (strides); + /* Set return value to 0. */ last_code = XCNEW (gfc_code); @@ -1466,6 +1728,206 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->expr2 = gfc_get_int_expr (4, NULL, 0); sub_ns->code = last_code; + /* Set: is_contiguous = .true. */ + last_code->next = XCNEW (gfc_code); + last_code = last_code->next; + last_code->op = EXEC_ASSIGN; + last_code->loc = gfc_current_locus; + last_code->expr1 = gfc_lval_expr_from_sym (is_contiguous); + last_code->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, + &gfc_current_locus, true); + + /* Set: sizes(0) = 1. */ + last_code->next = XCNEW (gfc_code); + last_code = last_code->next; + last_code->op = EXEC_ASSIGN; + last_code->loc = gfc_current_locus; + last_code->expr1 = gfc_lval_expr_from_sym (sizes); + last_code->expr1->ref = gfc_get_ref (); + last_code->expr1->ref->type = REF_ARRAY; + last_code->expr1->ref->u.ar.type = AR_ELEMENT; + last_code->expr1->ref->u.ar.dimen = 1; + last_code->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + last_code->expr1->ref->u.ar.start[0] + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + last_code->expr1->ref->u.ar.as = sizes->as; + last_code->expr2 = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1); + + /* Create: + DO idx = 1, rank + strides(idx) = _F._stride (array, dim=idx) + sizes(idx) = sizes(i-1) * size(array, dim=idx, kind=index_kind) + if (strides(idx) /= sizes(i-1)) is_contiguous = .false. + END DO. */ + + /* Create loop. */ + iter = gfc_get_iterator (); + iter->var = gfc_lval_expr_from_sym (idx); + iter->start = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + iter->end = gfc_copy_expr (rank); + iter->step = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + last_code->next = XCNEW (gfc_code); + last_code = last_code->next; + last_code->op = EXEC_DO; + last_code->loc = gfc_current_locus; + last_code->ext.iterator = iter; + last_code->block = gfc_get_code (); + last_code->block->op = EXEC_DO; + + /* strides(idx) = _F._stride(array,dim=idx). */ + last_code->block->next = XCNEW (gfc_code); + block = last_code->block->next; + block->op = EXEC_ASSIGN; + block->loc = gfc_current_locus; + + block->expr1 = gfc_lval_expr_from_sym (strides); + block->expr1->ref = gfc_get_ref (); + block->expr1->ref->type = REF_ARRAY; + block->expr1->ref->u.ar.type = AR_ELEMENT; + block->expr1->ref->u.ar.dimen = 1; + block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); + block->expr1->ref->u.ar.as = strides->as; + + block->expr2 = gfc_get_expr (); + block->expr2->expr_type = EXPR_FUNCTION; + block->expr2->value.function.isym + = gfc_intrinsic_function_by_id (GFC_ISYM_STRIDE); + gfc_get_sym_tree (GFC_PREFIX ("stride"), sub_ns, + &block->expr2->symtree, false); + block->expr2->symtree->n.sym->intmod_sym_id = GFC_ISYM_STRIDE; + block->expr2->symtree->n.sym->attr.flavor = FL_PROCEDURE; + block->expr2->symtree->n.sym->attr.intrinsic = 1; + gfc_commit_symbol (block->expr2->symtree->n.sym); + block->expr2->value.function.actual = gfc_get_actual_arglist (); + block->expr2->value.function.actual->expr = gfc_lval_expr_from_sym (array); + /* dim=idx. */ + block->expr2->value.function.actual->next = gfc_get_actual_arglist (); + block->expr2->value.function.actual->next->expr + = gfc_lval_expr_from_sym (idx); + block->expr2->ts = block->expr2->value.function.isym->ts; + + /* sizes(idx) = sizes(idx-1) * size(array,dim=idx, kind=index_kind). */ + block->next = XCNEW (gfc_code); + block = block->next; + block->op = EXEC_ASSIGN; + block->loc = gfc_current_locus; + + /* sizes(idx) = ... */ + block->expr1 = gfc_lval_expr_from_sym (sizes); + block->expr1->ref = gfc_get_ref (); + block->expr1->ref->type = REF_ARRAY; + block->expr1->ref->u.ar.type = AR_ELEMENT; + block->expr1->ref->u.ar.dimen = 1; + block->expr1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); + block->expr1->ref->u.ar.as = sizes->as; + + block->expr2 = gfc_get_expr (); + block->expr2->expr_type = EXPR_OP; + block->expr2->value.op.op = INTRINSIC_TIMES; + + /* sizes(idx-1). */ + block->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); + block->expr2->value.op.op1->ref = gfc_get_ref (); + block->expr2->value.op.op1->ref->type = REF_ARRAY; + block->expr2->value.op.op1->ref->u.ar.as = sizes->as; + block->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT; + block->expr2->value.op.op1->ref->u.ar.dimen = 1; + block->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr2->value.op.op1->ref->u.ar.start[0] = gfc_get_expr (); + block->expr2->value.op.op1->ref->u.ar.start[0]->expr_type = EXPR_OP; + block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; + block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1 + = gfc_lval_expr_from_sym (idx); + block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op2 + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + block->expr2->value.op.op1->ref->u.ar.start[0]->ts + = block->expr2->value.op.op1->ref->u.ar.start[0]->value.op.op1->ts; + + /* size(array, dim=idx, kind=index_kind). */ + block->expr2->value.op.op2 = gfc_get_expr (); + block->expr2->value.op.op2->expr_type = EXPR_FUNCTION; + block->expr2->value.op.op2->value.function.isym + = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE); + gfc_get_sym_tree ("size", sub_ns, &block->expr2->value.op.op2->symtree, + false); + size_intr = block->expr2->value.op.op2->symtree; + block->expr2->value.op.op2->symtree->n.sym->intmod_sym_id = GFC_ISYM_SIZE; + block->expr2->value.op.op2->symtree->n.sym->attr.flavor = FL_PROCEDURE; + block->expr2->value.op.op2->symtree->n.sym->attr.intrinsic = 1; + gfc_commit_symbol (block->expr2->value.op.op2->symtree->n.sym); + block->expr2->value.op.op2->value.function.actual + = gfc_get_actual_arglist (); + block->expr2->value.op.op2->value.function.actual->expr + = gfc_lval_expr_from_sym (array); + /* dim=idx. */ + block->expr2->value.op.op2->value.function.actual->next + = gfc_get_actual_arglist (); + block->expr2->value.op.op2->value.function.actual->next->expr + = gfc_lval_expr_from_sym (idx); + /* kind=c_intptr_t. */ + block->expr2->value.op.op2->value.function.actual->next->next + = gfc_get_actual_arglist (); + block->expr2->value.op.op2->value.function.actual->next->next->expr + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); + block->expr2->value.op.op2->ts = idx->ts; + block->expr2->ts = idx->ts; + + /* if (strides(idx) /= sizes(idx-1)) is_contiguous = .false. */ + block->next = XCNEW (gfc_code); + block = block->next; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + block->block = XCNEW (gfc_code); + block = block->block; + block->loc = gfc_current_locus; + block->op = EXEC_IF; + + /* if condition: strides(idx) /= sizes(idx-1). */ + block->expr1 = gfc_get_expr (); + block->expr1->ts.type = BT_LOGICAL; + block->expr1->ts.kind = gfc_default_logical_kind; + block->expr1->expr_type = EXPR_OP; + block->expr1->where = gfc_current_locus; + block->expr1->value.op.op = INTRINSIC_NE; + + block->expr1->value.op.op1 = gfc_lval_expr_from_sym (strides); + block->expr1->value.op.op1->ref = gfc_get_ref (); + block->expr1->value.op.op1->ref->type = REF_ARRAY; + block->expr1->value.op.op1->ref->u.ar.type = AR_ELEMENT; + block->expr1->value.op.op1->ref->u.ar.dimen = 1; + block->expr1->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr1->value.op.op1->ref->u.ar.start[0] = gfc_lval_expr_from_sym (idx); + block->expr1->value.op.op1->ref->u.ar.as = strides->as; + + block->expr1->value.op.op2 = gfc_lval_expr_from_sym (sizes); + block->expr1->value.op.op2->ref = gfc_get_ref (); + block->expr1->value.op.op2->ref->type = REF_ARRAY; + block->expr1->value.op.op2->ref->u.ar.as = sizes->as; + block->expr1->value.op.op2->ref->u.ar.type = AR_ELEMENT; + block->expr1->value.op.op2->ref->u.ar.dimen = 1; + block->expr1->value.op.op2->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + block->expr1->value.op.op2->ref->u.ar.start[0] = gfc_get_expr (); + block->expr1->value.op.op2->ref->u.ar.start[0]->expr_type = EXPR_OP; + block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op = INTRINSIC_MINUS; + block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1 + = gfc_lval_expr_from_sym (idx); + block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op2 + = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); + block->expr1->value.op.op2->ref->u.ar.start[0]->ts + = block->expr1->value.op.op2->ref->u.ar.start[0]->value.op.op1->ts; + + /* if body: is_contiguous = .false. */ + block->next = XCNEW (gfc_code); + block = block->next; + block->op = EXEC_ASSIGN; + block->loc = gfc_current_locus; + block->expr1 = gfc_lval_expr_from_sym (is_contiguous); + block->expr2 = gfc_get_logical_expr (gfc_default_logical_kind, + &gfc_current_locus, false); + /* Obtain the size (number of elements) of "array" MINUS ONE, which is used in the scalarization. */ gfc_get_symbol ("nelem", sub_ns, &nelem); @@ -1476,7 +1938,7 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, gfc_set_sym_referenced (nelem); gfc_commit_symbol (nelem); - /* Generate: nelem = SIZE (array) - 1. */ + /* nelem = sizes (rank) - 1. */ last_code->next = XCNEW (gfc_code); last_code = last_code->next; last_code->op = EXEC_ASSIGN; @@ -1491,32 +1953,14 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, = gfc_get_int_expr (gfc_index_integer_kind, NULL, 1); last_code->expr2->ts = last_code->expr2->value.op.op2->ts; - last_code->expr2->value.op.op1 = gfc_get_expr (); - last_code->expr2->value.op.op1->expr_type = EXPR_FUNCTION; - last_code->expr2->value.op.op1->value.function.isym - = gfc_intrinsic_function_by_id (GFC_ISYM_SIZE); - gfc_get_sym_tree ("size", sub_ns, &last_code->expr2->value.op.op1->symtree, - false); - size_intr = last_code->expr2->value.op.op1->symtree; - last_code->expr2->value.op.op1->symtree->n.sym->attr.flavor = FL_PROCEDURE; - last_code->expr2->value.op.op1->symtree->n.sym->attr.intrinsic = 1; - gfc_commit_symbol (last_code->expr2->value.op.op1->symtree->n.sym); - last_code->expr2->value.op.op1->value.function.actual - = gfc_get_actual_arglist (); - last_code->expr2->value.op.op1->value.function.actual->expr - = gfc_lval_expr_from_sym (array); - /* dim=NULL. */ - last_code->expr2->value.op.op1->value.function.actual->next - = gfc_get_actual_arglist (); - /* kind=c_intptr_t. */ - last_code->expr2->value.op.op1->value.function.actual->next->next - = gfc_get_actual_arglist (); - last_code->expr2->value.op.op1->value.function.actual->next->next->expr - = gfc_get_int_expr (gfc_index_integer_kind, NULL, 0); - last_code->expr2->value.op.op1->ts - = last_code->expr2->value.op.op1->value.function.isym->ts; - - sub_ns->code = last_code; + last_code->expr2->value.op.op1 = gfc_lval_expr_from_sym (sizes); + last_code->expr2->value.op.op1->ref = gfc_get_ref (); + last_code->expr2->value.op.op1->ref->type = REF_ARRAY; + last_code->expr2->value.op.op1->ref->u.ar.type = AR_ELEMENT; + last_code->expr2->value.op.op1->ref->u.ar.dimen = 1; + last_code->expr2->value.op.op1->ref->u.ar.dimen_type[0] = DIMEN_ELEMENT; + last_code->expr2->value.op.op1->ref->u.ar.start[0] = gfc_copy_expr (rank); + last_code->expr2->value.op.op1->ref->u.ar.as = sizes->as; /* Call final subroutines. We now generate code like: use iso_c_binding @@ -1539,15 +1983,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, if (derived->f2k_derived && derived->f2k_derived->finalizers) { gfc_finalizer *fini, *fini_elem = NULL; - gfc_code *block = NULL; - - gfc_get_symbol ("idx", sub_ns, &idx); - idx->ts.type = BT_INTEGER; - idx->ts.kind = gfc_index_integer_kind; - idx->attr.flavor = FL_VARIABLE; - idx->attr.artificial = 1; - gfc_set_sym_referenced (idx); - gfc_commit_symbol (idx); gfc_get_symbol ("ptr", sub_ns, &ptr); ptr->ts.type = BT_DERIVED; @@ -1563,20 +1998,8 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code = last_code->next; last_code->op = EXEC_SELECT; last_code->loc = gfc_current_locus; - - last_code->expr1 = gfc_get_expr (); - last_code->expr1->expr_type = EXPR_FUNCTION; - last_code->expr1->value.function.isym - = gfc_intrinsic_function_by_id (GFC_ISYM_RANK); - gfc_get_sym_tree ("rank", sub_ns, &last_code->expr1->symtree, - false); - last_code->expr1->symtree->n.sym->attr.flavor = FL_PROCEDURE; - last_code->expr1->symtree->n.sym->attr.intrinsic = 1; - gfc_commit_symbol (last_code->expr1->symtree->n.sym); - last_code->expr1->value.function.actual = gfc_get_actual_arglist (); - last_code->expr1->value.function.actual->expr - = gfc_lval_expr_from_sym (array); - last_code->expr1->ts = last_code->expr1->value.function.isym->ts; + last_code->expr1 = gfc_copy_expr (rank); + block = NULL; for (fini = derived->f2k_derived->finalizers; fini; fini = fini->next) { @@ -1613,8 +2036,10 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* CALL fini_rank (array) - possibly with packing. */ if (fini->proc_tree->n.sym->formal->sym->attr.dimension) - finalizer_insert_packed_call (block, fini, array, stride, idx, ptr, - nelem, size_intr, sub_ns); + finalizer_insert_packed_call (block, fini, array, byte_stride, + idx, ptr, nelem, size_intr, strides, + sizes, idx2, offset, is_contiguous, + rank, sub_ns); else { block->next = XCNEW (gfc_code); @@ -1630,8 +2055,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, /* Elemental call - scalarized. */ if (fini_elem) { - gfc_iterator *iter; - /* CASE DEFAULT. */ if (block) { @@ -1661,14 +2084,19 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, block->block = gfc_get_code (); block->block->op = EXEC_DO; + /* Offset calculation. */ + block = finalization_get_offset (idx, idx2, offset, strides, sizes, + byte_stride, rank, block->block, + sub_ns); + /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) - + idx * stride, c_ptr), ptr). */ - block->block->next - = finalization_scalarizer (idx, array, ptr, - gfc_lval_expr_from_sym (stride), - sub_ns); - block = block->block->next; + + offset, c_ptr), ptr). */ + block->next + = finalization_scalarizer (array, ptr, + gfc_lval_expr_from_sym (offset), + sub_ns); + block = block->next; /* CALL final_elemental (array). */ block->next = XCNEW (gfc_code); @@ -1689,18 +2117,6 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, { gfc_symbol *stat; gfc_code *block = NULL; - gfc_iterator *iter; - - if (!idx) - { - gfc_get_symbol ("idx", sub_ns, &idx); - idx->ts.type = BT_INTEGER; - idx->ts.kind = gfc_index_integer_kind; - idx->attr.flavor = FL_VARIABLE; - idx->attr.artificial = 1; - gfc_set_sym_referenced (idx); - gfc_commit_symbol (idx); - } if (!ptr) { @@ -1736,14 +2152,18 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->block = gfc_get_code (); last_code->block->op = EXEC_DO; + /* Offset calculation. */ + block = finalization_get_offset (idx, idx2, offset, strides, sizes, + byte_stride, rank, last_code->block, + sub_ns); + /* Create code for CALL C_F_POINTER (TRANSFER (TRANSFER (C_LOC (array, cptr), c_intptr) + idx * stride, c_ptr), ptr). */ - last_code->block->next - = finalization_scalarizer (idx, array, ptr, - gfc_lval_expr_from_sym (stride), - sub_ns); - block = last_code->block->next; + block->next = finalization_scalarizer (array, ptr, + gfc_lval_expr_from_sym(offset), + sub_ns); + block = block->next; for (comp = derived->components; comp; comp = comp->next) { @@ -1772,12 +2192,13 @@ generate_finalization_wrapper (gfc_symbol *derived, gfc_namespace *ns, last_code->ext.actual = gfc_get_actual_arglist (); last_code->ext.actual->expr = gfc_lval_expr_from_sym (array); last_code->ext.actual->next = gfc_get_actual_arglist (); - last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (stride); + last_code->ext.actual->next->expr = gfc_lval_expr_from_sym (byte_stride); last_code->ext.actual->next->next = gfc_get_actual_arglist (); last_code->ext.actual->next->next->expr = gfc_lval_expr_from_sym (fini_coarray); } + gfc_free_expr (rank); vtab_final->initializer = gfc_lval_expr_from_sym (final); vtab_final->ts.interface = final; }