Index: gcc/gcc/fortran/array.c =================================================================== --- gcc.orig/gcc/fortran/array.c +++ gcc/gcc/fortran/array.c @@ -314,6 +314,9 @@ match_array_element_spec (gfc_array_spec gfc_error ("Expected expression in array specification at %C"); if (m != MATCH_YES) return AS_UNKNOWN; + /* Check whether the lower/upper bound is specified by derived type parameters. */ + if ((*upper)->expr_type == EXPR_VARIABLE) + gfc_check_dt_kind_parameter (upper); if (gfc_match_char (':') == MATCH_NO) { @@ -332,6 +335,9 @@ match_array_element_spec (gfc_array_spec return AS_UNKNOWN; if (m == MATCH_NO) return AS_ASSUMED_SHAPE; + /* Check whether the lower/upper bound is specified by derived type parameters. */ + if ((*upper)->expr_type == EXPR_VARIABLE) + gfc_check_dt_kind_parameter (upper); return AS_EXPLICIT; } Index: gcc/gcc/fortran/decl.c =================================================================== --- gcc.orig/gcc/fortran/decl.c +++ gcc/gcc/fortran/decl.c @@ -1181,6 +1181,95 @@ gfc_free_enum_history (void) enum_history = NULL; } +static gfc_expr * +get_kind_param_value (gfc_expr *e) +{ + gfc_expr *value; + + if (e && e->expr_type == EXPR_VARIABLE + && e->symtree && e->symtree->n.sym + && e->symtree->n.sym->attr.kind == 1 + && e->symtree->n.sym->value) + { + value = gfc_copy_expr (e->symtree->n.sym->value); + return value; + } + return NULL; +} + +/* Function called by variable_decl() to initialize/update derived type + components by the given parameters. */ + +static try +update_parameterized_dt_components (void) +{ + gfc_component *c; + gfc_typespec *com_ts; + gfc_array_spec *as; + gfc_expr *e, *init; + const char *msg; + + c = current_ts.derived->components; + /* The parameterized derived type contains no components. */ + if (c == NULL) + return SUCCESS; + + /* Go through all components and check their kind values. Update them + with current parameter values. If no parameters given, set them to + the initial values. */ + for(;c != NULL; c = c->next) + { + /* Update component's kind with corresponding KIND type parameter. */ + com_ts = &c->ts; + /*FIXME: kind parameter is saved in params, anywhere else better? */ + /* Component is specified by a KIND parameter. */ + if (com_ts->params) + { + e = get_kind_param_value (com_ts->params->expr); + if (e) + { + msg = gfc_extract_int (e, &com_ts->kind); + if (msg != NULL) + { + gfc_error (msg); + return FAILURE; + } + + if (gfc_validate_kind (com_ts->type, com_ts->kind, true) < 0) + { + gfc_error ("Kind %d not supported for type %s at %C", com_ts->kind, + gfc_basic_typename (com_ts->type)); + return FAILURE; + } + } + } + /* Update component's array bounds with corresponding KIND type parameter. */ + as = c->as; + if (as) + { + int i; + + for (i = 0; i < as->rank; i++) + { + e = get_kind_param_value (as->lower[i]); + if (e) + as->lower[i] = e; + e = get_kind_param_value (as->upper[i]); + if (e) + as->upper[i] = e; + } + } + + /* Update component's initializer with corresponding KIND type parameter. */ + init = get_kind_param_value (c->initializer); + if (init) + c->initializer = init; + + /* Else the component is not specified by parameter, simply ignore. */ + } + + return SUCCESS; +} /* Function called by variable_decl() that adds an initialization expression to a symbol. */ @@ -1532,6 +1621,20 @@ gfc_match_null (gfc_expr **result) return MATCH_YES; } +/* Check if parameter name is in the formal arglist of symbol. */ + +static int +found_parameter_name (gfc_symbol *sym, char *param) +{ + gfc_formal_arglist *p; + for(p = sym->formal; p != NULL; p = p->next) + { + if (!strcmp (p->sym->name, param)) + return 1; + } + return 0; +} + /* Match a variable name with an optional initializer. When this subroutine is called, a variable is expected to be parsed next. @@ -1542,6 +1645,7 @@ static match variable_decl (int elem) { char name[GFC_MAX_SYMBOL_LEN + 1]; + char dt_param_name[GFC_MAX_SYMBOL_LEN + 1]; gfc_expr *initializer, *char_len; gfc_array_spec *as; gfc_array_spec *cp_as; /* Extra copy for Cray Pointees. */ @@ -1549,8 +1653,9 @@ variable_decl (int elem) locus var_locus; match m; try t; - gfc_symbol *sym; + gfc_symbol *sym, *temp_sym; locus old_locus; + gfc_symtree *st; initializer = NULL; as = NULL; @@ -1579,6 +1684,22 @@ variable_decl (int elem) char_len = NULL; cl = NULL; + /* Check if derived type KIND parameter. */ + + if (current_attr.kind == 1 && current_ts.type == BT_INTEGER) + { + temp_sym = gfc_current_block(); + strcpy (dt_param_name, gfc_get_string ("%s.%s", temp_sym->name, name)); + if (temp_sym->formal == NULL + || !found_parameter_name (temp_sym, dt_param_name)) + { + gfc_error("Kind parameter %s at %C is not declared in the parameter list.", name); + m = MATCH_ERROR; + goto cleanup; + } + } + + if (current_ts.type == BT_CHARACTER) { switch (match_char_length (&char_len)) @@ -1801,6 +1922,12 @@ variable_decl (int elem) goto cleanup; } + /* Parameterized derived type, update components with the parameter values. */ + if (current_ts.type == BT_DERIVED) + if ( update_parameterized_dt_components () == FAILURE) + return MATCH_ERROR; + + /* Add the initializer. Note that it is fine if initializer is NULL here, because we sometimes also need to check if a declaration *must* have an initialization expression. */ @@ -1811,7 +1938,23 @@ variable_decl (int elem) if (current_ts.type == BT_DERIVED && !current_attr.pointer && !initializer) initializer = gfc_default_initializer (¤t_ts); - t = build_struct (name, cl, &initializer, &as); + /* kind parameter */ + if (current_attr.kind) + { + strcpy (dt_param_name, gfc_get_string ("%s.%s", gfc_current_block ()->name, name)); + st = gfc_find_symtree (gfc_current_ns->sym_root, dt_param_name); + if (st != NULL && st->n.sym != NULL) + { + temp_sym = st->n.sym; + temp_sym->ts = current_ts; + temp_sym->attr = current_attr; + t = add_init_expr_to_sym (dt_param_name, &initializer, &var_locus); + } + else + goto cleanup; + } + else + t = build_struct (name, cl, &initializer, &as); } m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR; @@ -1940,6 +2083,20 @@ kind_expr: goto no_match; } + /* KIND type parameter is not initialized, save the symbol in typespec. */ + /* FIXME: Where to keep parameter symbol? */ + if (e->expr_type == EXPR_VARIABLE && e->symtree + && e->symtree->n.sym->attr.kind == 1) + { + ts->params = gfc_get_actual_arglist (); + ts->params->expr = e; + ts->params->name = e->symtree->name; +/* if (e->symtree->n.sym->value) + e = gfc_copy_expr (e->symtree->n.sym->value); + else +*/ goto get_expr; + } + msg = gfc_extract_int (e, &ts->kind); if (msg != NULL) @@ -1972,6 +2129,7 @@ kind_expr: return MATCH_ERROR; } +get_expr: gfc_gobble_whitespace (); if ((c = gfc_next_ascii_char ()) != ')' && (ts->type != BT_CHARACTER || c != ',')) @@ -2233,6 +2391,33 @@ done: } +/* Compare formal and actual argument list type and replace formal argument + values by actual argument values. */ +static int +replace_formal_by_actual (gfc_formal_arglist **formal, gfc_actual_arglist **actual) +{ + gfc_formal_arglist *p1; + gfc_actual_arglist *p2; + + p1 = *formal; + p2 = *actual; + for(; p1 != NULL && p2 != NULL;) + { + /* Type parameters are of integer type. */ + if (p2->expr->expr_type == EXPR_CONSTANT + && gfc_compare_types (&p1->sym->ts, &p2->expr->ts)) + { + p1->sym->value = gfc_copy_expr(p2->expr); + p1 = p1->next; + p2 = p2->next; + } + } + if (p1 == NULL && p2 == NULL) + return 1; + + return 0; +} + /* Matches a type specification. If successful, sets the ts structure to the matched specification. This is necessary for FUNCTION and IMPLICIT statements. @@ -2247,8 +2432,9 @@ gfc_match_type_spec (gfc_typespec *ts, i char name[GFC_MAX_SYMBOL_LEN + 1]; gfc_symbol *sym; match m; - char c; - bool seen_deferred_kind; + char c, parameter_matched; + bool seen_deferred_kind, has_parameter; + gfc_actual_arglist *arglist; /* A belt and braces check that the typespec is correctly being treated as a deferred characteristic association. */ @@ -2335,9 +2521,30 @@ gfc_match_type_spec (gfc_typespec *ts, i goto get_kind; } - m = gfc_match (" type ( %n )", name); + m = gfc_match (" type ( %n", name); + if (m != MATCH_YES) return m; + else + { + /* Is this a parameterized derived type? */ + if (gfc_peek_char () == '(') + { + m = gfc_match_actual_arglist (0, &arglist); + if (m != MATCH_YES) + return m; + has_parameter = true; + } + else /* no parameters */ + { + arglist = NULL; + has_parameter = false; + } + + m = gfc_match (")"); + if (m != MATCH_YES) + return m; + } ts->type = BT_DERIVED; @@ -2381,9 +2588,18 @@ gfc_match_type_spec (gfc_typespec *ts, i && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE) return MATCH_ERROR; + /* Match actual parameter list to formal parameter list and update the value. */ + if (has_parameter) + { + if (sym->formal != NULL) + parameter_matched = replace_formal_by_actual (&sym->formal, &arglist); + if (!parameter_matched) + return MATCH_ERROR; + } + gfc_set_sym_referenced (sym); ts->derived = sym; - + ts->params = arglist; return MATCH_YES; get_kind: @@ -3992,6 +4208,10 @@ ok: goto cleanup; } + /* If parameterized derived type, add formal arglist to type symbol. */ + if (type == GFC_PARAMETERIZED_DT_FORMAL) + progname->formal = head; + return MATCH_YES; cleanup: Index: gcc/gcc/fortran/expr.c =================================================================== --- gcc.orig/gcc/fortran/expr.c +++ gcc/gcc/fortran/expr.c @@ -25,6 +25,7 @@ along with GCC; see the file COPYING3. #include "arith.h" #include "match.h" #include "target-memory.h" /* for gfc_convert_boz */ +#include "parse.h" /* For gfc_current_state() */ /* Get a new expr node. */ @@ -736,7 +737,14 @@ gfc_is_constant_expr (gfc_expr *e) break; case EXPR_VARIABLE: - rv = 0; + if (e->symtree->n.sym->attr.kind == 1) + { + /* KIND type parameter value will be resolved later at compile time, + therefore can be regard as constant. */ + rv = 1; + } + else + rv = 0; break; case EXPR_FUNCTION: @@ -2235,6 +2243,11 @@ check_init_expr (gfc_expr *e) break; } + /* A KIND type parameter may not be initialized in type definition. + The value will then be resolved later in data declaration. */ + if (e->symtree->n.sym->attr.kind == 1) + break; + if (gfc_in_match_data ()) break; @@ -2524,6 +2537,14 @@ check_restricted (gfc_expr *e) break; } + /* A KIND type parameter may not be initialized in type definition. + The value will then be resolved later in data declaration. */ + if (e->symtree->n.sym->attr.kind == 1) + { + t = SUCCESS; + break; + } + gfc_error ("Variable '%s' cannot appear in the expression at %L", sym->name, &e->where); @@ -3256,3 +3277,26 @@ gfc_expr_set_symbols_referenced (gfc_exp { gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0); } + +/* Check whether the expression is a derived type parameter. If so, replace + the symtree with the parameter's symtree. */ + +void +gfc_check_dt_kind_parameter (gfc_expr **expr) +{ + char name[GFC_MAX_SYMBOL_LEN + 1]; + gfc_symtree *st; + gfc_expr *e; + + e = *expr; + if (gfc_current_state() == COMP_DERIVED) + { + strcpy (name, gfc_get_string ("%s.%s", gfc_current_block ()->name, + e->symtree->name)); + st = gfc_find_symtree (gfc_current_ns->sym_root, name); + + /* Replace symtree with the kind type parameter symtree. */ + if (st != NULL && st->n.sym->attr.kind == 1) + e->symtree = st; + } +} Index: gcc/gcc/fortran/gfortran.h =================================================================== --- gcc.orig/gcc/fortran/gfortran.h +++ gcc/gcc/fortran/gfortran.h @@ -814,6 +814,7 @@ typedef struct bt type; int kind; struct gfc_symbol *derived; + struct gfc_actual_arglist *params; /* For derived type to keep parameter list. */ gfc_charlen *cl; /* For character types only. */ struct gfc_symbol *interface; /* For PROCEDURE declarations. */ int is_c_interop; @@ -2336,6 +2337,7 @@ bool gfc_traverse_expr (gfc_expr *, gfc_ bool (*)(gfc_expr *, gfc_symbol *, int*), int); void gfc_expr_set_symbols_referenced (gfc_expr *); +void gfc_check_dt_kind_parameter (gfc_expr **); /* st.c */ extern gfc_code new_st; Index: gcc/gcc/fortran/interface.c =================================================================== --- gcc.orig/gcc/fortran/interface.c +++ gcc/gcc/fortran/interface.c @@ -361,7 +361,7 @@ gfc_compare_derived_types (gfc_symbol *d /* Special case for comparing derived types across namespaces. If the true names and module names are the same and the module name is - nonnull, then they are equal. */ + nonnull, then they are equal. Then compare their parameters if exist. */ if (derived1 != NULL && derived2 != NULL && strcmp (derived1->name, derived2->name) == 0 && derived1->module != NULL && derived2->module != NULL @@ -434,6 +434,26 @@ gfc_compare_derived_types (gfc_symbol *d return 1; } +static int +gfc_compare_derived_type_params (gfc_actual_arglist *p1, gfc_actual_arglist *p2) +{ + gfc_expr *e1, *e2; + for (;p1 != NULL && p2 != NULL;) + { + e1 = p1->expr; + e2 = p2->expr; + /* compare two kind parameter values. */ + if (!gfc_dep_compare_expr(e1, e2)) + { + p1 = p1->next; + p2 = p2->next; + } + else return 0; + } + if (p1 == NULL && p2 == NULL) + return 1; + return 0; +} /* Compare two typespecs, recursively if necessary. */ @@ -453,10 +473,14 @@ gfc_compare_types (gfc_typespec *ts1, gf return (ts1->kind == ts2->kind); /* Compare derived types. */ - if (ts1->derived == ts2->derived) - return 1; + if (ts1->derived == ts2->derived + || gfc_compare_derived_types (ts1->derived ,ts2->derived)) + { + /* The same type may have different parameter values. */ + return gfc_compare_derived_type_params (ts1->params, ts2->params); + } - return gfc_compare_derived_types (ts1->derived ,ts2->derived); + return 0; } @@ -950,6 +974,21 @@ generic_correspondence (gfc_formal_argli } +static int +check_derived_types (gfc_formal_arglist *f1, gfc_formal_arglist *f2) +{ + for (; f1 != NULL && f2 != NULL;) + { + if (!gfc_compare_types (&f1->sym->ts, &f2->sym->ts)) + return 1; + + f1 = f1->next; + f2 = f2->next; + } + + return 0; +} + /* 'Compare' two formal interfaces associated with a pair of symbols. We return nonzero if there exists an actual argument list that would be ambiguous between the two interfaces, zero otherwise. */ @@ -987,6 +1026,9 @@ compare_interfaces (gfc_symbol *s1, gfc_ return 0; } + if(check_derived_types (f1, f2)) + return 0; + return 1; } Index: gcc/gcc/fortran/module.c =================================================================== --- gcc.orig/gcc/fortran/module.c +++ gcc/gcc/fortran/module.c @@ -1991,6 +1991,53 @@ check_unique_name (const char *name) return *name == '@'; } +static void +mio_actual_arg (gfc_actual_arglist *a) +{ + mio_lparen (); + mio_pool_string (&a->name); + mio_expr (&a->expr); + mio_rparen (); +} + + +static void +mio_actual_arglist (gfc_actual_arglist **ap) +{ + gfc_actual_arglist *a, *tail; + + mio_lparen (); + + if (iomode == IO_OUTPUT) + { + for (a = *ap; a; a = a->next) + mio_actual_arg (a); + + } + else + { + tail = NULL; + + for (;;) + { + if (peek_atom () != ATOM_LPAREN) + break; + + a = gfc_get_actual_arglist (); + + if (tail == NULL) + *ap = a; + else + tail->next = a; + + tail = a; + mio_actual_arg (a); + } + } + + mio_rparen (); +} + static void mio_typespec (gfc_typespec *ts) @@ -2002,7 +2049,10 @@ mio_typespec (gfc_typespec *ts) if (ts->type != BT_DERIVED) mio_integer (&ts->kind); else - mio_symbol_ref (&ts->derived); + { + mio_symbol_ref (&ts->derived); + mio_actual_arglist (&ts->params); + } /* Add info for C interop and is_iso_c. */ mio_integer (&ts->is_c_interop); @@ -2308,53 +2358,6 @@ mio_component_list (gfc_component **cp) } -static void -mio_actual_arg (gfc_actual_arglist *a) -{ - mio_lparen (); - mio_pool_string (&a->name); - mio_expr (&a->expr); - mio_rparen (); -} - - -static void -mio_actual_arglist (gfc_actual_arglist **ap) -{ - gfc_actual_arglist *a, *tail; - - mio_lparen (); - - if (iomode == IO_OUTPUT) - { - for (a = *ap; a; a = a->next) - mio_actual_arg (a); - - } - else - { - tail = NULL; - - for (;;) - { - if (peek_atom () != ATOM_LPAREN) - break; - - a = gfc_get_actual_arglist (); - - if (tail == NULL) - *ap = a; - else - tail->next = a; - - tail = a; - mio_actual_arg (a); - } - } - - mio_rparen (); -} - /* Read and write formal argument lists. */ @@ -3199,7 +3202,8 @@ mio_symbol (gfc_symbol *sym) while (formal && !formal->sym) formal = formal->next; - if (formal) + /* parameterized derived type has formal arglist, but is not procedure. */ + if (formal && sym->attr.flavor != FL_DERIVED) mio_namespace_ref (&formal->sym->ns); else mio_namespace_ref (&sym->formal_ns); Index: gcc/gcc/fortran/resolve.c =================================================================== --- gcc.orig/gcc/fortran/resolve.c +++ gcc/gcc/fortran/resolve.c @@ -4049,6 +4049,9 @@ resolve_variable (gfc_expr *e) if (e->ref && resolve_ref (e) == FAILURE) return FAILURE; + /* Check KIND parameters. */ + gfc_check_dt_kind_parameter (&e); + sym = e->symtree->n.sym; if (sym->attr.flavor == FL_PROCEDURE && !sym->attr.function) { Index: gcc/gcc/fortran/misc.c =================================================================== --- gcc.orig/gcc/fortran/misc.c +++ gcc/gcc/fortran/misc.c @@ -75,6 +75,7 @@ gfc_clear_ts (gfc_typespec *ts) { ts->type = BT_UNKNOWN; ts->derived = NULL; + ts->params = NULL; ts->kind = 0; ts->cl = NULL; ts->interface = NULL;