This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |
Other format: | [Raw text] |
Hi all, here goes another patch for the fortran-dev branch. It contains an implementation for the SAME_TYPE_AS intrinsic, fixes some stuff related to initialization and makes sure that *every* derived type in a module gets a unique vindex (which was not the case before). However, these vindices are not unique yet when used across modules (that will come later). I also added two test cases for SAME_TYPE_AS. I will probably commit this tomorrow or on Monday. Until then, feedback is welcome (as always). Cheers, Janus
Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (Revision 152201) +++ gcc/fortran/intrinsic.c (Arbeitskopie) @@ -2307,6 +2307,12 @@ add_functions (void) make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95); + add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO, + BT_LOGICAL, dl, GFC_STD_F2003, + gfc_check_same_type_as, NULL, NULL, + a, BT_UNKNOWN, 0, REQUIRED, + b, BT_UNKNOWN, 0, REQUIRED); + add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale, x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 152201) +++ gcc/fortran/trans-expr.c (Arbeitskopie) @@ -3820,6 +3820,13 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp gfc_add_block_to_block (&block, &se.post); } } + else if (cm->ts.type == BT_CLASS && expr->expr_type == EXPR_NULL) + { + /* NULL initialization for CLASS components. */ + tmp = gfc_trans_structure_assign (dest, + gfc_default_initializer (&cm->ts)); + gfc_add_expr_to_block (&block, tmp); + } else if (cm->attr.dimension) { if (cm->attr.allocatable && expr->expr_type == EXPR_NULL) @@ -4015,12 +4022,26 @@ gfc_conv_structure (gfc_se * se, gfc_expr * expr, if (!c->expr || cm->attr.allocatable) continue; - val = gfc_conv_initializer (c->expr, &cm->ts, - TREE_TYPE (cm->backend_decl), cm->attr.dimension, - cm->attr.pointer || cm->attr.proc_pointer); + if (cm->ts.type == BT_CLASS) + { + val = gfc_conv_initializer (c->expr, &cm->ts, + TREE_TYPE (cm->ts.u.derived->components->backend_decl), + cm->ts.u.derived->components->attr.dimension, + cm->ts.u.derived->components->attr.pointer); - /* Append it to the constructor list. */ - CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->ts.u.derived->components->backend_decl, + val); + } + else + { + val = gfc_conv_initializer (c->expr, &cm->ts, + TREE_TYPE (cm->backend_decl), cm->attr.dimension, + cm->attr.pointer || cm->attr.proc_pointer); + + /* Append it to the constructor list. */ + CONSTRUCTOR_APPEND_ELT (v, cm->backend_decl, val); + } } se->expr = build_constructor (type, v); if (init) Index: gcc/fortran/decl.c =================================================================== --- gcc/fortran/decl.c (Revision 152201) +++ gcc/fortran/decl.c (Arbeitskopie) @@ -1077,6 +1077,8 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol c->attr.allocatable = attr->allocatable; c->attr.dimension = attr->dimension; c->as = (*as); + c->initializer = gfc_get_expr (); + c->initializer->expr_type = EXPR_NULL; /* Add component '$vindex'. */ if (gfc_add_component (fclass, "$vindex", &c) == FAILURE) @@ -1084,6 +1086,7 @@ encapsulate_class_symbol (gfc_typespec *ts, symbol c->ts.type = BT_INTEGER; c->ts.kind = 4; c->attr.access = ACCESS_PRIVATE; + c->initializer = gfc_int_expr (0); } fclass->attr.extension = 1; @@ -1322,6 +1325,7 @@ add_init_expr_to_sym (const char *name, gfc_expr * /* Check if the assignment can happen. This has to be put off until later for a derived type variable. */ if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED + && sym->ts.type != BT_CLASS && init->ts.type != BT_CLASS && gfc_check_assign_symbol (sym, init) == FAILURE) return FAILURE; @@ -6738,6 +6742,10 @@ gfc_get_type_attr_spec (symbol_attribute *attr, ch } +/* Counter for assigning a unique vindex number to each derived type. */ +static int vindex_counter = 0; + + /* Match the beginning of a derived type declaration. If a type name was the result of a function, then it is possible to have a symbol already to be known as a derived type yet have no components. */ @@ -6840,7 +6848,6 @@ gfc_match_derived_decl (void) { gfc_component *p; gfc_symtree *st; - gfc_symbol *declared_type; /* Add the extended derived type as the first component. */ gfc_add_component (sym, parent, &p); @@ -6857,16 +6864,12 @@ gfc_match_derived_decl (void) extended->f2k_derived = gfc_get_namespace (NULL, 0); st = gfc_new_symtree (&extended->f2k_derived->sym_root, sym->name); st->n.sym = sym; - - /* Increment the VINDEX of the top-level declared type and set - the VINDEX for this one. This is done so that the size of - the VTABLE entries for the top-level derived type is VINDEX. */ - declared_type = gfc_get_ultimate_derived_super_type (sym); - if (declared_type->vindex == 0) - declared_type->vindex++; - sym->vindex = declared_type->vindex++; } + if (!sym->vindex) + /* Set the vindex for this type and increment the counter. */ + sym->vindex = ++vindex_counter; + /* Take over the ABSTRACT attribute. */ sym->attr.abstract = attr.abstract; Index: gcc/fortran/intrinsic.h =================================================================== --- gcc/fortran/intrinsic.h (Revision 152201) +++ gcc/fortran/intrinsic.h (Arbeitskopie) @@ -119,6 +119,7 @@ gfc_try gfc_check_real (gfc_expr *, gfc_expr *); gfc_try gfc_check_rename (gfc_expr *, gfc_expr *); gfc_try gfc_check_repeat (gfc_expr *, gfc_expr *); gfc_try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); +gfc_try gfc_check_same_type_as (gfc_expr *, gfc_expr *); gfc_try gfc_check_scale (gfc_expr *, gfc_expr *); gfc_try gfc_check_scan (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *); gfc_try gfc_check_second_sub (gfc_expr *); Index: gcc/fortran/gfortran.h =================================================================== --- gcc/fortran/gfortran.h (Revision 152201) +++ gcc/fortran/gfortran.h (Arbeitskopie) @@ -475,6 +475,7 @@ enum gfc_isym_id GFC_ISYM_RESHAPE, GFC_ISYM_RRSPACING, GFC_ISYM_RSHIFT, + GFC_ISYM_SAME_TYPE_AS, GFC_ISYM_SC_KIND, GFC_ISYM_SCALE, GFC_ISYM_SCAN, @@ -2626,6 +2627,7 @@ int gfc_is_formal_arg (void); void gfc_resolve_substring_charlen (gfc_expr *); match gfc_iso_c_sub_interface(gfc_code *, gfc_symbol *); gfc_expr *gfc_expr_to_initialize (gfc_expr *); +bool gfc_type_is_extensible (gfc_symbol *sym); /* array.c */ Index: gcc/fortran/expr.c =================================================================== --- gcc/fortran/expr.c (Revision 152201) +++ gcc/fortran/expr.c (Arbeitskopie) @@ -3368,7 +3368,8 @@ gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr if (sym->attr.pointer || sym->attr.proc_pointer || (sym->ts.type == BT_CLASS - && sym->ts.u.derived->components->attr.pointer)) + && sym->ts.u.derived->components->attr.pointer + && rvalue->expr_type == EXPR_NULL)) r = gfc_check_pointer_assign (&lvalue, rvalue); else r = gfc_check_assign (&lvalue, rvalue, 1); Index: gcc/fortran/resolve.c =================================================================== --- gcc/fortran/resolve.c (Revision 152201) +++ gcc/fortran/resolve.c (Arbeitskopie) @@ -879,7 +879,10 @@ resolve_structure_cons (gfc_expr *expr) if (cons->expr->expr_type == EXPR_NULL && !(comp->attr.pointer || comp->attr.allocatable - || comp->attr.proc_pointer)) + || comp->attr.proc_pointer + || (comp->ts.type == BT_CLASS + && (comp->ts.u.derived->components->attr.pointer + || comp->ts.u.derived->components->attr.allocatable)))) { t = FAILURE; gfc_error ("The NULL in the derived type constructor at %L is " @@ -6404,8 +6407,8 @@ resolve_select (gfc_code *code) /* Check if a derived type is extensible. */ -static bool -type_is_extensible (gfc_symbol *sym) +bool +gfc_type_is_extensible (gfc_symbol *sym) { return !(sym->attr.is_bind_c || sym->attr.sequence); } @@ -6434,7 +6437,7 @@ resolve_select_type (gfc_code *code) /* Check F03:C815. */ if ((c->ts.type == BT_DERIVED || c->ts.type == BT_CLASS) - && !type_is_extensible (c->ts.u.derived)) + && !gfc_type_is_extensible (c->ts.u.derived)) { gfc_error ("Derived type '%s' at %L must be extensible", c->ts.u.derived->name, &c->where); @@ -7267,17 +7270,16 @@ resolve_class_assign (gfc_code *code) assign_code->expr1 = gfc_copy_expr (code->expr1); gfc_add_component_ref (assign_code->expr1, "$vindex"); if (code->expr2->ts.type == BT_DERIVED) - { - /* vindex is constant, determined at compile time. */ - int vindex = code->expr2->ts.u.derived->vindex; - assign_code->expr2 = gfc_int_expr (vindex); - } + /* vindex is constant, determined at compile time. */ + assign_code->expr2 = gfc_int_expr (code->expr2->ts.u.derived->vindex); else if (code->expr2->ts.type == BT_CLASS) { /* vindex must be determined at run time. */ assign_code->expr2 = gfc_copy_expr (code->expr2); gfc_add_component_ref (assign_code->expr2, "$vindex"); } + else if (code->expr2->expr_type == EXPR_NULL) + assign_code->expr2 = gfc_int_expr (0); else gcc_unreachable (); @@ -8279,7 +8281,7 @@ resolve_fl_variable_derived (gfc_symbol *sym, int if (sym->ts.type == BT_CLASS) { /* C502. */ - if (!type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) + if (!gfc_type_is_extensible (sym->ts.u.derived->components->ts.u.derived)) { gfc_error ("Type '%s' of CLASS variable '%s' at %L is not extensible", sym->ts.u.derived->name, sym->name, &sym->declared_at); @@ -9665,7 +9667,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; /* An ABSTRACT type must be extensible. */ - if (sym->attr.abstract && !type_is_extensible (sym)) + if (sym->attr.abstract && !gfc_type_is_extensible (sym)) { gfc_error ("Non-extensible derived-type '%s' at %L must not be ABSTRACT", sym->name, &sym->declared_at); @@ -9841,7 +9843,7 @@ resolve_fl_derived (gfc_symbol *sym) return FAILURE; } - if (type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) + if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS) gfc_error ("Non-polymorphic passed-object dummy argument of '%s'" " at %L", c->name, &c->loc); Index: gcc/fortran/check.c =================================================================== --- gcc/fortran/check.c (Revision 152201) +++ gcc/fortran/check.c (Arbeitskopie) @@ -2641,6 +2641,46 @@ gfc_check_reshape (gfc_expr *source, gfc_expr *sha gfc_try +gfc_check_same_type_as (gfc_expr *a, gfc_expr *b) +{ + + if (a->ts.type != BT_DERIVED && a->ts.type != BT_CLASS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of a derived type", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &a->where); + return FAILURE; + } + + if (!gfc_type_is_extensible (a->ts.u.derived)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of an extensible type", gfc_current_intrinsic_arg[0], + gfc_current_intrinsic, &a->where); + return FAILURE; + } + + if (b->ts.type != BT_DERIVED && b->ts.type != BT_CLASS) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of a derived type", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &b->where); + return FAILURE; + } + + if (!gfc_type_is_extensible (b->ts.u.derived)) + { + gfc_error ("'%s' argument of '%s' intrinsic at %L " + "must be of an extensible type", gfc_current_intrinsic_arg[1], + gfc_current_intrinsic, &b->where); + return FAILURE; + } + + return SUCCESS; +} + + +gfc_try gfc_check_scale (gfc_expr *x, gfc_expr *i) { if (type_check (x, 0, BT_REAL) == FAILURE) Index: gcc/fortran/primary.c =================================================================== --- gcc/fortran/primary.c (Revision 152201) +++ gcc/fortran/primary.c (Arbeitskopie) @@ -2074,7 +2074,16 @@ gfc_expr_attr (gfc_expr *e) gfc_clear_attr (&attr); if (e->value.function.esym != NULL) - attr = e->value.function.esym->result->attr; + { + gfc_symbol *sym = e->value.function.esym->result; + attr = sym->attr; + if (sym->ts.type == BT_CLASS) + { + attr.dimension = sym->ts.u.derived->components->attr.dimension; + attr.pointer = sym->ts.u.derived->components->attr.pointer; + attr.allocatable = sym->ts.u.derived->components->attr.allocatable; + } + } else attr = gfc_variable_attr (e, NULL); Index: gcc/fortran/trans-intrinsic.c =================================================================== --- gcc/fortran/trans-intrinsic.c (Revision 152201) +++ gcc/fortran/trans-intrinsic.c (Arbeitskopie) @@ -4700,6 +4700,41 @@ gfc_conv_associated (gfc_se *se, gfc_expr *expr) } +/* Generate code for the SAME_TYPE_AS intrinsic. + Generate inline code that directly checks the vindices. */ + +static void +gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr) +{ + gfc_expr *a, *b; + gfc_se se1, se2; + tree tmp; + + gfc_init_se (&se1, NULL); + gfc_init_se (&se2, NULL); + + a = expr->value.function.actual->expr; + b = expr->value.function.actual->next->expr; + + if (a->ts.type == BT_CLASS) + gfc_add_component_ref (a, "$vindex"); + else if (a->ts.type == BT_DERIVED) + a = gfc_int_expr (a->ts.u.derived->vindex); + + if (b->ts.type == BT_CLASS) + gfc_add_component_ref (b, "$vindex"); + else if (b->ts.type == BT_DERIVED) + b = gfc_int_expr (b->ts.u.derived->vindex); + + gfc_conv_expr (&se1, a); + gfc_conv_expr (&se2, b); + + tmp = fold_build2 (EQ_EXPR, boolean_type_node, + se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr)); + se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); +} + + /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */ static void @@ -5108,6 +5143,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr gfc_conv_associated(se, expr); break; + case GFC_ISYM_SAME_TYPE_AS: + gfc_conv_same_type_as (se, expr); + break; + case GFC_ISYM_ABS: gfc_conv_intrinsic_abs (se, expr); break;
Attachment:
same_type_as_1.f90
Description: Binary data
Attachment:
same_type_as_2.f90
Description: Binary data
Index Nav: | [Date Index] [Subject Index] [Author Index] [Thread Index] | |
---|---|---|
Message Nav: | [Date Prev] [Date Next] | [Thread Prev] [Thread Next] |