From patchwork Sun Dec 11 16:55:08 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Paul Richard Thomas X-Patchwork-Id: 130611 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 1F500B6FF5 for ; Mon, 12 Dec 2011 03:55:55 +1100 (EST) Received: (qmail 13623 invoked by alias); 11 Dec 2011 16:55:50 -0000 Received: (qmail 13314 invoked by uid 22791); 11 Dec 2011 16:55:35 -0000 X-SWARE-Spam-Status: No, hits=0.0 required=5.0 tests=AWL, BAYES_50, DKIM_SIGNED, DKIM_VALID, DKIM_VALID_AU, FREEMAIL_FROM, KAM_STOCKGEN, RCVD_IN_DNSWL_LOW, TW_TM, TW_VP X-Spam-Check-By: sourceware.org Received: from mail-ey0-f175.google.com (HELO mail-ey0-f175.google.com) (209.85.215.175) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sun, 11 Dec 2011 16:55:11 +0000 Received: by eaal1 with SMTP id l1so832468eaa.20 for ; Sun, 11 Dec 2011 08:55:08 -0800 (PST) MIME-Version: 1.0 Received: by 10.213.21.195 with SMTP id k3mr2908816ebb.134.1323622508657; Sun, 11 Dec 2011 08:55:08 -0800 (PST) Received: by 10.14.186.10 with HTTP; Sun, 11 Dec 2011 08:55:08 -0800 (PST) Date: Sun, 11 Dec 2011 17:55:08 +0100 Message-ID: Subject: [Patch, fortran] - Arrays of classes for fortran From: Paul Richard Thomas To: Tobias Burnus , fortran@gcc.gnu.org, gcc-patches 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, I have been much longer in preparing the class array patch than intended simply because I wanted to reach the point where it would do something useful :-) Well here it is. Whilst I realise that we are in phase 3, this patch is pretty bomb-proof simply because class arrays did not work at all, previously. Also, we are a few months from release yet and I am sure that any significant regressions will appear by then. I have to confess that it is still not as consistent and well ordered as I would like. I started the process of cleaning up, as will be apparent in the first, new block in trans-expr.c; when this reaches critical mass, it will be broken out into trans-class.c. I should record here that Tobias has been extraordinarily helpful in providing feedback, testcases and the coarray part. Between now and the release of 4.7, I will continue to bug fix and clean up the implementation of class arrays. However, I am pleased to say that it already does better than most of the other brands that we have had access to, with the exception of NAG. The testcase class_array_3.f03 is a quick sort program that could be generalised to work with any comparison operator. Only NAG was able to deal with this. All this said, I should record where gfortran is still broken, is a bit untidy or does not yet produce correct code: (i) Class subarray references usually produce ICEs. eg type t integer :: i end type t class(t),allocatable :: A(:) allocate (A(2)) A(1:2)%i = [33,66] ! <<<< HERE end See comment #2 of PR46356 (ii) Vector indices do not work. See class_array_3.f03 for a place where a do loop must be used instead of: a = tmp(index_array), where a and tmp are class arrays. This produces a segfault because the class array temporary that is produced is not allocated and, still worse is nullified. In addition, the temporary is not necessary, since no pointers are involved and the variables are different. For some reason, moving the index array to the lhs, causes the massage, "Variable must not be polymorphic in assignment at (1)" so that the statement cannot be recognised as a defined assignment. (iii) gfc_trans_class_array_init_assign and gfc_trans_allocate make use of front-endery to produce a call to gfc_trans_call, in order to benefit from the scalarizer in element by element copies. These bits of code can be combined with advantage and moved to (trans-)class.c. (iv) gfc_add_loop_ss_code does not produce a temporary for class scalars, since their size can vary according to the dynamic type. Whilst this has not been seen to fail, it should be determined if this works generally. (v) build_class_array_ref is an example of a place where manipulation of front-end expressions is used heavily to generate the class declaration. This could be done in gfc_conv_expr by adding an gfc_se field for the class decl and storing it on the fly. (vi) Numerous places exist, where the new class API should be used; eg in structure_alloc_comps. (vii) GFC_DECL_CLASS is only set for variable declarations; field and parm dels should be set too. (viii) Whilst some intrinsics now work, such as LBOUND, UBOUND, SIZE, MOVE_ALLOC, ALLOCATED and ASSOCIATED, there are still others that need to be implemented. (ix) match.c:5247 is a horrible expression to distinguish class arrays. gfc_is_class_array_ref does not work there and causes numerous regressions. This must be understood and corrected. (x) PRs are welcome! At least it is a sign that people are trying to use this feature and I will do my best to fix them. Boostrapped and regtested on x86_64/FC9 - OK for trunk? Cheers Paul 2011-12-11 Paul Thomas Tobias Burnus PR fortran/41539 PR fortran/43214 PR fortran/43969 PR fortran/44568 PR fortran/46356 PR fortran/46990 PR fortran/49074 * interface.c(symbol_rank): Return the rank of the _data component of class objects. (compare_parameter): Also compare the derived type of the class _data component for type mismatch. Similarly, return 1 if the formal and _data ranks match. (compare_actual_formal): Do not compare storage sizes for class expressions. It is an error if an actual class array, passed to a formal class array is not full. * trans-expr.c (gfc_class_data_get, gfc_class_vptr_get, gfc_vtable_field_get, gfc_vtable_hash_get, gfc_vtable_size_get, gfc_vtable_extends_get, gfc_vtable_def_init_get, gfc_vtable_copy_get): New functions for class API. (gfc_conv_derived_to_class): For an array reference in an elemental procedure call retain the ss to provide the scalarized array reference. Moved in file. (gfc_conv_class_to_class): New function. (gfc_conv_subref_array_arg): Use the type of the class _data component as a basetype. (gfc_conv_procedure_call): Ensure that class array expressions have both the _data reference and an array reference. Use gfc_conv_class_to_class to handle class arrays for elemental functions in scalarized loops, class array elements and full class arrays. Use a call to gfc_conv_subref_array_arg in order that the copy-in/copy-out for passing class arrays to derived type arrays occurs correctly. (gfc_conv_expr): If it is missing, add the _data component between a class object or component and an array reference. (gfc_trans_class_array_init_assign): New function. (gfc_trans_class_init_assign): Call it for array expressions. * trans-array.c (gfc_add_loop_ss_code): Do not use a temp for class scalars since their size will depend on the dynamic type. (build_class_array_ref): New function. (gfc_conv_scalarized_array_ref): Call build_class_array_ref. (gfc_array_init_size): Add extra argument, expr3, that represents the SOURCE argument. If present,use this for the element size. (gfc_array_allocate): Also add argument expr3 and use it when calling gfc_array_init_size. (structure_alloc_comps): Enable class arrays. * class.c (gfc_add_component_ref): Carry over the derived type of the _data component. (gfc_add_class_array_ref): New function. (class_array_ref_detected): New static function. (gfc_is_class_array_ref): New function that calls previous. (gfc_is_class_scalar_expr): New function. (gfc_build_class_symbol): Throw not implemented error for assumed size class arrays. Remove error that prevents CLASS arrays. (gfc_build_class_symbol): Prevent pointer/allocatable conflict. Also unset codimension. (gfc_find_derived_vtab): Make 'copy' elemental and set the intent of the arguments accordingly.: * trans-array.h : Update prototype for gfc_array_allocate. * array.c (gfc_array_dimen_size): Return failure if class expr. (gfc_array_size): Likewise. * gfortran.h : New prototypes for gfc_add_class_array_ref, gfc_is_class_array_ref and gfc_is_class_scalar_expr. * trans-stmt.c (trans_associate_var): Exclude class targets from test. Move the allocation of the _vptr to an earlier time for class objects. (trans_associate_var): Assign the descriptor directly for class arrays. (gfc_trans_allocate): Add expr3 to gfc_array_allocate arguments. Convert array element references into sections. Do not invoke gfc_conv_procedure_call, use gfc_trans_call instead. * expr.c (gfc_get_corank): Fix for BT_CLASS. (gfc_is_simply_contiguous): Exclude class from test. * trans.c (gfc_build_array_ref): Include class array refs. * trans.h : Include prototypes for class API functions that are new in trans-expr. Define GFC_DECL_CLASS(node). * resolve.c (check_typebound_baseobject ): Remove error for non-scalar base object. (resolve_allocate_expr): Ensure that class _data component is present. If array, call gfc_expr_to_intialize. (resolve_select): Remove scalar error for SELECT statement as a temporary measure. (resolve_assoc_var): Update 'target' (aka 'selector') as needed. Ensure that the target expression has the right rank. (resolve_select_type): Ensure that target expressions have a valid locus. (resolve_allocate_expr, resolve_fl_derived0): Fix for BT_CLASS. * trans-decl.c (gfc_get_symbol_decl): Set GFC_DECL_CLASS, where appropriate. (gfc_trans_deferred_vars): Get class arrays right. * match.c(select_type_set_tmp): Add array spec to temporary. (gfc_match_select_type): Allow class arrays. * check.c (array_check): Ensure that class arrays have refs. (dim_corank_check, dim_rank_check): Retrun success if class. * primary.c (gfc_match_varspec): Fix for class arrays and co-arrays. Make sure that class _data is present. (gfc_match_rvalue): Handle class arrays. *trans-intrinsic.c (gfc_conv_intrinsic_size): Add class array reference. (gfc_conv_allocated): Add _data component to class expressions. (gfc_add_intrinsic_ss_code): ditto. * simplify.c (simplify_cobound): Fix for BT_CLASS. (simplify_bound): Return NULL for class arrays. (simplify_cobound): Obtain correct array_spec. Use cotype as appropriate. Use arrayspec for bounds. 2011-12-11 Paul Thomas Tobias Burnus PR fortran/41539 PR fortran/43214 PR fortran/43969 PR fortran/44568 PR fortran/46356 PR fortran/46990 PR fortran/49074 * gfortran.dg/class_array_1.f03: New. * gfortran.dg/class_array_2.f03: New. * gfortran.dg/class_array_3.f03: New. * gfortran.dg/class_array_4.f03: New. * gfortran.dg/class_array_5.f03: New. * gfortran.dg/class_array_6.f03: New. * gfortran.dg/class_array_7.f03: New. * gfortran.dg/class_array_8.f03: New. * gfortran.dg/coarray_poly_1.f90: New. * gfortran.dg/coarray_poly_2.f90: New. * gfortran.dg/coarray/poly_run_1.f90: New. * gfortran.dg/coarray/poly_run_2.f90: New. * gfortran.dg/class_to_type_1.f03: New. * gfortran.dg/type_to_class_1.f03: New. * gfortran.dg/typebound_assignment_3.f03: Remove the error. * gfortran.dg/auto_dealloc_2.f90: Occurences of __builtin_free now 2. * gfortran.dg/auto_dealloc_2.f90: Occurences of __builtin_free * gfortran.dg/class_19.f03: Occurences of __builtin_free now 8. Index: gcc/fortran/interface.c =================================================================== *** gcc/fortran/interface.c (revision 182187) --- gcc/fortran/interface.c (working copy) *************** done: *** 1541,1546 **** --- 1541,1549 ---- static int symbol_rank (gfc_symbol *sym) { + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->as) + return CLASS_DATA (sym)->as->rank; + return (sym->as == NULL) ? 0 : sym->as->rank; } *************** compare_parameter (gfc_symbol *formal, g *** 1691,1697 **** if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && actual->ts.type != BT_HOLLERITH ! && !gfc_compare_types (&formal->ts, &actual->ts)) { if (where) gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s", --- 1694,1703 ---- if ((actual->expr_type != EXPR_NULL || actual->ts.type != BT_UNKNOWN) && actual->ts.type != BT_HOLLERITH ! && !gfc_compare_types (&formal->ts, &actual->ts) ! && !(formal->ts.type == BT_DERIVED && actual->ts.type == BT_CLASS ! && gfc_compare_derived_types (formal->ts.u.derived, ! CLASS_DATA (actual)->ts.u.derived))) { if (where) gfc_error ("Type mismatch in argument '%s' at %L; passed %s to %s", *************** compare_parameter (gfc_symbol *formal, g *** 1820,1825 **** --- 1826,1835 ---- if (symbol_rank (formal) == actual->rank) return 1; + if (actual->ts.type == BT_CLASS && CLASS_DATA (actual)->as + && CLASS_DATA (actual)->as->rank == symbol_rank (formal)) + return 1; + rank_check = where != NULL && !is_elemental && formal->as && (formal->as->type == AS_ASSUMED_SHAPE || formal->as->type == AS_DEFERRED) *************** compare_parameter (gfc_symbol *formal, g *** 1829,1835 **** if (rank_check || ranks_must_agree || (formal->attr.pointer && actual->expr_type != EXPR_NULL) || (actual->rank != 0 && !(is_elemental || formal->attr.dimension)) ! || (actual->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE && actual->expr_type != EXPR_NULL) || (actual->rank == 0 && formal->attr.dimension && gfc_is_coindexed (actual))) --- 1839,1849 ---- if (rank_check || ranks_must_agree || (formal->attr.pointer && actual->expr_type != EXPR_NULL) || (actual->rank != 0 && !(is_elemental || formal->attr.dimension)) ! || (actual->rank == 0 ! && ((formal->ts.type == BT_CLASS ! && CLASS_DATA (formal)->as->type == AS_ASSUMED_SHAPE) ! || (formal->ts.type != BT_CLASS ! && formal->as->type == AS_ASSUMED_SHAPE)) && actual->expr_type != EXPR_NULL) || (actual->rank == 0 && formal->attr.dimension && gfc_is_coindexed (actual))) *************** compare_actual_formal (gfc_actual_arglis *** 2158,2163 **** --- 2172,2178 ---- gfc_formal_arglist *f; int i, n, na; unsigned long actual_size, formal_size; + bool full_array = false; actual = *ap; *************** compare_actual_formal (gfc_actual_arglis *** 2297,2302 **** --- 2312,2320 ---- return 0; } + if (f->sym->ts.type == BT_CLASS) + goto skip_size_check; + actual_size = get_expr_storage_size (a->expr); formal_size = get_sym_storage_size (f->sym); if (actual_size != 0 && actual_size < formal_size *************** compare_actual_formal (gfc_actual_arglis *** 2316,2321 **** --- 2334,2341 ---- return 0; } + skip_size_check: + /* Satisfy 12.4.1.3 by ensuring that a procedure pointer actual argument is provided for a procedure pointer formal argument. */ if (f->sym->attr.proc_pointer *************** compare_actual_formal (gfc_actual_arglis *** 2428,2433 **** --- 2448,2465 ---- return 0; } + if (f->sym->ts.type == BT_CLASS + && CLASS_DATA (f->sym)->attr.allocatable + && gfc_is_class_array_ref (a->expr, &full_array) + && !full_array) + { + if (where) + gfc_error ("Actual CLASS array argument for '%s' must be a full " + "array at %L", f->sym->name, &a->expr->where); + return 0; + } + + if (a->expr->expr_type != EXPR_NULL && compare_allocatable (f->sym, a->expr) == 0) { Index: gcc/fortran/trans-expr.c =================================================================== *** gcc/fortran/trans-expr.c (revision 182187) --- gcc/fortran/trans-expr.c (working copy) *************** along with GCC; see the file COPYING3. *** 41,46 **** --- 41,310 ---- #include "trans-stmt.h" #include "dependency.h" + + /* This is the seed for an eventual trans-class.c + + The following parameters should not be used directly since they might + in future implementations. Use the corresponding APIs. */ + #define CLASS_DATA_FIELD 0 + #define CLASS_VPTR_FIELD 1 + #define VTABLE_HASH_FIELD 0 + #define VTABLE_SIZE_FIELD 1 + #define VTABLE_EXTENDS_FIELD 2 + #define VTABLE_DEF_INIT_FIELD 3 + #define VTABLE_COPY_FIELD 4 + + + tree + gfc_class_data_get (tree decl) + { + tree data; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + data = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), + CLASS_DATA_FIELD); + return fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (data), decl, data, + NULL_TREE); + } + + + tree + gfc_class_vptr_get (tree decl) + { + tree vptr; + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + vptr = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (decl)), + CLASS_VPTR_FIELD); + return fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (vptr), decl, vptr, + NULL_TREE); + } + + + static tree + gfc_vtable_field_get (tree decl, int field) + { + tree size; + tree vptr; + vptr = gfc_class_vptr_get (decl); + vptr = build_fold_indirect_ref_loc (input_location, vptr); + size = gfc_advance_chain (TYPE_FIELDS (TREE_TYPE (vptr)), + field); + size = fold_build3_loc (input_location, COMPONENT_REF, + TREE_TYPE (size), vptr, size, + NULL_TREE); + /* Always return size as an array index type. */ + if (field == VTABLE_SIZE_FIELD) + size = fold_convert (gfc_array_index_type, size); + gcc_assert (size); + return size; + } + + + tree + gfc_vtable_hash_get (tree decl) + { + return gfc_vtable_field_get (decl, VTABLE_HASH_FIELD); + } + + + tree + gfc_vtable_size_get (tree decl) + { + return gfc_vtable_field_get (decl, VTABLE_SIZE_FIELD); + } + + + tree + gfc_vtable_extends_get (tree decl) + { + return gfc_vtable_field_get (decl, VTABLE_EXTENDS_FIELD); + } + + + tree + gfc_vtable_def_init_get (tree decl) + { + return gfc_vtable_field_get (decl, VTABLE_DEF_INIT_FIELD); + } + + + tree + gfc_vtable_copy_get (tree decl) + { + return gfc_vtable_field_get (decl, VTABLE_COPY_FIELD); + } + + + #undef CLASS_DATA_FIELD + #undef CLASS_VPTR_FIELD + #undef VTABLE_HASH_FIELD + #undef VTABLE_SIZE_FIELD + #undef VTABLE_EXTENDS_FIELD + #undef VTABLE_DEF_INIT_FIELD + #undef VTABLE_COPY_FIELD + + + /* Takes a derived type expression and returns the address of a temporary + class object of the 'declared' type. */ + static void + gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, + gfc_typespec class_ts) + { + gfc_symbol *vtab; + gfc_ss *ss; + tree ctree; + tree var; + tree tmp; + + /* The derived type needs to be converted to a temporary + CLASS object. */ + tmp = gfc_typenode_for_spec (&class_ts); + var = gfc_create_var (tmp, "class"); + + /* Set the vptr. */ + ctree = gfc_class_vptr_get (var); + + /* Remember the vtab corresponds to the derived type + not to the class declared type. */ + vtab = gfc_find_derived_vtab (e->ts.u.derived); + gcc_assert (vtab); + tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), tmp)); + + /* Now set the data field. */ + ctree = gfc_class_data_get (var); + + if (parmse->ss && parmse->ss->info->useflags) + { + /* For an array reference in an elemental procedure call we need + to retain the ss to provide the scalarized array reference. */ + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + ss = gfc_walk_expr (e); + if (ss == gfc_ss_terminator) + { + parmse->ss = NULL; + gfc_conv_expr_reference (parmse, e); + tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); + gfc_add_modify (&parmse->pre, ctree, tmp); + } + else + { + parmse->ss = ss; + gfc_conv_expr_descriptor (parmse, e, ss); + gfc_add_modify (&parmse->pre, ctree, parmse->expr); + } + } + + /* Pass the address of the class object. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, var); + } + + + /* Takes a scalarized class array expression and returns the + address of a temporary scalar class object of the 'declared' + type. + OOP-TODO: This could be improved by adding code that branched on + the dynamic type being the same as the declared type. In this case + the original class expression can be passed directly. */ + static void + gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, + gfc_typespec class_ts, bool elemental) + { + tree ctree; + tree var; + tree tmp; + tree vptr; + gfc_ref *ref; + gfc_ref *class_ref; + bool full_array = false; + + class_ref = NULL; + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS) + class_ref = ref; + + if (ref->next == NULL) + break; + } + + if (ref == NULL || class_ref == ref) + return; + + /* Test for FULL_ARRAY. */ + gfc_is_class_array_ref (e, &full_array); + + /* The derived type needs to be converted to a temporary + CLASS object. */ + tmp = gfc_typenode_for_spec (&class_ts); + var = gfc_create_var (tmp, "class"); + + /* Set the data. */ + ctree = gfc_class_data_get (var); + gfc_add_modify (&parmse->pre, ctree, parmse->expr); + + /* Return the data component, except in the case of scalarized array + references, where nullification of the cannot occur and so there + is no need. */ + if (!elemental && full_array) + gfc_add_modify (&parmse->post, parmse->expr, ctree); + + /* Set the vptr. */ + ctree = gfc_class_vptr_get (var); + + /* The vptr is the second field of the actual argument. + First we have to find the corresponding class reference. */ + + tmp = NULL_TREE; + if (class_ref == NULL + && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS) + tmp = e->symtree->n.sym->backend_decl; + else + { + /* Remove everything after the last class reference, convert the + expression and then recover its tailend once more. */ + gfc_se tmpse; + ref = class_ref->next; + class_ref->next = NULL; + gfc_init_se (&tmpse, NULL); + gfc_conv_expr (&tmpse, e); + class_ref->next = ref; + tmp = tmpse.expr; + } + + gcc_assert (tmp != NULL_TREE); + + /* Dereference if needs be. */ + if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE) + tmp = build_fold_indirect_ref_loc (input_location, tmp); + + vptr = gfc_class_vptr_get (tmp); + gfc_add_modify (&parmse->pre, ctree, + fold_convert (TREE_TYPE (ctree), vptr)); + + /* Return the vptr component, except in the case of scalarized array + references, where the dynamic type cannot change. */ + if (!elemental && full_array) + gfc_add_modify (&parmse->post, vptr, + fold_convert (TREE_TYPE (vptr), ctree)); + + /* Pass the address of the class object. */ + parmse->expr = gfc_build_addr_expr (NULL_TREE, var); + } + + /* End of prototype trans-class.c */ + + static tree gfc_trans_structure_assign (tree dest, gfc_expr * expr); static void gfc_apply_interface_mapping_to_expr (gfc_interface_mapping *, gfc_expr *); *************** gfc_conv_variable (gfc_se * se, gfc_expr *** 799,804 **** --- 1063,1069 ---- conv_parent_component_references (se, ref); gfc_conv_component_ref (se, ref); + break; case REF_SUBSTRING: *************** gfc_conv_subref_array_arg (gfc_se * parm *** 2409,2414 **** --- 2674,2682 ---- || GFC_DESCRIPTOR_TYPE_P (base_type)) base_type = gfc_get_element_type (base_type); + if (expr->ts.type == BT_CLASS) + base_type = gfc_typenode_for_spec (&CLASS_DATA (expr)->ts); + loop.temp_ss = gfc_get_temp_ss (base_type, ((expr->ts.type == BT_CHARACTER) ? expr->ts.u.cl->backend_decl : NULL), *************** conv_arglist_function (gfc_se *se, gfc_e *** 2645,2708 **** } - /* Takes a derived type expression and returns the address of a temporary - class object of the 'declared' type. */ - static void - gfc_conv_derived_to_class (gfc_se *parmse, gfc_expr *e, - gfc_typespec class_ts) - { - gfc_component *cmp; - gfc_symbol *vtab; - gfc_symbol *declared = class_ts.u.derived; - gfc_ss *ss; - tree ctree; - tree var; - tree tmp; - - /* The derived type needs to be converted to a temporary - CLASS object. */ - tmp = gfc_typenode_for_spec (&class_ts); - var = gfc_create_var (tmp, "class"); - - /* Set the vptr. */ - cmp = gfc_find_component (declared, "_vptr", true, true); - ctree = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (cmp->backend_decl), - var, cmp->backend_decl, NULL_TREE); - - /* Remember the vtab corresponds to the derived type - not to the class declared type. */ - vtab = gfc_find_derived_vtab (e->ts.u.derived); - gcc_assert (vtab); - tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab)); - gfc_add_modify (&parmse->pre, ctree, - fold_convert (TREE_TYPE (ctree), tmp)); - - /* Now set the data field. */ - cmp = gfc_find_component (declared, "_data", true, true); - ctree = fold_build3_loc (input_location, COMPONENT_REF, - TREE_TYPE (cmp->backend_decl), - var, cmp->backend_decl, NULL_TREE); - ss = gfc_walk_expr (e); - if (ss == gfc_ss_terminator) - { - parmse->ss = NULL; - gfc_conv_expr_reference (parmse, e); - tmp = fold_convert (TREE_TYPE (ctree), parmse->expr); - gfc_add_modify (&parmse->pre, ctree, tmp); - } - else - { - parmse->ss = ss; - gfc_conv_expr (parmse, e); - gfc_add_modify (&parmse->pre, ctree, parmse->expr); - } - - /* Pass the address of the class object. */ - parmse->expr = gfc_build_addr_expr (NULL_TREE, var); - } - - /* The following routine generates code for the intrinsic procedures from the ISO_C_BINDING module: * C_LOC (function) --- 2913,2918 ---- *************** gfc_conv_procedure_call (gfc_se * se, gf *** 2954,2959 **** --- 3164,3182 ---- fsym = formal ? formal->sym : NULL; parm_kind = MISSING; + /* Class array expressions are sometimes coming completely unadorned + with either arrayspec or _data component. Correct that here. + OOP-TODO: Move this to the frontend. */ + if (e && e->expr_type == EXPR_VARIABLE + && !e->ref + && e->ts.type == BT_CLASS + && CLASS_DATA (e)->attr.dimension) + { + gfc_typespec temp_ts = e->ts; + gfc_add_class_array_ref (e); + e->ts = temp_ts; + } + if (e == NULL) { if (se->ignore_optional) *************** gfc_conv_procedure_call (gfc_se * se, gf *** 3010,3015 **** --- 3233,3243 ---- } else gfc_conv_expr_reference (&parmse, e); + + /* The scalarizer does not repackage the reference to a class + array - instead it returns a pointer to the data element. */ + if (fsym && fsym->ts.type == BT_CLASS && e->ts.type == BT_CLASS) + gfc_conv_class_to_class (&parmse, e, fsym->ts, true); } else { *************** gfc_conv_procedure_call (gfc_se * se, gf *** 3073,3078 **** --- 3301,3313 ---- { gfc_conv_expr_reference (&parmse, e); + /* A class array element needs converting back to be a + class object, if the formal argument is a class object. */ + if (fsym && fsym->ts.type == BT_CLASS + && e->ts.type == BT_CLASS + && CLASS_DATA (e)->attr.dimension) + gfc_conv_class_to_class (&parmse, e, fsym->ts, false); + /* If an ALLOCATABLE dummy argument has INTENT(OUT) and is allocated on entry, it must be deallocated. */ if (fsym && fsym->attr.allocatable *************** gfc_conv_procedure_call (gfc_se * se, gf *** 3124,3129 **** --- 3359,3375 ---- } } } + else if (e->ts.type == BT_CLASS + && fsym && fsym->ts.type == BT_CLASS + && CLASS_DATA (fsym)->attr.dimension) + { + /* Pass a class array. */ + gfc_init_se (&parmse, se); + gfc_conv_expr_descriptor (&parmse, e, argss); + /* The conversion does not repackage the reference to a class + array - _data descriptor. */ + gfc_conv_class_to_class (&parmse, e, fsym->ts, false); + } else { /* If the procedure requires an explicit interface, the actual *************** gfc_conv_procedure_call (gfc_se * se, gf *** 3188,3193 **** --- 3434,3451 ---- gfc_conv_subref_array_arg (&parmse, e, f, fsym ? fsym->attr.intent : INTENT_INOUT, fsym && fsym->attr.pointer); + else if (gfc_is_class_array_ref (e, NULL) + && fsym && fsym->ts.type == BT_DERIVED) + /* The actual argument is a component reference to an + array of derived types. In this case, the argument + is converted to a temporary, which is passed and then + written back after the procedure call. + OOP-TODO: Insert code so that if the dynamic type is + the same as the declared type, copy-in/copy-out does + not occur. */ + gfc_conv_subref_array_arg (&parmse, e, f, + fsym ? fsym->attr.intent : INTENT_INOUT, + fsym && fsym->attr.pointer); else gfc_conv_array_parameter (&parmse, e, argss, f, fsym, sym->name, NULL); *************** gfc_conv_expr (gfc_se * se, gfc_expr * e *** 4895,4901 **** expr->ts.kind = expr->ts.u.derived->ts.kind; } } ! switch (expr->expr_type) { case EXPR_OP: --- 5153,5164 ---- expr->ts.kind = expr->ts.u.derived->ts.kind; } } ! ! /* TODO: make this work for general class array expressions. */ ! if (expr->ts.type == BT_CLASS ! && expr->ref && expr->ref->type == REF_ARRAY) ! gfc_add_component_ref (expr, "_data"); ! switch (expr->expr_type) { case EXPR_OP: *************** gfc_trans_assign (gfc_code * code) *** 6469,6474 **** --- 6732,6767 ---- } + static tree + gfc_trans_class_array_init_assign (gfc_expr *rhs, gfc_expr *lhs, gfc_expr *obj) + { + gfc_actual_arglist *actual; + gfc_expr *ppc; + gfc_code *ppc_code; + tree res; + + actual = gfc_get_actual_arglist (); + actual->expr = gfc_copy_expr (rhs); + actual->next = gfc_get_actual_arglist (); + actual->next->expr = gfc_copy_expr (lhs); + ppc = gfc_copy_expr (obj); + gfc_add_vptr_component (ppc); + gfc_add_component_ref (ppc, "_copy"); + ppc_code = gfc_get_code (); + ppc_code->resolved_sym = ppc->symtree->n.sym; + /* Although '_copy' is set to be elemental in class.c, it is + not staying that way. Find out why, sometime.... */ + ppc_code->resolved_sym->attr.elemental = 1; + ppc_code->ext.actual = actual; + ppc_code->expr1 = ppc; + ppc_code->op = EXEC_CALL; + /* Since '_copy' is elemental, the scalarizer will take care + of arrays in gfc_trans_call. */ + res = gfc_trans_call (ppc_code, false, NULL, NULL, false); + gfc_free_statements (ppc_code); + return res; + } + /* Special case for initializing a polymorphic dummy with INTENT(OUT). A MEMCPY is needed to copy the full data from the default initializer of the dynamic type. */ *************** gfc_trans_class_init_assign (gfc_code *c *** 6495,6512 **** gfc_get_derived_type (rhs->ts.u.derived); gfc_add_def_init_component (rhs); ! sz = gfc_copy_expr (code->expr1); ! gfc_add_vptr_component (sz); ! gfc_add_size_component (sz); ! ! gfc_init_se (&dst, NULL); ! gfc_init_se (&src, NULL); ! gfc_init_se (&memsz, NULL); ! gfc_conv_expr (&dst, lhs); ! gfc_conv_expr (&src, rhs); ! gfc_conv_expr (&memsz, sz); ! gfc_add_block_to_block (&block, &src.pre); ! tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); --- 6788,6811 ---- gfc_get_derived_type (rhs->ts.u.derived); gfc_add_def_init_component (rhs); ! if (code->expr1->ts.type == BT_CLASS ! && CLASS_DATA (code->expr1)->attr.dimension) ! tmp = gfc_trans_class_array_init_assign (rhs, lhs, code->expr1); ! else ! { ! sz = gfc_copy_expr (code->expr1); ! gfc_add_vptr_component (sz); ! gfc_add_size_component (sz); ! ! gfc_init_se (&dst, NULL); ! gfc_init_se (&src, NULL); ! gfc_init_se (&memsz, NULL); ! gfc_conv_expr (&dst, lhs); ! gfc_conv_expr (&src, rhs); ! gfc_conv_expr (&memsz, sz); ! gfc_add_block_to_block (&block, &src.pre); ! tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz.expr); ! } gfc_add_expr_to_block (&block, tmp); return gfc_finish_block (&block); *************** gfc_trans_class_assign (gfc_expr *expr1, *** 6553,6561 **** gfc_free_expr (lhs); gfc_free_expr (rhs); } /* Do the actual CLASS assignment. */ ! if (expr2->ts.type == BT_CLASS) op = EXEC_ASSIGN; else gfc_add_data_component (expr1); --- 6852,6875 ---- gfc_free_expr (lhs); gfc_free_expr (rhs); } + else if (CLASS_DATA (expr2)->attr.dimension) + { + /* Insert an additional assignment which sets the '_vptr' field. */ + lhs = gfc_copy_expr (expr1); + gfc_add_vptr_component (lhs); + + rhs = gfc_copy_expr (expr2); + gfc_add_vptr_component (rhs); + + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + + gfc_free_expr (lhs); + gfc_free_expr (rhs); + } /* Do the actual CLASS assignment. */ ! if (expr2->ts.type == BT_CLASS && !CLASS_DATA (expr2)->attr.dimension) op = EXEC_ASSIGN; else gfc_add_data_component (expr1); Index: gcc/fortran/trans-array.c =================================================================== *** gcc/fortran/trans-array.c (revision 182187) --- gcc/fortran/trans-array.c (working copy) *************** gfc_add_loop_ss_code (gfc_loopinfo * loo *** 2428,2436 **** gfc_conv_expr (&se, expr); gfc_add_block_to_block (&outer_loop->pre, &se.pre); gfc_add_block_to_block (&outer_loop->post, &se.post); - ss_info->data.scalar.value = gfc_evaluate_now (se.expr, - &outer_loop->pre); ss_info->string_length = se.string_length; break; --- 2428,2445 ---- gfc_conv_expr (&se, expr); gfc_add_block_to_block (&outer_loop->pre, &se.pre); gfc_add_block_to_block (&outer_loop->post, &se.post); + if (gfc_is_class_scalar_expr (expr)) + /* This is necessary because the dynamic type will always be + large than the declared type. In consequence, assigning + the value to a temporary could segfault. + OOP-TODO: see if this is generally correct or is the value + has to be written to an allocated temporary, whose address + is passed via ss_info. */ + ss_info->data.scalar.value = se.expr; + else + ss_info->data.scalar.value = gfc_evaluate_now (se.expr, + &outer_loop->pre); ss_info->string_length = se.string_length; break; *************** conv_array_index_offset (gfc_se * se, gf *** 2879,2884 **** --- 2888,2969 ---- } + /* Build a scalarized array reference using the vptr 'size'. */ + + static bool + build_class_array_ref (gfc_se *se, tree base, tree index) + { + tree type; + tree size; + tree offset; + tree decl; + tree tmp; + gfc_expr *expr = se->ss->info->expr; + gfc_ref *ref; + gfc_ref *class_ref; + gfc_typespec *ts; + + if (expr == NULL || expr->ts.type != BT_CLASS) + return false; + + if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS) + ts = &expr->symtree->n.sym->ts; + else + ts = NULL; + class_ref = NULL; + + for (ref = expr->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS + && ref->next && ref->next->type == REF_COMPONENT + && strcmp (ref->next->u.c.component->name, "_data") == 0 + && ref->next->next + && ref->next->next->type == REF_ARRAY + && ref->next->next->u.ar.type != AR_ELEMENT) + { + ts = &ref->u.c.component->ts; + class_ref = ref; + break; + } + } + + if (ts == NULL) + return false; + + if (class_ref == NULL) + decl = expr->symtree->n.sym->backend_decl; + else + { + /* Remove everything after the last class reference, convert the + expression and then recover its tailend once more. */ + gfc_se tmpse; + ref = class_ref->next; + class_ref->next = NULL; + gfc_init_se (&tmpse, NULL); + gfc_conv_expr (&tmpse, expr); + decl = tmpse.expr; + class_ref->next = ref; + } + + size = gfc_vtable_size_get (decl); + + /* Build the address of the element. */ + type = TREE_TYPE (TREE_TYPE (base)); + size = fold_convert (TREE_TYPE (index), size); + offset = fold_build2_loc (input_location, MULT_EXPR, + gfc_array_index_type, + index, size); + tmp = gfc_build_addr_expr (pvoid_type_node, base); + tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); + tmp = fold_convert (build_pointer_type (type), tmp); + + /* Return the element in the se expression. */ + se->expr = build_fold_indirect_ref_loc (input_location, tmp); + return true; + } + + /* Build a scalarized reference to an array. */ static void *************** gfc_conv_scalarized_array_ref (gfc_se * *** 2911,2916 **** --- 2996,3007 ---- decl = expr->symtree->n.sym->backend_decl; tmp = build_fold_indirect_ref_loc (input_location, info->data); + + /* Use the vptr 'size' field to access a class the element of a class + array. */ + if (build_class_array_ref (se, tmp, index)) + return; + se->expr = gfc_build_array_ref (tmp, index, decl); } *************** gfc_conv_descriptor_cosize (tree desc, i *** 4592,4598 **** static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, ! stmtblock_t * descriptor_block, tree * overflow) { tree type; tree tmp; --- 4683,4690 ---- static tree gfc_array_init_size (tree descriptor, int rank, int corank, tree * poffset, gfc_expr ** lower, gfc_expr ** upper, stmtblock_t * pblock, ! stmtblock_t * descriptor_block, tree * overflow, ! gfc_expr *expr3) { tree type; tree tmp; *************** gfc_array_init_size (tree descriptor, in *** 4747,4754 **** } /* The stride is the number of elements in the array, so multiply by the ! size of an element to get the total size. */ ! tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); /* Convert to size_t. */ element_size = fold_convert (size_type_node, tmp); --- 4839,4868 ---- } /* The stride is the number of elements in the array, so multiply by the ! size of an element to get the total size. Obviously, if there ia a ! SOURCE expression (expr3) we must use its element size. */ ! if (expr3 != NULL) ! { ! if (expr3->ts.type == BT_CLASS) ! { ! gfc_se se_sz; ! gfc_expr *sz = gfc_copy_expr (expr3); ! gfc_add_vptr_component (sz); ! gfc_add_size_component (sz); ! gfc_init_se (&se_sz, NULL); ! gfc_conv_expr (&se_sz, sz); ! gfc_free_expr (sz); ! tmp = se_sz.expr; ! } ! else ! { ! tmp = gfc_typenode_for_spec (&expr3->ts); ! tmp = TYPE_SIZE_UNIT (tmp); ! } ! } ! else ! tmp = TYPE_SIZE_UNIT (gfc_get_element_type (type)); ! /* Convert to size_t. */ element_size = fold_convert (size_type_node, tmp); *************** gfc_array_init_size (tree descriptor, in *** 4813,4819 **** bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ! tree errlen) { tree tmp; tree pointer; --- 4927,4933 ---- bool gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status, tree errmsg, ! tree errlen, gfc_expr *expr3) { tree tmp; tree pointer; *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 4897,4903 **** gfc_init_block (&set_descriptor_block); size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, ! &se->pre, &set_descriptor_block, &overflow); if (dimension) { --- 5011,5018 ---- gfc_init_block (&set_descriptor_block); size = gfc_array_init_size (se->expr, ref->u.ar.as->rank, ref->u.ar.as->corank, &offset, lower, upper, ! &se->pre, &set_descriptor_block, &overflow, ! expr3); if (dimension) { *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 4953,4959 **** --- 5068,5088 ---- tmp = gfc_finish_block (&elseblock); gfc_add_expr_to_block (&se->pre, tmp); + #if 0 + if (expr->ts.type == BT_CLASS && expr3) + { + tmp = build_int_cst (unsigned_char_type_node, 0); + /* With class objects, it is best to play safe and null the + memory because we cannot know if dynamic types have allocatable + components or not.. + OOP-TODO: Determine if this is necessary or not. */ + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMSET), + 3, pointer, tmp, size); + gfc_add_expr_to_block (&se->pre, tmp); + } + #endif /* Update the array descriptors. */ if (dimension) gfc_conv_descriptor_offset_set (&set_descriptor_block, se->expr, offset); *************** gfc_array_allocate (gfc_se * se, gfc_exp *** 4972,4978 **** else gfc_add_expr_to_block (&se->pre, set_descriptor); ! if ((expr->ts.type == BT_DERIVED || expr->ts.type == BT_CLASS) && expr->ts.u.derived->attr.alloc_comp) { tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr, --- 5101,5107 ---- else gfc_add_expr_to_block (&se->pre, set_descriptor); ! if ((expr->ts.type == BT_DERIVED) && expr->ts.u.derived->attr.alloc_comp) { tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, se->expr, *************** structure_alloc_comps (gfc_symbol * der_ *** 7240,7246 **** } else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { ! /* Allocatable scalar CLASS components. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); --- 7369,7375 ---- } else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { ! /* Allocatable CLASS components. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); *************** structure_alloc_comps (gfc_symbol * der_ *** 7249,7261 **** comp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); ! tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, ! CLASS_DATA (c)->ts); ! gfc_add_expr_to_block (&fnblock, tmp); ! ! tmp = fold_build2_loc (input_location, MODIFY_EXPR, ! void_type_node, comp, ! build_int_cst (TREE_TYPE (comp), 0)); gfc_add_expr_to_block (&fnblock, tmp); } break; --- 7378,7395 ---- comp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); ! if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp))) ! tmp = gfc_trans_dealloc_allocated (comp); ! else ! { ! tmp = gfc_deallocate_scalar_with_status (comp, NULL, true, NULL, ! CLASS_DATA (c)->ts); ! gfc_add_expr_to_block (&fnblock, tmp); ! ! tmp = fold_build2_loc (input_location, MODIFY_EXPR, ! void_type_node, comp, ! build_int_cst (TREE_TYPE (comp), 0)); ! } gfc_add_expr_to_block (&fnblock, tmp); } break; *************** structure_alloc_comps (gfc_symbol * der_ *** 7282,7298 **** } else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { ! /* Allocatable scalar CLASS components. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); /* Add reference to '_data' component. */ tmp = CLASS_DATA (c)->backend_decl; comp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); ! tmp = fold_build2_loc (input_location, MODIFY_EXPR, ! void_type_node, comp, ! build_int_cst (TREE_TYPE (comp), 0)); ! gfc_add_expr_to_block (&fnblock, tmp); } else if (cmp_has_alloc_comps) { --- 7416,7437 ---- } else if (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable) { ! /* Allocatable CLASS components. */ comp = fold_build3_loc (input_location, COMPONENT_REF, ctype, decl, cdecl, NULL_TREE); /* Add reference to '_data' component. */ tmp = CLASS_DATA (c)->backend_decl; comp = fold_build3_loc (input_location, COMPONENT_REF, TREE_TYPE (tmp), comp, tmp, NULL_TREE); ! if (GFC_DESCRIPTOR_TYPE_P(TREE_TYPE (comp))) ! gfc_conv_descriptor_data_set (&fnblock, comp, null_pointer_node); ! else ! { ! tmp = fold_build2_loc (input_location, MODIFY_EXPR, ! void_type_node, comp, ! build_int_cst (TREE_TYPE (comp), 0)); ! gfc_add_expr_to_block (&fnblock, tmp); ! } } else if (cmp_has_alloc_comps) { Index: gcc/fortran/class.c =================================================================== *** gcc/fortran/class.c (revision 182187) --- gcc/fortran/class.c (working copy) *************** gfc_add_component_ref (gfc_expr *e, cons *** 64,70 **** while (*tail != NULL) { if ((*tail)->type == REF_COMPONENT) ! derived = (*tail)->u.c.component->ts.u.derived; if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) break; tail = &((*tail)->next); --- 64,77 ---- while (*tail != NULL) { if ((*tail)->type == REF_COMPONENT) ! { ! if (strcmp ((*tail)->u.c.component->name, "_data") == 0 ! && (*tail)->next ! && (*tail)->next->type == REF_ARRAY ! && (*tail)->next->next == NULL) ! return; ! derived = (*tail)->u.c.component->ts.u.derived; ! } if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL) break; tail = &((*tail)->next); *************** gfc_add_component_ref (gfc_expr *e, cons *** 82,87 **** --- 89,243 ---- } + /* This is used to add both the _data component reference and an array + reference to class expressions. Used in translation of intrinsic + array inquiry functions. */ + + void + gfc_add_class_array_ref (gfc_expr *e) + { + int rank = CLASS_DATA (e)->as->rank; + gfc_array_spec *as = CLASS_DATA (e)->as; + gfc_ref *ref = NULL; + gfc_add_component_ref (e, "_data"); + e->rank = rank; + for (ref = e->ref; ref; ref = ref->next) + if (!ref->next) + break; + if (ref->type != REF_ARRAY) + { + ref->next = gfc_get_ref (); + ref = ref->next; + ref->type = REF_ARRAY; + ref->u.ar.type = AR_FULL; + ref->u.ar.as = as; + } + } + + + /* Unfortunately, class array expressions can appear in various conditions; + with and without both _data component and an arrayspec. This function + deals with that variability. The previous reference to 'ref' is to a + class array. */ + + static bool + class_array_ref_detected (gfc_ref *ref, bool *full_array) + { + bool no_data = false; + bool with_data = false; + + /* An array reference with no _data component. */ + if (ref && ref->type == REF_ARRAY + && !ref->next + && ref->u.ar.type != AR_ELEMENT) + { + if (full_array) + *full_array = ref->u.ar.type == AR_FULL; + no_data = true; + } + + /* Cover cases where _data appears, with or without an array ref. */ + if (ref && ref->type == REF_COMPONENT + && strcmp (ref->u.c.component->name, "_data") == 0) + { + if (!ref->next) + { + with_data = true; + if (full_array) + *full_array = true; + } + else if (ref->next && ref->next->type == REF_ARRAY + && !ref->next->next + && ref->type == REF_COMPONENT + && ref->next->type == REF_ARRAY + && ref->next->u.ar.type != AR_ELEMENT) + { + with_data = true; + if (full_array) + *full_array = ref->next->u.ar.type == AR_FULL; + } + } + + return no_data || with_data; + } + + + /* Returns true if the expression contains a reference to a class + array. Notice that class array elements return false. */ + + bool + gfc_is_class_array_ref (gfc_expr *e, bool *full_array) + { + gfc_ref *ref; + + if (!e->rank) + return false; + + if (full_array) + *full_array= false; + + /* Is this a class array object? ie. Is the symbol of type class? */ + if (e->symtree + && e->symtree->n.sym->ts.type == BT_CLASS + && CLASS_DATA (e->symtree->n.sym) + && CLASS_DATA (e->symtree->n.sym)->attr.dimension + && class_array_ref_detected (e->ref, full_array)) + return true; + + /* Or is this a class array component reference? */ + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component)->attr.dimension + && class_array_ref_detected (ref->next, full_array)) + return true; + } + + return false; + } + + + /* Returns true if the expression is a reference to a class + scalar. This function is necessary because such expressions + can be dressed with a reference to the _data component and so + have a type other than BT_CLASS. */ + + bool + gfc_is_class_scalar_expr (gfc_expr *e) + { + gfc_ref *ref; + + if (e->rank) + return false; + + /* Is this a class object? */ + if (e->symtree + && e->symtree->n.sym->ts.type == BT_CLASS + && CLASS_DATA (e->symtree->n.sym) + && !CLASS_DATA (e->symtree->n.sym)->attr.dimension + && (e->ref == NULL + || (strcmp (e->ref->u.c.component->name, "_data") == 0 + && e->ref->next == NULL))) + return true; + + /* Or is the final reference BT_CLASS or _data? */ + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT + && ref->u.c.component->ts.type == BT_CLASS + && CLASS_DATA (ref->u.c.component) + && !CLASS_DATA (ref->u.c.component)->attr.dimension + && (ref->next == NULL + || (strcmp (ref->next->u.c.component->name, "_data") == 0 + && ref->next->next == NULL))) + return true; + } + + return false; + } + + /* Build a NULL initializer for CLASS pointers, initializing the _data component to NULL and the _vptr component to the declared type. */ *************** gfc_build_class_symbol (gfc_typespec *ts *** 183,189 **** gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; ! if (attr->class_ok) /* Class container has already been built. */ return SUCCESS; --- 339,352 ---- gfc_symbol *fclass; gfc_symbol *vtab; gfc_component *c; ! ! if (as && *as && (*as)->type == AS_ASSUMED_SIZE) ! { ! gfc_error ("Assumed size polymorphic objects or components, such " ! "as that at %C, have not yet been implemented"); ! return FAILURE; ! } ! if (attr->class_ok) /* Class container has already been built. */ return SUCCESS; *************** gfc_build_class_symbol (gfc_typespec *ts *** 195,206 **** /* We can not build the class container yet. */ return SUCCESS; - if (*as) - { - gfc_fatal_error ("Polymorphic array at %C not yet supported"); - return FAILURE; - } - /* Determine the name of the encapsulating type. */ get_unique_hashed_string (tname, ts->u.derived); if ((*as) && (*as)->rank && attr->allocatable) --- 358,363 ---- *************** gfc_build_class_symbol (gfc_typespec *ts *** 277,284 **** fclass->attr.extension = ts->u.derived->attr.extension + 1; fclass->attr.is_class = 1; ts->u.derived = fclass; ! attr->allocatable = attr->pointer = attr->dimension = 0; ! (*as) = NULL; /* XXX */ return SUCCESS; } --- 434,441 ---- fclass->attr.extension = ts->u.derived->attr.extension + 1; fclass->attr.is_class = 1; ts->u.derived = fclass; ! attr->allocatable = attr->pointer = attr->dimension = attr->codimension = 0; ! (*as) = NULL; return SUCCESS; } *************** gfc_find_derived_vtab (gfc_symbol *deriv *** 402,408 **** gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; ! /* Find the top-level namespace (MODULE or PROGRAM). */ for (ns = gfc_current_ns; ns; ns = ns->parent) if (!ns->parent) --- 559,565 ---- gfc_namespace *ns; gfc_symbol *vtab = NULL, *vtype = NULL, *found_sym = NULL, *def_init = NULL; gfc_symbol *copy = NULL, *src = NULL, *dst = NULL; ! /* Find the top-level namespace (MODULE or PROGRAM). */ for (ns = gfc_current_ns; ns; ns = ns->parent) if (!ns->parent) *************** gfc_find_derived_vtab (gfc_symbol *deriv *** 556,561 **** --- 713,721 ---- copy->attr.flavor = FL_PROCEDURE; copy->attr.subroutine = 1; copy->attr.if_source = IFSRC_DECL; + /* This is elemental so that arrays are automatically + treated correctly by the scalarizer. */ + copy->attr.elemental = 1; if (ns->proc_name->attr.flavor == FL_MODULE) copy->module = ns->proc_name->name; gfc_set_sym_referenced (copy); *************** gfc_find_derived_vtab (gfc_symbol *deriv *** 565,570 **** --- 725,731 ---- src->ts.u.derived = derived; src->attr.flavor = FL_VARIABLE; src->attr.dummy = 1; + src->attr.intent = INTENT_IN; gfc_set_sym_referenced (src); copy->formal = gfc_get_formal_arglist (); copy->formal->sym = src; *************** gfc_find_derived_vtab (gfc_symbol *deriv *** 573,578 **** --- 734,740 ---- dst->ts.u.derived = derived; dst->attr.flavor = FL_VARIABLE; dst->attr.dummy = 1; + dst->attr.intent = INTENT_OUT; gfc_set_sym_referenced (dst); copy->formal->next = gfc_get_formal_arglist (); copy->formal->next->sym = dst; Index: gcc/fortran/trans-array.h =================================================================== *** gcc/fortran/trans-array.h (revision 182187) --- gcc/fortran/trans-array.h (working copy) *************** tree gfc_array_deallocate (tree, tree, g *** 24,30 **** /* Generate code to initialize an allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ ! bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, --- 24,30 ---- /* Generate code to initialize an allocate an array. Statements are added to se, which should contain an expression for the array descriptor. */ ! bool gfc_array_allocate (gfc_se *, gfc_expr *, tree, tree, tree, gfc_expr *); /* Allow the bounds of a loop to be set from a callee's array spec. */ void gfc_set_loop_bounds_from_array_spec (gfc_interface_mapping *, Index: gcc/fortran/array.c =================================================================== *** gcc/fortran/array.c (revision 182187) --- gcc/fortran/array.c (working copy) *************** gfc_array_dimen_size (gfc_expr *array, i *** 2112,2117 **** --- 2112,2120 ---- gfc_ref *ref; int i; + if (array->ts.type == BT_CLASS) + return FAILURE; + if (dimen < 0 || array == NULL || dimen > array->rank - 1) gfc_internal_error ("gfc_array_dimen_size(): Bad dimension"); *************** gfc_array_size (gfc_expr *array, mpz_t * *** 2190,2195 **** --- 2193,2201 ---- int i; gfc_try t; + if (array->ts.type == BT_CLASS) + return FAILURE; + switch (array->expr_type) { case EXPR_ARRAY: Index: gcc/fortran/gfortran.h =================================================================== *** gcc/fortran/gfortran.h (revision 182187) --- gcc/fortran/gfortran.h (working copy) *************** gfc_try gfc_calculate_transfer_sizes (gf *** 2911,2921 **** --- 2911,2924 ---- /* class.c */ void gfc_add_component_ref (gfc_expr *, const char *); + void gfc_add_class_array_ref (gfc_expr *); #define gfc_add_data_component(e) gfc_add_component_ref(e,"_data") #define gfc_add_vptr_component(e) gfc_add_component_ref(e,"_vptr") #define gfc_add_hash_component(e) gfc_add_component_ref(e,"_hash") #define gfc_add_size_component(e) gfc_add_component_ref(e,"_size") #define gfc_add_def_init_component(e) gfc_add_component_ref(e,"_def_init") + bool gfc_is_class_array_ref (gfc_expr *, bool *); + bool gfc_is_class_scalar_expr (gfc_expr *); gfc_expr *gfc_class_null_initializer (gfc_typespec *); unsigned int gfc_hash_value (gfc_symbol *); gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *, Index: gcc/fortran/trans-stmt.c =================================================================== *** gcc/fortran/trans-stmt.c (revision 182187) --- gcc/fortran/trans-stmt.c (working copy) *************** trans_associate_var (gfc_symbol *sym, gf *** 1093,1106 **** { gfc_expr *e; tree tmp; gcc_assert (sym->assoc); e = sym->assoc->target; /* Do a `pointer assignment' with updated descriptor (or assign descriptor to array temporary) for arrays with either unknown shape or if associating to a variable. */ ! if (sym->attr.dimension && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) { gfc_se se; --- 1093,1111 ---- { gfc_expr *e; tree tmp; + bool class_target; gcc_assert (sym->assoc); e = sym->assoc->target; + class_target = (e->expr_type == EXPR_VARIABLE) + && (gfc_is_class_scalar_expr (e) + || gfc_is_class_array_ref (e, NULL)); + /* Do a `pointer assignment' with updated descriptor (or assign descriptor to array temporary) for arrays with either unknown shape or if associating to a variable. */ ! if (sym->attr.dimension && !class_target && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) { gfc_se se; *************** trans_associate_var (gfc_symbol *sym, gf *** 1140,1145 **** --- 1145,1167 ---- gfc_finish_block (&se.post)); } + /* CLASS arrays just need the descriptor to be directly assigned. */ + else if (class_target && sym->attr.dimension) + { + gfc_se se; + + gfc_init_se (&se, NULL); + gfc_conv_expr (&se, e); + + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))); + gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); + + gfc_add_modify (&se.pre, sym->backend_decl, se.expr); + + gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), + gfc_finish_block (&se.post)); + } + /* Do a scalar pointer assignment; this is for scalar variable targets. */ else if (gfc_is_associate_pointer (sym)) { *************** tree *** 4677,4682 **** --- 4699,4705 ---- gfc_trans_allocate (gfc_code * code) { gfc_alloc *al; + gfc_expr *e; gfc_expr *expr; gfc_se se; tree tmp; *************** gfc_trans_allocate (gfc_code * code) *** 4748,4754 **** se.descriptor_only = 1; gfc_conv_expr (&se, expr); ! if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen)) { /* A scalar or derived type. */ --- 4771,4777 ---- se.descriptor_only = 1; gfc_conv_expr (&se, expr); ! if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, code->expr3)) { /* A scalar or derived type. */ *************** gfc_trans_allocate (gfc_code * code) *** 4878,4883 **** --- 4901,4916 ---- tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0); gfc_add_expr_to_block (&se.pre, tmp); } + else if (al->expr->ts.type == BT_CLASS && code->expr3) + { + /* With class objects, it is best to play safe and null the + memory because we cannot know if dynamic types have allocatable + components or not. */ + tmp = build_call_expr_loc (input_location, + builtin_decl_explicit (BUILT_IN_MEMSET), + 3, se.expr, integer_zero_node, memsz); + gfc_add_expr_to_block (&se.pre, tmp); + } } gfc_add_block_to_block (&block, &se.pre); *************** gfc_trans_allocate (gfc_code * code) *** 4901,4906 **** --- 4934,4993 ---- gfc_add_expr_to_block (&block, tmp); } + /* We need the vptr of CLASS objects to be initialized. */ + e = gfc_copy_expr (al->expr); + if (e->ts.type == BT_CLASS) + { + gfc_expr *lhs,*rhs; + gfc_se lse; + + lhs = gfc_expr_to_initialize (e); + gfc_add_vptr_component (lhs); + rhs = NULL; + if (code->expr3 && code->expr3->ts.type == BT_CLASS) + { + /* Polymorphic SOURCE: VPTR must be determined at run time. */ + rhs = gfc_copy_expr (code->expr3); + gfc_add_vptr_component (rhs); + tmp = gfc_trans_pointer_assignment (lhs, rhs); + gfc_add_expr_to_block (&block, tmp); + gfc_free_expr (rhs); + rhs = gfc_expr_to_initialize (e); + } + else + { + /* VPTR is fixed at compile time. */ + gfc_symbol *vtab; + gfc_typespec *ts; + if (code->expr3) + ts = &code->expr3->ts; + else if (e->ts.type == BT_DERIVED) + ts = &e->ts; + else if (code->ext.alloc.ts.type == BT_DERIVED) + ts = &code->ext.alloc.ts; + else if (e->ts.type == BT_CLASS) + ts = &CLASS_DATA (e)->ts; + else + ts = &e->ts; + + if (ts->type == BT_DERIVED) + { + vtab = gfc_find_derived_vtab (ts->u.derived); + gcc_assert (vtab); + gfc_init_se (&lse, NULL); + lse.want_pointer = 1; + gfc_conv_expr (&lse, lhs); + tmp = gfc_build_addr_expr (NULL_TREE, + gfc_get_symbol_decl (vtab)); + gfc_add_modify (&block, lse.expr, + fold_convert (TREE_TYPE (lse.expr), tmp)); + } + } + gfc_free_expr (lhs); + } + + gfc_free_expr (e); + if (code->expr3 && !code->expr3->mold) { /* Initialization via SOURCE block *************** gfc_trans_allocate (gfc_code * code) *** 4908,4917 **** gfc_expr *rhs = gfc_copy_expr (code->expr3); if (al->expr->ts.type == BT_CLASS) { - gfc_se call; gfc_actual_arglist *actual; gfc_expr *ppc; ! gfc_init_se (&call, NULL); /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); actual->expr = gfc_copy_expr (rhs); --- 4995,5005 ---- gfc_expr *rhs = gfc_copy_expr (code->expr3); if (al->expr->ts.type == BT_CLASS) { gfc_actual_arglist *actual; gfc_expr *ppc; ! gfc_code *ppc_code; ! gfc_ref *dataref; ! /* Do a polymorphic deep copy. */ actual = gfc_get_actual_arglist (); actual->expr = gfc_copy_expr (rhs); *************** gfc_trans_allocate (gfc_code * code) *** 4919,4938 **** gfc_add_data_component (actual->expr); actual->next = gfc_get_actual_arglist (); actual->next->expr = gfc_copy_expr (al->expr); gfc_add_data_component (actual->next->expr); if (rhs->ts.type == BT_CLASS) { ppc = gfc_copy_expr (rhs); gfc_add_vptr_component (ppc); } else ! ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived)); gfc_add_component_ref (ppc, "_copy"); ! gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual, ! ppc, NULL); ! gfc_add_expr_to_block (&call.pre, call.expr); ! gfc_add_block_to_block (&call.pre, &call.post); ! tmp = gfc_finish_block (&call.pre); } else if (expr3 != NULL_TREE) { --- 5007,5064 ---- gfc_add_data_component (actual->expr); actual->next = gfc_get_actual_arglist (); actual->next->expr = gfc_copy_expr (al->expr); + actual->next->expr->ts.type = BT_CLASS; gfc_add_data_component (actual->next->expr); + dataref = actual->next->expr->ref; + if (dataref->u.c.component->as) + { + int dim; + gfc_expr *temp; + gfc_ref *ref = dataref->next; + ref->u.ar.type = AR_SECTION; + /* We have to set up the array reference to give ranges + in all dimensions and ensure that the end and stride + are set so that the copy can be scalarized. */ + dim = 0; + for (; dim < dataref->u.c.component->as->rank; dim++) + { + ref->u.ar.dimen_type[dim] = DIMEN_RANGE; + if (ref->u.ar.end[dim] == NULL) + { + ref->u.ar.end[dim] = ref->u.ar.start[dim]; + temp = gfc_get_int_expr (gfc_default_integer_kind, + &al->expr->where, 1); + ref->u.ar.start[dim] = temp; + } + temp = gfc_subtract (gfc_copy_expr (ref->u.ar.end[dim]), + gfc_copy_expr (ref->u.ar.start[dim])); + temp = gfc_add (gfc_get_int_expr (gfc_default_integer_kind, + &al->expr->where, 1), + temp); + } + } if (rhs->ts.type == BT_CLASS) { ppc = gfc_copy_expr (rhs); gfc_add_vptr_component (ppc); } else ! ppc = gfc_lval_expr_from_sym ! (gfc_find_derived_vtab (rhs->ts.u.derived)); gfc_add_component_ref (ppc, "_copy"); ! ! ppc_code = gfc_get_code (); ! ppc_code->resolved_sym = ppc->symtree->n.sym; ! /* Although '_copy' is set to be elemental in class.c, it is ! not staying that way. Find out why, sometime.... */ ! ppc_code->resolved_sym->attr.elemental = 1; ! ppc_code->ext.actual = actual; ! ppc_code->expr1 = ppc; ! ppc_code->op = EXEC_CALL; ! /* Since '_copy' is elemental, the scalarizer will take care ! of arrays in gfc_trans_call. */ ! tmp = gfc_trans_call (ppc_code, true, NULL, NULL, false); ! gfc_free_statements (ppc_code); } else if (expr3 != NULL_TREE) { *************** gfc_trans_allocate (gfc_code * code) *** 4972,5030 **** gfc_free_expr (rhs); } - /* Allocation of CLASS entities. */ gfc_free_expr (expr); - expr = al->expr; - if (expr->ts.type == BT_CLASS) - { - gfc_expr *lhs,*rhs; - gfc_se lse; - - /* Initialize VPTR for CLASS objects. */ - lhs = gfc_expr_to_initialize (expr); - gfc_add_vptr_component (lhs); - rhs = NULL; - if (code->expr3 && code->expr3->ts.type == BT_CLASS) - { - /* Polymorphic SOURCE: VPTR must be determined at run time. */ - rhs = gfc_copy_expr (code->expr3); - gfc_add_vptr_component (rhs); - tmp = gfc_trans_pointer_assignment (lhs, rhs); - gfc_add_expr_to_block (&block, tmp); - gfc_free_expr (rhs); - } - else - { - /* VPTR is fixed at compile time. */ - gfc_symbol *vtab; - gfc_typespec *ts; - if (code->expr3) - ts = &code->expr3->ts; - else if (expr->ts.type == BT_DERIVED) - ts = &expr->ts; - else if (code->ext.alloc.ts.type == BT_DERIVED) - ts = &code->ext.alloc.ts; - else if (expr->ts.type == BT_CLASS) - ts = &CLASS_DATA (expr)->ts; - else - ts = &expr->ts; - - if (ts->type == BT_DERIVED) - { - vtab = gfc_find_derived_vtab (ts->u.derived); - gcc_assert (vtab); - gfc_init_se (&lse, NULL); - lse.want_pointer = 1; - gfc_conv_expr (&lse, lhs); - tmp = gfc_build_addr_expr (NULL_TREE, - gfc_get_symbol_decl (vtab)); - gfc_add_modify (&block, lse.expr, - fold_convert (TREE_TYPE (lse.expr), tmp)); - } - } - gfc_free_expr (lhs); - } - } /* STAT (ERRMSG only makes sense with STAT). */ --- 5098,5104 ---- Index: gcc/fortran/expr.c =================================================================== *** gcc/fortran/expr.c (revision 182187) --- gcc/fortran/expr.c (working copy) *************** gfc_get_corank (gfc_expr *e) *** 4309,4315 **** if (!gfc_is_coarray (e)) return 0; ! corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; for (ref = e->ref; ref; ref = ref->next) { --- 4309,4319 ---- if (!gfc_is_coarray (e)) return 0; ! if (e->ts.type == BT_CLASS && e->ts.u.derived->components) ! corank = e->ts.u.derived->components->as ! ? e->ts.u.derived->components->as->corank : 0; ! else ! corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0; for (ref = e->ref; ref; ref = ref->next) { *************** gfc_is_simply_contiguous (gfc_expr *expr *** 4394,4399 **** --- 4398,4404 ---- int i; gfc_array_ref *ar = NULL; gfc_ref *ref, *part_ref = NULL; + gfc_symbol *sym; if (expr->expr_type == EXPR_FUNCTION) return expr->value.function.esym *************** gfc_is_simply_contiguous (gfc_expr *expr *** 4417,4427 **** ar = &ref->u.ar; } ! if ((part_ref && !part_ref->u.c.component->attr.contiguous ! && part_ref->u.c.component->attr.pointer) ! || (!part_ref && !expr->symtree->n.sym->attr.contiguous ! && (expr->symtree->n.sym->attr.pointer ! || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE))) return false; if (!ar || ar->type == AR_FULL) --- 4422,4436 ---- ar = &ref->u.ar; } ! sym = expr->symtree->n.sym; ! if (expr->ts.type != BT_CLASS ! && ((part_ref ! && !part_ref->u.c.component->attr.contiguous ! && part_ref->u.c.component->attr.pointer) ! || (!part_ref ! && !sym->attr.contiguous ! && (sym->attr.pointer ! || sym->as->type == AS_ASSUMED_SHAPE)))) return false; if (!ar || ar->type == AR_FULL) Index: gcc/fortran/trans.c =================================================================== *** gcc/fortran/trans.c (revision 182187) --- gcc/fortran/trans.c (working copy) *************** gfc_build_array_ref (tree base, tree off *** 315,320 **** --- 315,321 ---- { tree type = TREE_TYPE (base); tree tmp; + tree span; if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0) { *************** gfc_build_array_ref (tree base, tree off *** 345,356 **** if (decl && (TREE_CODE (decl) == FIELD_DECL || TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) ! && GFC_DECL_SUBREF_ARRAY_P (decl) ! && !integer_zerop (GFC_DECL_SPAN(decl))) { offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, ! offset, GFC_DECL_SPAN(decl)); tmp = gfc_build_addr_expr (pvoid_type_node, base); tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); tmp = fold_convert (build_pointer_type (type), tmp); --- 346,378 ---- if (decl && (TREE_CODE (decl) == FIELD_DECL || TREE_CODE (decl) == VAR_DECL || TREE_CODE (decl) == PARM_DECL) ! && ((GFC_DECL_SUBREF_ARRAY_P (decl) ! && !integer_zerop (GFC_DECL_SPAN(decl))) ! || GFC_DECL_CLASS (decl))) { + if (GFC_DECL_CLASS (decl)) + { + /* Allow for dummy arguments and other good things. */ + if (POINTER_TYPE_P (TREE_TYPE (decl))) + decl = build_fold_indirect_ref_loc (input_location, decl); + + /* Check if '_data' is an array descriptor. If it is not, + the array must be one of the components of the class object, + so return a normal array reference. */ + if (!GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (gfc_class_data_get (decl)))) + return build4_loc (input_location, ARRAY_REF, type, base, + offset, NULL_TREE, NULL_TREE); + + span = gfc_vtable_size_get (decl); + } + else if (GFC_DECL_SUBREF_ARRAY_P (decl)) + span = GFC_DECL_SPAN(decl); + else + gcc_unreachable (); + offset = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, ! offset, span); tmp = gfc_build_addr_expr (pvoid_type_node, base); tmp = fold_build_pointer_plus_loc (input_location, tmp, offset); tmp = fold_convert (build_pointer_type (type), tmp); Index: gcc/fortran/trans.h =================================================================== *** gcc/fortran/trans.h (revision 182187) --- gcc/fortran/trans.h (working copy) *************** typedef struct *** 333,338 **** --- 333,346 ---- } gfc_wrapped_block; + /* Class API functions. */ + tree gfc_class_data_get (tree); + tree gfc_class_vptr_get (tree); + tree gfc_vtable_hash_get (tree); + tree gfc_vtable_size_get (tree); + tree gfc_vtable_extends_get (tree); + tree gfc_vtable_def_init_get (tree); + tree gfc_vtable_copy_get (tree); /* Initialize an init/cleanup block. */ void gfc_start_wrapped_block (gfc_wrapped_block* block, tree code); *************** struct GTY((variable_size)) lang_decl { *** 803,808 **** --- 811,817 ---- #define GFC_DECL_RESULT(node) DECL_LANG_FLAG_5(node) #define GFC_DECL_SUBREF_ARRAY_P(node) DECL_LANG_FLAG_6(node) #define GFC_DECL_PUSH_TOPLEVEL(node) DECL_LANG_FLAG_7(node) + #define GFC_DECL_CLASS(node) DECL_LANG_FLAG_8(node) /* An array descriptor. */ #define GFC_DESCRIPTOR_TYPE_P(node) TYPE_LANG_FLAG_1(node) Index: gcc/fortran/resolve.c =================================================================== *** gcc/fortran/resolve.c (revision 182187) --- gcc/fortran/resolve.c (working copy) *************** check_typebound_baseobject (gfc_expr* e) *** 5584,5597 **** goto cleanup; } - /* FIXME: Remove once PR 43214 is fixed (TBP with non-scalar PASS). */ - if (base->rank > 0) - { - gfc_error ("Non-scalar base object at %L currently not implemented", - &e->where); - goto cleanup; - } - return_value = SUCCESS; cleanup: --- 5584,5589 ---- *************** resolve_allocate_expr (gfc_expr *e, gfc_ *** 6765,6771 **** } else { ! if (sym->ts.type == BT_CLASS) { allocatable = CLASS_DATA (sym)->attr.allocatable; pointer = CLASS_DATA (sym)->attr.class_pointer; --- 6757,6763 ---- } else { ! if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)) { allocatable = CLASS_DATA (sym)->attr.allocatable; pointer = CLASS_DATA (sym)->attr.class_pointer; *************** resolve_allocate_expr (gfc_expr *e, gfc_ *** 6911,6917 **** if (t == FAILURE) goto failure; ! if (!code->expr3) { /* Set up default initializer if needed. */ gfc_typespec ts; --- 6903,6918 ---- if (t == FAILURE) goto failure; ! if (e->ts.type == BT_CLASS && CLASS_DATA (e)->attr.dimension ! && !code->expr3 && code->ext.alloc.ts.type == BT_DERIVED) ! { ! /* For class arrays, the initialization with SOURCE is done ! using _copy and trans_call. It is convenient to exploit that ! when the allocated type is different from the declared type but ! no SOURCE exists by setting expr3. */ ! code->expr3 = gfc_default_initializer (&code->ext.alloc.ts); ! } ! else if (!code->expr3) { /* Set up default initializer if needed. */ gfc_typespec ts; *************** resolve_allocate_expr (gfc_expr *e, gfc_ *** 6955,6960 **** --- 6956,6963 ---- else if (code->ext.alloc.ts.type == BT_DERIVED) ts = code->ext.alloc.ts; gfc_find_derived_vtab (ts.u.derived); + if (dimension) + e = gfc_expr_to_initialize (e); } if (dimension == 0 && codimension == 0) *************** resolve_select (gfc_code *code) *** 7531,7546 **** return; } - if (case_expr->rank != 0) - { - gfc_error ("Argument of SELECT statement at %L must be a scalar " - "expression", &case_expr->where); - - /* Punt. */ - return; - } - - /* Raise a warning if an INTEGER case value exceeds the range of the case-expr. Later, all expressions will be promoted to the largest kind of all case-labels. */ --- 7534,7539 ---- *************** resolve_assoc_var (gfc_symbol* sym, bool *** 7825,7830 **** --- 7818,7826 ---- sym->attr.volatile_ = tsym->attr.volatile_; sym->attr.target = (tsym->attr.target || tsym->attr.pointer); + + if (sym->ts.type == BT_DERIVED && target->symtree->n.sym->ts.type == BT_CLASS) + target->rank = sym->as ? sym->as->rank : 0; } /* Get type if this was not already set. Note that it can be *************** resolve_assoc_var (gfc_symbol* sym, bool *** 7839,7845 **** && !gfc_has_vector_subscript (target)); /* Finally resolve if this is an array or not. */ ! if (sym->attr.dimension && target->rank == 0) { gfc_error ("Associate-name '%s' at %L is used as array", sym->name, &sym->declared_at); --- 7835,7844 ---- && !gfc_has_vector_subscript (target)); /* Finally resolve if this is an array or not. */ ! if (sym->attr.dimension ! && (target->ts.type == BT_CLASS ! ? !CLASS_DATA (target)->attr.dimension ! : target->rank == 0)) { gfc_error ("Associate-name '%s' at %L is used as array", sym->name, &sym->declared_at); *************** resolve_select_type (gfc_code *code, gfc *** 7955,7960 **** --- 7954,7960 ---- assoc = gfc_get_association_list (); assoc->st = code->expr1->symtree; assoc->target = gfc_copy_expr (code->expr2); + assoc->target->where = code->expr2->where; /* assoc->variable will be set by resolve_assoc_var. */ code->ext.block.assoc = assoc; *************** resolve_select_type (gfc_code *code, gfc *** 8006,8011 **** --- 8006,8012 ---- st = gfc_find_symtree (ns->sym_root, name); gcc_assert (st->n.sym->assoc); st->n.sym->assoc->target = gfc_get_variable_expr (code->expr1->symtree); + st->n.sym->assoc->target->where = code->expr1->where; if (c->ts.type == BT_DERIVED) gfc_add_data_component (st->n.sym->assoc->target); *************** resolve_fl_derived0 (gfc_symbol *sym) *** 11432,11438 **** for (c = sym->components; c != NULL; c = c->next) { /* F2008, C442. */ ! if (c->attr.codimension /* FIXME: c->as check due to PR 43412. */ && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) { gfc_error ("Coarray component '%s' at %L must be allocatable with " --- 11433,11440 ---- for (c = sym->components; c != NULL; c = c->next) { /* F2008, C442. */ ! if ((!sym->attr.is_class || c != sym->components) ! && c->attr.codimension && (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED))) { gfc_error ("Coarray component '%s' at %L must be allocatable with " Index: gcc/fortran/trans-decl.c =================================================================== *** gcc/fortran/trans-decl.c (revision 182187) --- gcc/fortran/trans-decl.c (working copy) *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1293,1299 **** && DECL_CONTEXT (sym->backend_decl) != current_function_decl) gfc_nonlocal_dummy_array_decl (sym); ! return sym->backend_decl; } if (sym->backend_decl) --- 1293,1304 ---- && DECL_CONTEXT (sym->backend_decl) != current_function_decl) gfc_nonlocal_dummy_array_decl (sym); ! if (sym->ts.type == BT_CLASS && sym->backend_decl) ! GFC_DECL_CLASS(sym->backend_decl) = 1; ! ! if (sym->ts.type == BT_CLASS && sym->backend_decl) ! GFC_DECL_CLASS(sym->backend_decl) = 1; ! return sym->backend_decl; } if (sym->backend_decl) *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1314,1320 **** && !intrinsic_array_parameter && sym->module && gfc_get_module_backend_decl (sym)) ! return sym->backend_decl; if (sym->attr.flavor == FL_PROCEDURE) { --- 1319,1329 ---- && !intrinsic_array_parameter && sym->module && gfc_get_module_backend_decl (sym)) ! { ! if (sym->ts.type == BT_CLASS && sym->backend_decl) ! GFC_DECL_CLASS(sym->backend_decl) = 1; ! return sym->backend_decl; ! } if (sym->attr.flavor == FL_PROCEDURE) { *************** gfc_get_symbol_decl (gfc_symbol * sym) *** 1431,1436 **** --- 1440,1448 ---- GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span; } + if (sym->ts.type == BT_CLASS) + GFC_DECL_CLASS(decl) = 1; + sym->backend_decl = decl; if (sym->attr.assign) *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 3656,3661 **** --- 3668,3677 ---- gfc_trans_deferred_array (sym, block); } else if ((!sym->attr.dummy || sym->ts.deferred) + && (sym->ts.type == BT_CLASS + && CLASS_DATA (sym)->attr.pointer)) + break; + else if ((!sym->attr.dummy || sym->ts.deferred) && (sym->attr.allocatable || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.allocatable))) *************** gfc_trans_deferred_vars (gfc_symbol * pr *** 3669,3676 **** gfc_add_data_component (e); gfc_init_se (&se, NULL); ! se.want_pointer = 1; ! gfc_conv_expr (&se, e); gfc_free_expr (e); gfc_save_backend_locus (&loc); --- 3685,3710 ---- gfc_add_data_component (e); gfc_init_se (&se, NULL); ! if (sym->ts.type != BT_CLASS ! || sym->ts.u.derived->attr.dimension ! || sym->ts.u.derived->attr.codimension) ! { ! se.want_pointer = 1; ! gfc_conv_expr (&se, e); ! } ! else if (sym->ts.type == BT_CLASS ! && !CLASS_DATA (sym)->attr.dimension ! && !CLASS_DATA (sym)->attr.codimension) ! { ! se.want_pointer = 1; ! gfc_conv_expr (&se, e); ! } ! else ! { ! gfc_conv_expr (&se, e); ! se.expr = gfc_conv_descriptor_data_addr (se.expr); ! se.expr = build_fold_indirect_ref_loc (input_location, se.expr); ! } gfc_free_expr (e); gfc_save_backend_locus (&loc); Index: gcc/fortran/match.c =================================================================== *** gcc/fortran/match.c (revision 182187) --- gcc/fortran/match.c (working copy) *************** select_type_set_tmp (gfc_typespec *ts) *** 5151,5156 **** --- 5151,5177 ---- sprintf (name, "__tmp_type_%s", ts->u.derived->name); gfc_get_sym_tree (name, gfc_current_ns, &tmp, false); gfc_add_type (tmp->n.sym, ts, NULL); + + /* Copy across the array spec to the selector, taking care as to + whether or not it is a class object or not. */ + if (select_type_stack->selector->ts.type == BT_CLASS && + CLASS_DATA (select_type_stack->selector)->attr.dimension) + { + if (ts->type == BT_CLASS) + { + CLASS_DATA (tmp->n.sym)->attr.dimension = 1; + CLASS_DATA (tmp->n.sym)->as = gfc_get_array_spec (); + CLASS_DATA (tmp->n.sym)->as + = CLASS_DATA (select_type_stack->selector)->as; + } + else + { + tmp->n.sym->attr.dimension = 1; + tmp->n.sym->as = gfc_get_array_spec (); + tmp->n.sym->as = CLASS_DATA (select_type_stack->selector)->as; + } + } + gfc_set_sym_referenced (tmp->n.sym); gfc_add_flavor (&tmp->n.sym->attr, FL_VARIABLE, name, NULL); tmp->n.sym->attr.select_type_temporary = 1; *************** gfc_match_select_type (void) *** 5176,5181 **** --- 5197,5203 ---- gfc_expr *expr1, *expr2 = NULL; match m; char name[GFC_MAX_SYMBOL_LEN]; + bool class_array; m = gfc_match_label (); if (m == MATCH_ERROR) *************** gfc_match_select_type (void) *** 5216,5223 **** if (m != MATCH_YES) goto cleanup; /* Check for F03:C811. */ ! if (!expr2 && (expr1->expr_type != EXPR_VARIABLE || expr1->ref != NULL)) { gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " "use associate-name=>"); --- 5238,5261 ---- if (m != MATCH_YES) goto cleanup; + /* This ghastly expression seems to be needed to distinguish a CLASS + array, which can have a reference, from other expressions that + have references, such as derived type components, and are not + allowed by the standard. + TODO; see is it is sufficent to exclude component and substring + references. */ + class_array = expr1->expr_type == EXPR_VARIABLE + && expr1->ts.type != BT_UNKNOWN + && CLASS_DATA (expr1) + && (strcmp (CLASS_DATA (expr1)->name, "_data") == 0) + && CLASS_DATA (expr1)->attr.dimension + && expr1->ref + && expr1->ref->type == REF_ARRAY + && expr1->ref->next == NULL; + /* Check for F03:C811. */ ! if (!expr2 && (expr1->expr_type != EXPR_VARIABLE ! || (!class_array && expr1->ref != NULL))) { gfc_error ("Selector in SELECT TYPE at %C is not a named variable; " "use associate-name=>"); Index: gcc/fortran/check.c =================================================================== *** gcc/fortran/check.c (revision 182187) --- gcc/fortran/check.c (working copy) *************** logical_array_check (gfc_expr *array, in *** 240,245 **** --- 240,253 ---- static gfc_try array_check (gfc_expr *e, int n) { + if (e->ts.type == BT_CLASS + && CLASS_DATA (e)->attr.dimension + && CLASS_DATA (e)->as->rank) + { + gfc_add_class_array_ref (e); + return SUCCESS; + } + if (e->rank != 0) return SUCCESS; *************** dim_corank_check (gfc_expr *dim, gfc_exp *** 554,559 **** --- 562,570 ---- if (dim->expr_type != EXPR_CONSTANT) return SUCCESS; + + if (array->ts.type == BT_CLASS) + return SUCCESS; corank = gfc_get_corank (array); *************** dim_rank_check (gfc_expr *dim, gfc_expr *** 587,592 **** --- 598,606 ---- if (dim->expr_type != EXPR_CONSTANT) return SUCCESS; + if (array->ts.type == BT_CLASS) + return SUCCESS; + if (array->expr_type == EXPR_FUNCTION && array->value.function.isym && array->value.function.isym->id == GFC_ISYM_SPREAD) rank = array->rank + 1; Index: gcc/fortran/primary.c =================================================================== *** gcc/fortran/primary.c (revision 182187) --- gcc/fortran/primary.c (working copy) *************** gfc_match_varspec (gfc_expr *primary, in *** 1789,1801 **** if (gfc_peek_ascii_char () == '[') { ! if (sym->attr.dimension) { gfc_error ("Array section designator, e.g. '(:)', is required " "besides the coarray designator '[...]' at %C"); return MATCH_ERROR; } ! if (!sym->attr.codimension) { gfc_error ("Coarray designator at %C but '%s' is not a coarray", sym->name); --- 1789,1805 ---- if (gfc_peek_ascii_char () == '[') { ! if ((sym->ts.type != BT_CLASS && sym->attr.dimension) ! || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) ! && CLASS_DATA (sym)->attr.dimension)) { gfc_error ("Array section designator, e.g. '(:)', is required " "besides the coarray designator '[...]' at %C"); return MATCH_ERROR; } ! if ((sym->ts.type != BT_CLASS && !sym->attr.codimension) ! || (sym->ts.type == BT_CLASS && CLASS_DATA (sym) ! && !CLASS_DATA (sym)->attr.codimension)) { gfc_error ("Coarray designator at %C but '%s' is not a coarray", sym->name); *************** gfc_match_varspec (gfc_expr *primary, in *** 1827,1833 **** m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as, equiv_flag, ! sym->ts.type == BT_CLASS ? (CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0) : (sym->as ? sym->as->corank : 0)); --- 1831,1837 ---- m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as, equiv_flag, ! sym->ts.type == BT_CLASS && CLASS_DATA (sym) ? (CLASS_DATA (sym)->as ? CLASS_DATA (sym)->as->corank : 0) : (sym->as ? sym->as->corank : 0)); *************** gfc_match_rvalue (gfc_expr **result) *** 2909,2914 **** --- 2913,2934 ---- break; } + if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) + { + if (gfc_add_flavor (&sym->attr, FL_VARIABLE, + sym->name, NULL) == FAILURE) + { + m = MATCH_ERROR; + break; + } + + e = gfc_get_expr (); + e->symtree = symtree; + e->expr_type = EXPR_VARIABLE; + m = gfc_match_varspec (e, 0, false, true); + break; + } + /* Name is not an array, so we peek to see if a '(' implies a function call or a substring reference. Otherwise the variable is just a scalar. */ Index: gcc/fortran/trans-intrinsic.c =================================================================== *** gcc/fortran/trans-intrinsic.c (revision 182187) --- gcc/fortran/trans-intrinsic.c (working copy) *************** gfc_conv_intrinsic_size (gfc_se * se, gf *** 5028,5033 **** --- 5028,5036 ---- gfc_init_se (&argse, NULL); actual = expr->value.function.actual; + if (actual->expr->ts.type == BT_CLASS) + gfc_add_class_array_ref (actual->expr); + ss = gfc_walk_expr (actual->expr); gcc_assert (ss != gfc_ss_terminator); argse.want_pointer = 1; *************** gfc_conv_allocated (gfc_se *se, gfc_expr *** 5667,5680 **** gfc_init_se (&arg1se, NULL); arg1 = expr->value.function.actual; ss1 = gfc_walk_expr (arg1->expr); if (ss1 == gfc_ss_terminator) { /* Allocatable scalar. */ arg1se.want_pointer = 1; - if (arg1->expr->ts.type == BT_CLASS) - gfc_add_data_component (arg1->expr); gfc_conv_expr (&arg1se, arg1->expr); tmp = arg1se.expr; } --- 5670,5693 ---- gfc_init_se (&arg1se, NULL); arg1 = expr->value.function.actual; + + if (arg1->expr->ts.type == BT_CLASS) + { + /* Make sure that class array expressions have both a _data + component reference and an array reference.... */ + if (CLASS_DATA (arg1->expr)->attr.dimension) + gfc_add_class_array_ref (arg1->expr); + /* .... whilst scalars only need the _data component. */ + else + gfc_add_data_component (arg1->expr); + } + ss1 = gfc_walk_expr (arg1->expr); if (ss1 == gfc_ss_terminator) { /* Allocatable scalar. */ arg1se.want_pointer = 1; gfc_conv_expr (&arg1se, arg1->expr); tmp = arg1se.expr; } *************** gfc_add_intrinsic_ss_code (gfc_loopinfo *** 6998,7003 **** --- 7011,7019 ---- static gfc_ss * gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) { + if (expr->value.function.actual->expr->ts.type == BT_CLASS) + gfc_add_class_array_ref (expr->value.function.actual->expr); + /* The two argument version returns a scalar. */ if (expr->value.function.actual->next->expr) return ss; Index: gcc/fortran/simplify.c =================================================================== *** gcc/fortran/simplify.c (revision 182187) --- gcc/fortran/simplify.c (working copy) *************** simplify_bound (gfc_expr *array, gfc_exp *** 3326,3331 **** --- 3326,3334 ---- gfc_array_spec *as; int d; + if (array->ts.type == BT_CLASS) + return NULL; + if (array->expr_type != EXPR_VARIABLE) { as = NULL; *************** simplify_cobound (gfc_expr *array, gfc_e *** 3462,3468 **** return NULL; /* Follow any component references. */ ! as = array->symtree->n.sym->as; for (ref = array->ref; ref; ref = ref->next) { switch (ref->type) --- 3465,3473 ---- return NULL; /* Follow any component references. */ ! as = (array->ts.type == BT_CLASS && array->ts.u.derived->components) ! ? array->ts.u.derived->components->as ! : array->symtree->n.sym->as; for (ref = array->ref; ref; ref = ref->next) { switch (ref->type) *************** simplify_cobound (gfc_expr *array, gfc_e *** 3506,3516 **** } } ! gcc_unreachable (); done: ! if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE) return NULL; if (dim == NULL) --- 3511,3522 ---- } } ! if (!as) ! gcc_unreachable (); done: ! if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE) return NULL; if (dim == NULL) *************** simplify_cobound (gfc_expr *array, gfc_e *** 3523,3529 **** /* Simplify the cobounds for each dimension. */ for (d = 0; d < as->corank; d++) { ! bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank, upper, as, ref, true); if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) { --- 3529,3535 ---- /* Simplify the cobounds for each dimension. */ for (d = 0; d < as->corank; d++) { ! bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank, upper, as, ref, true); if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr) { *************** simplify_cobound (gfc_expr *array, gfc_e *** 3575,3581 **** return &gfc_bad_expr; } ! return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true); } } --- 3581,3587 ---- return &gfc_bad_expr; } ! return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true); } } Index: gcc/testsuite/gfortran.dg/class_array_5.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_5.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_array_5.f03 (revision 0) *************** *** 0 **** --- 1,25 ---- + ! { dg-do compile } + ! PR44568 - class array impelementation. + ! + ! Contributed by Hans-Werner Boschmann + ! + module ice6 + + type::a_type + contains + procedure::do_something + end type a_type + + contains + + subroutine do_something(this) + class(a_type),intent(in)::this + end subroutine do_something + + subroutine do_something_else() + class(a_type),dimension(:),allocatable::values + call values(1)%do_something() + end subroutine do_something_else + + end module ice6 + ! { dg-final { cleanup-modules "ice6" } } Index: gcc/testsuite/gfortran.dg/coarray_poly_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/coarray_poly_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/coarray_poly_1.f90 (revision 0) *************** *** 0 **** --- 1,13 ---- + ! { dg-do compile } + ! { dg-options "-fcoarray=single" } + ! + ! Test for polymorphic coarrays + ! + subroutine s2() + type t + end type t + class(t) :: A(:)[4,2:*] ! { dg-error "is not ALLOCATABLE, SAVE nor a dummy argument" } + print *, ucobound(a) + allocate(a) ! { dg-error "must be ALLOCATABLE or a POINTER" } + end + Index: gcc/testsuite/gfortran.dg/class_array_7.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_7.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_array_7.f03 (revision 0) *************** *** 0 **** --- 1,59 ---- + ! { dg-do run } + ! PR46990 - class array implementation + ! + ! Contributed by Wolfgang Kilian on comp.lang.fortran - see comment #7 of PR + ! + module realloc + implicit none + + type :: base_type + integer :: i + contains + procedure :: assign + generic :: assignment(=) => assign ! define generic assignment + end type base_type + + type, extends(base_type) :: extended_type + integer :: j + end type extended_type + + contains + + elemental subroutine assign (a, b) + class(base_type), intent(out) :: a + type(base_type), intent(in) :: b + a%i = b%i + end subroutine assign + + subroutine reallocate (a) + class(base_type), dimension(:), allocatable, intent(inout) :: a + class(base_type), dimension(:), allocatable :: tmp + allocate (tmp (2 * size (a))) ! how to alloc b with same type as a ? + if (trim (print_type ("tmp", tmp)) .ne. "tmp is base_type") call abort + tmp(:size(a)) = a ! polymorphic l.h.s. + call move_alloc (from=tmp, to=a) + end subroutine reallocate + + character(20) function print_type (name, a) + character(*), intent(in) :: name + class(base_type), dimension(:), intent(in) :: a + select type (a) + type is (base_type); print_type = NAME // " is base_type" + type is (extended_type); print_type = NAME // " is extended_type" + end select + end function + + end module realloc + + program main + use realloc + implicit none + class(base_type), dimension(:), allocatable :: a + + allocate (extended_type :: a(10)) + if (trim (print_type ("a", a)) .ne. "a is extended_type") call abort + call reallocate (a) + if (trim (print_type ("a", a)) .ne. "a is base_type") call abort + end program main + + ! { dg-final { cleanup-modules "realloc" } } Index: gcc/testsuite/gfortran.dg/class_to_type_1.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_to_type_1.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_to_type_1.f03 (revision 0) *************** *** 0 **** --- 1,97 ---- + ! { dg-do run } + ! + ! Passing CLASS to TYPE + ! + implicit none + type t + integer :: A + real, allocatable :: B(:) + end type t + + type, extends(t) :: t2 + complex :: z = cmplx(3.3, 4.4) + end type t2 + integer :: i + class(t), allocatable :: x(:) + + allocate(t2 :: x(10)) + select type(x) + type is(t2) + if (size (x) /= 10) call abort () + x = [(t2(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)] + do i = 1, 10 + if (x(i)%a /= -i .or. size (x(i)%b) /= 4 & + .or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then + call abort() + end if + if (x(i)%z /= cmplx(3.3, 4.4)) call abort() + end do + class default + call abort() + end select + + call base(x) + call baseExplicit(x, size(x)) + call class(x) + call classExplicit(x, size(x)) + contains + subroutine base(y) + type(t) :: y(:) + if (size (y) /= 10) call abort () + do i = 1, 10 + if (y(i)%a /= -i .or. size (y(i)%b) /= 4 & + .or. any (y(i)%b /= [1*i,2*i,3*i,4*i])) then + call abort() + end if + end do + end subroutine base + subroutine baseExplicit(v, n) + integer, intent(in) :: n + type(t) :: v(n) + if (size (v) /= 10) call abort () + do i = 1, 10 + if (v(i)%a /= -i .or. size (v(i)%b) /= 4 & + .or. any (v(i)%b /= [1*i,2*i,3*i,4*i])) then + call abort() + end if + end do + end subroutine baseExplicit + subroutine class(z) + class(t), intent(in) :: z(:) + select type(z) + type is(t2) + if (size (z) /= 10) call abort () + do i = 1, 10 + if (z(i)%a /= -i .or. size (z(i)%b) /= 4 & + .or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then + call abort() + end if + if (z(i)%z /= cmplx(3.3, 4.4)) call abort() + end do + class default + call abort() + end select + call base(z) + call baseExplicit(z, size(z)) + end subroutine class + subroutine classExplicit(u, n) + integer, intent(in) :: n + class(t), intent(in) :: u(n) + select type(u) + type is(t2) + if (size (u) /= 10) call abort () + do i = 1, 10 + if (u(i)%a /= -i .or. size (u(i)%b) /= 4 & + .or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then + call abort() + end if + if (u(i)%z /= cmplx(3.3, 4.4)) call abort() + end do + class default + call abort() + end select + call base(u) + call baseExplicit(u, n) + end subroutine classExplicit + end + Index: gcc/testsuite/gfortran.dg/class_array_2.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_2.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_array_2.f03 (revision 0) *************** *** 0 **** --- 1,78 ---- + ! { dg-do run } + ! + ! Test functionality of pointer class arrays: + ! ALLOCATE with source, ASSOCIATED, DEALLOCATE, passing as arguments for + ! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER. + ! + type :: type1 + integer :: i + end type + type, extends(type1) :: type2 + real :: r + end type + class(type1), pointer, dimension (:) :: x + + allocate(x(2), source = type2(42,42.0)) + call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)]) + call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)]) + if (associated (x)) deallocate (x) + + allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)]) + call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)]) + call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)]) + + if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) call abort + + if (associated (x)) deallocate (x) + + allocate(x(1:4), source = type1(42)) + call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)]) + call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)]) + if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) call abort + + if (associated (x)) deallocate (x) + + contains + subroutine display(x, lower, upper, t1, t2) + class(type1), pointer, dimension (:) :: x + integer, dimension (:) :: lower, upper + type(type1), optional, dimension(:) :: t1 + type(type2), optional, dimension(:) :: t2 + select type (x) + type is (type1) + if (present (t1)) then + if (any (x%i .ne. t1%i)) call abort + else + call abort + end if + x(2)%i = 99 + type is (type2) + if (present (t2)) then + if (any (x%i .ne. t2%i)) call abort + if (any (x%r .ne. t2%r)) call abort + else + call abort + end if + x%i = 111 + x%r = 99.0 + end select + call bounds (x, lower, upper) + end subroutine + subroutine bounds (x, lower, upper) + class(type1), pointer, dimension (:) :: x + integer, dimension (:) :: lower, upper + if (any (lower .ne. lbound (x))) call abort + if (any (upper .ne. ubound (x))) call abort + end subroutine + elemental function disp(y) result(ans) + class(type1), intent(in) :: y + real :: ans + select type (y) + type is (type1) + ans = 0.0 + type is (type2) + ans = y%r + end select + end function + end + Index: gcc/testsuite/gfortran.dg/class_array_4.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_4.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_array_4.f03 (revision 0) *************** *** 0 **** --- 1,26 ---- + ! { dg-do run } + ! PR43214 - implementation of class arrays + ! + ! Contributed by Tobias Burnus + ! + module m + type t + real :: r = 99 + contains + procedure, pass :: foo => foo + end type t + contains + elemental subroutine foo(x, i) + class(t),intent(in) :: x + integer,intent(inout) :: i + i = x%r + i + end subroutine foo + end module m + + use m + type(t) :: x(3) + integer :: n(3) = [0,100,200] + call x(:)%foo(n) + if (any(n .ne. [99,199,299])) call abort + end + ! { dg-final { cleanup-modules "m" } } Index: gcc/testsuite/gfortran.dg/class_array_6.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_6.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_array_6.f03 (revision 0) *************** *** 0 **** --- 1,33 ---- + ! { dg-do compile } + ! PR46356 - class arrays + ! + ! Contributed by Ian Harvey + ! + MODULE procedure_intent_nonsense + IMPLICIT NONE + PRIVATE + TYPE, PUBLIC :: Parent + INTEGER :: comp + END TYPE Parent + + TYPE :: ParentVector + INTEGER :: a + ! CLASS(Parent), ALLOCATABLE :: a + END TYPE ParentVector + CONTAINS + SUBROUTINE vector_operation(pvec) + CLASS(ParentVector), INTENT(INOUT) :: pvec(:) + INTEGER :: i + !--- + DO i = 1, SIZE(pvec) + CALL item_operation(pvec(i)) + END DO + ! PRINT *, pvec(1)%a%comp + END SUBROUTINE vector_operation + + SUBROUTINE item_operation(pvec) + CLASS(ParentVector), INTENT(INOUT) :: pvec + !TYPE(ParentVector), INTENT(INOUT) :: pvec + END SUBROUTINE item_operation + END MODULE procedure_intent_nonsense + ! { dg-final { cleanup-modules "procedure_intent_nonsense" } } Index: gcc/testsuite/gfortran.dg/coarray_poly_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/coarray_poly_2.f90 (revision 0) --- gcc/testsuite/gfortran.dg/coarray_poly_2.f90 (revision 0) *************** *** 0 **** --- 1,13 ---- + ! { dg-do compile } + ! { dg-options "-fcoarray=single" } + ! + type t + end type t + type(t) :: a[*] + call test(a) ! { dg-error "Rank mismatch in argument 'x' at .1. .rank-1 and scalar." } + contains + subroutine test(x) + class(t) :: x(:)[*] + print *, ucobound(x) + end + end Index: gcc/testsuite/gfortran.dg/class_array_8.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_8.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_array_8.f03 (revision 0) *************** *** 0 **** --- 1,18 ---- + ! { dg-do run } + ! PR43969 - class array implementation + ! + ! Contributed by Janus Weil + ! + implicit none + + type indx_map + end type + + type desc_type + class(indx_map), allocatable :: indxmap(:) + end type + + type(desc_type) :: desc + if (allocated(desc%indxmap)) call abort() + + end Index: gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 (revision 182187) --- gcc/testsuite/gfortran.dg/auto_dealloc_2.f90 (working copy) *************** contains *** 25,29 **** end program ! ! { dg-final { scan-tree-dump-times "__builtin_free" 2 "original" } } ! { dg-final { cleanup-tree-dump "original" } } --- 25,29 ---- end program ! ! { dg-final { scan-tree-dump-times "__builtin_free" 3 "original" } } ! { dg-final { cleanup-tree-dump "original" } } Index: gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 =================================================================== *** gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 (revision 0) --- gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 (revision 0) *************** *** 0 **** --- 1,43 ---- + ! { dg-do run } + ! + ! Test for polymorphic coarrays + ! + type t + end type t + class(t), allocatable :: A(:)[:,:] + allocate (A(2)[1:4,-5:*]) + if (any (lcobound(A) /= [1, -5])) call abort () + if (num_images() == 1) then + if (any (ucobound(A) /= [4, -5])) call abort () + else + if (ucobound(A,dim=1) /= 4) call abort () + end if + if (allocated(A)) i = 5 + call s(A) + !call t(A) ! FIXME + + contains + + subroutine s(x) + class(t),allocatable :: x(:)[:,:] + if (any (lcobound(x) /= [1, -5])) call abort () + if (num_images() == 1) then + if (any (ucobound(x) /= [4, -5])) call abort () + ! FIXME: Tree-walking issue? + ! else + ! if (ucobound(x,dim=1) /= 4) call abort () + end if + end subroutine s + + ! FIXME + !subroutine st(x) + ! class(t),allocatable :: x(:)[:,:] + ! if (any (lcobound(x) /= [1, 2])) call abort () + ! if (num_images() == 1) then + ! if (any (ucobound(x) /= [4, 2])) call abort () + ! else + ! if (ucobound(x,dim=1) /= 4) call abort () + ! end if + !end subroutine st + end + Index: gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 =================================================================== *** gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 (revision 0) --- gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 (revision 0) *************** *** 0 **** --- 1,40 ---- + ! { dg-do run } + ! + ! Test for polymorphic coarrays + ! + type t + end type t + class(t), allocatable :: A[:,:] + allocate (A[1:4,-5:*]) + if (allocated(A)) stop + if (any (lcobound(A) /= [1, -5])) call abort () + if (num_images() == 1) then + if (any (ucobound(A) /= [4, -5])) call abort () + ! FIXME: Tree walk issue + !else + ! if (ucobound(A,dim=1) /= 4) call abort () + end if + if (allocated(A)) i = 5 + call s(A) + call st(A) + contains + subroutine s(x) + class(t) :: x[4,2:*] + if (any (lcobound(x) /= [1, 2])) call abort () + if (num_images() == 1) then + if (any (ucobound(x) /= [4, 2])) call abort () + else + if (ucobound(x,dim=1) /= 4) call abort () + end if + end subroutine s + subroutine st(x) + class(t) :: x[:,:] + if (any (lcobound(x) /= [1, -5])) call abort () + if (num_images() == 1) then + if (any (ucobound(x) /= [4, -5])) call abort () + else + if (ucobound(x,dim=1) /= 4) call abort () + end if + end subroutine st + end + Index: gcc/testsuite/gfortran.dg/type_to_class_1.f03 =================================================================== *** gcc/testsuite/gfortran.dg/type_to_class_1.f03 (revision 0) --- gcc/testsuite/gfortran.dg/type_to_class_1.f03 (revision 0) *************** *** 0 **** --- 1,65 ---- + ! { dg-do run } + ! + ! Passing TYPE to CLASS + ! + implicit none + type t + integer :: A + real, allocatable :: B(:) + end type t + + type(t), allocatable :: x(:) + type(t) :: y(10) + integer :: i + + allocate(x(10)) + if (size (x) /= 10) call abort () + x = [(t(a=-i, B=[1*i,2*i,3*i,4*i]), i = 1, 10)] + do i = 1, 10 + if (x(i)%a /= -i .or. size (x(i)%b) /= 4 & + .or. any (x(i)%b /= [1*i,2*i,3*i,4*i])) then + call abort() + end if + end do + + y = x ! TODO: Segfaults in runtime without 'y' being set + + call class(x) + call classExplicit(x, size(x)) + call class(y) + call classExplicit(y, size(y)) + + contains + subroutine class(z) + class(t), intent(in) :: z(:) + select type(z) + type is(t) + if (size (z) /= 10) call abort () + do i = 1, 10 + if (z(i)%a /= -i .or. size (z(i)%b) /= 4 & + .or. any (z(i)%b /= [1*i,2*i,3*i,4*i])) then + call abort() + end if + end do + class default + call abort() + end select + end subroutine class + subroutine classExplicit(u, n) + integer, intent(in) :: n + class(t), intent(in) :: u(n) + select type(u) + type is(t) + if (size (u) /= 10) call abort () + do i = 1, 10 + if (u(i)%a /= -i .or. size (u(i)%b) /= 4 & + .or. any (u(i)%b /= [1*i,2*i,3*i,4*i])) then + call abort() + end if + end do + class default + call abort() + end select + end subroutine classExplicit + end + Index: gcc/testsuite/gfortran.dg/typebound_assignment_3.f03 =================================================================== *** gcc/testsuite/gfortran.dg/typebound_assignment_3.f03 (revision 182187) --- gcc/testsuite/gfortran.dg/typebound_assignment_3.f03 (working copy) *************** end module *** 24,30 **** use foo type (bar) :: foobar(2) ! foobar = bar() ! { dg-error "currently not implemented" } end ! { dg-final { cleanup-modules "foo" } } --- 24,30 ---- use foo type (bar) :: foobar(2) ! foobar = bar() ! There was a not-implemented error here end ! { dg-final { cleanup-modules "foo" } } Index: gcc/testsuite/gfortran.dg/class_array_1.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_1.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_array_1.f03 (revision 0) *************** *** 0 **** --- 1,76 ---- + ! { dg-do run } + ! + ! Test functionality of allocatable class arrays: + ! ALLOCATE with source, ALLOCATED, DEALLOCATE, passing as arguments for + ! ELEMENTAL and non-ELEMENTAL procedures, SELECT TYPE and LOWER/UPPER. + ! + type :: type1 + integer :: i + end type + type, extends(type1) :: type2 + real :: r + end type + class(type1), allocatable, dimension (:) :: x + + allocate(x(2), source = type2(42,42.0)) + call display(x, [1], [2], t2 = [type2(42,42.0),type2(42,42.0)]) + call display(x, [1], [2], t2 = [type2(111,99.0),type2(111,99.0)]) + if (allocated (x)) deallocate (x) + + allocate(x(1:4), source = [(type2(i,42.0 + float (i)), i = 1, 4)]) + call display(x, [1], [4], t2 = [(type2(i,42.0 + float (i)), i = 1, 4)]) + call display(x, [1], [4], t2 = [(type2(111,99.0), i = 1, 4)]) + + if (any (disp (x) .ne. [99.0,99.0,99.0,99.0])) call abort + + if (allocated (x)) deallocate (x) + + allocate(x(1:4), source = type1(42)) + call display(x, [1], [4], t1 = [(type1(42), i = 1, 4)]) + call display(x, [1], [4], t1 = [type1(42),type1(99),type1(42),type1(42)]) + if (any (disp (x) .ne. [0.0,0.0,0.0,0.0])) call abort + + contains + subroutine display(x, lower, upper, t1, t2) + class(type1), allocatable, dimension (:) :: x + integer, dimension (:) :: lower, upper + type(type1), optional, dimension(:) :: t1 + type(type2), optional, dimension(:) :: t2 + select type (x) + type is (type1) + if (present (t1)) then + if (any (x%i .ne. t1%i)) call abort + else + call abort + end if + x(2)%i = 99 + type is (type2) + if (present (t2)) then + if (any (x%i .ne. t2%i)) call abort + if (any (x%r .ne. t2%r)) call abort + else + call abort + end if + x%i = 111 + x%r = 99.0 + end select + call bounds (x, lower, upper) + end subroutine + subroutine bounds (x, lower, upper) + class(type1), allocatable, dimension (:) :: x + integer, dimension (:) :: lower, upper + if (any (lower .ne. lbound (x))) call abort + if (any (upper .ne. ubound (x))) call abort + end subroutine + elemental function disp(y) result(ans) + class(type1), intent(in) :: y + real :: ans + select type (y) + type is (type1) + ans = 0.0 + type is (type2) + ans = y%r + end select + end function + end + Index: gcc/testsuite/gfortran.dg/class_19.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_19.f03 (revision 182187) --- gcc/testsuite/gfortran.dg/class_19.f03 (working copy) *************** program main *** 39,45 **** end program main ! ! { dg-final { scan-tree-dump-times "__builtin_free" 8 "original" } } ! { dg-final { cleanup-tree-dump "original" } } ! { dg-final { cleanup-modules "foo_mod" } } --- 39,45 ---- end program main ! ! { dg-final { scan-tree-dump-times "__builtin_free" 11 "original" } } ! { dg-final { cleanup-tree-dump "original" } } ! { dg-final { cleanup-modules "foo_mod" } } Index: gcc/testsuite/gfortran.dg/class_array_3.f03 =================================================================== *** gcc/testsuite/gfortran.dg/class_array_3.f03 (revision 0) --- gcc/testsuite/gfortran.dg/class_array_3.f03 (revision 0) *************** *** 0 **** --- 1,143 ---- + ! { dg-do run } + ! + ! class based quick sort program - starting point comment #0 of pr41539 + ! + ! Note assignment with vector index reference fails because temporary + ! allocation does not occur - also false dependency detected. Nullification + ! of temp descriptor data causes a segfault. + ! + module m_qsort + implicit none + type, abstract :: sort_t + contains + procedure(disp), deferred :: disp + procedure(lt_cmp), deferred :: lt_cmp + procedure(assign), deferred :: assign + generic :: operator(<) => lt_cmp + generic :: assignment(=) => assign + end type sort_t + interface + elemental integer function disp(a) + import + class(sort_t), intent(in) :: a + end function disp + end interface + interface + impure elemental logical function lt_cmp(a,b) + import + class(sort_t), intent(in) :: a, b + end function lt_cmp + end interface + interface + elemental subroutine assign(a,b) + import + class(sort_t), intent(out) :: a + class(sort_t), intent(in) :: b + end subroutine assign + end interface + contains + + subroutine qsort(a) + class(sort_t), intent(inout),allocatable :: a(:) + class(sort_t), allocatable :: tmp (:) + integer, allocatable :: index_array (:) + integer :: i + allocate (tmp(size (a, 1)), source = a) + index_array = [(i, i = 1, size (a, 1))] + call internal_qsort (tmp, index_array) ! Do not move class elements around until end + do i = 1, size (a, 1) ! Since they can be of arbitrary size. + a(i) = tmp(index_array(i)) ! Vector index array would be neater + end do + ! a = tmp(index_array) ! Like this - TODO: fixme + end subroutine qsort + + recursive subroutine internal_qsort (x, iarray) + class(sort_t), intent(inout),allocatable :: x(:) + class(sort_t), allocatable :: ptr + integer, allocatable :: iarray(:), above(:), below(:), itmp(:) + integer :: pivot, nelem, i, iptr + if (.not.allocated (iarray)) return + nelem = size (iarray, 1) + if (nelem .le. 1) return + pivot = nelem / 2 + allocate (ptr, source = x(iarray(pivot))) ! Pointer to the pivot element + do i = 1, nelem + iptr = iarray(i) ! Index for i'th element + if (ptr%lt_cmp (x(iptr))) then ! Compare pivot with i'th element + itmp = [iptr] + above = concat (itmp, above) ! Invert order to prevent infinite loops + else + itmp = [iptr] + below = concat (itmp, below) ! -ditto- + end if + end do + call internal_qsort (x, above) ! Recursive sort of 'above' and 'below' + call internal_qsort (x, below) + iarray = concat (below, above) ! Concatenate the result + end subroutine internal_qsort + + function concat (ia, ib) result (ic) + integer, allocatable, dimension(:) :: ia, ib, ic + if (allocated (ia) .and. allocated (ib)) then + ic = [ia, ib] + else if (allocated (ia)) then + ic = ia + else if (allocated (ib)) then + ic = ib + end if + end function concat + end module m_qsort + + module test + use m_qsort + implicit none + type, extends(sort_t) :: sort_int_t + integer :: i + contains + procedure :: disp => disp_int + procedure :: lt_cmp => lt_cmp_int + procedure :: assign => assign_int + end type + contains + elemental integer function disp_int(a) + class(sort_int_t), intent(in) :: a + disp_int = a%i + end function disp_int + elemental subroutine assign_int (a, b) + class(sort_int_t), intent(out) :: a + class(sort_t), intent(in) :: b ! TODO: gfortran does not throw 'class(sort_int_t)' + select type (b) + class is (sort_int_t) + a%i = b%i + class default + a%i = -1 + end select + end subroutine assign_int + impure elemental logical function lt_cmp_int(a,b) result(cmp) + class(sort_int_t), intent(in) :: a + class(sort_t), intent(in) :: b + select type(b) + type is(sort_int_t) + if (a%i < b%i) then + cmp = .true. + else + cmp = .false. + end if + class default + ERROR STOP "Don't compare apples with oranges" + end select + end function lt_cmp_int + end module test + + program main + use test + class(sort_t), allocatable :: A(:) + integer :: i, m(5)= [7 , 4, 5, 2, 3] + allocate (A(5), source = [(sort_int_t(m(i)), i=1,5)]) + ! print *, "Before qsort: ", (A(i)%disp(), i = 1, size(a,1)) + call qsort(A) + ! print *, "After qsort: ", (A(i)%disp(), i = 1, size(a,1)) + if (any ([(A(i)%disp(), i = 1, size(a,1))] .ne. [2,3,4,5,7])) call abort + end program main + + ! { dg-final { cleanup-modules "m_qsort test" } }