diff options
Diffstat (limited to 'gcc/fortran/match.c')
| -rw-r--r-- | gcc/fortran/match.c | 186 |
1 files changed, 132 insertions, 54 deletions
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index 39da62f..6322fae 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -588,7 +588,7 @@ gfc_match_name_C (const char **buffer) size_t i = 0; gfc_char_t c; char* buf; - size_t cursz = 16; + size_t cursz = 16; old_loc = gfc_current_locus; gfc_gobble_whitespace (); @@ -605,7 +605,7 @@ gfc_match_name_C (const char **buffer) gfc_current_locus = old_loc; return MATCH_YES; } - + if (!ISALPHA (c) && c != '_') { gfc_error ("Invalid C name in NAME= specifier at %C"); @@ -625,9 +625,9 @@ gfc_match_name_C (const char **buffer) cursz *= 2; buf = XRESIZEVEC (char, buf, cursz); } - + old_loc = gfc_current_locus; - + /* Get next char; param means we're in a string. */ c = gfc_next_char_literal (INSTRING_WARN); } while (ISALNUM (c) || c == '_'); @@ -650,7 +650,7 @@ gfc_match_name_C (const char **buffer) return MATCH_ERROR; } } - + /* If we stopped because we had an invalid character for a C name, report that to the user by returning MATCH_NO. */ if (c != '"' && c != '\'') @@ -708,8 +708,8 @@ gfc_match_symbol (gfc_symbol **matched_symbol, int host_assoc) } -/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, - we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this +/* Match an intrinsic operator. Returns an INTRINSIC enum. While matching, + we always find INTRINSIC_PLUS before INTRINSIC_UPLUS. We work around this in matchexp.c. */ match @@ -1441,7 +1441,7 @@ gfc_match_if (gfc_statement *if_type) old_loc2 = gfc_current_locus; gfc_current_locus = old_loc; - + if (gfc_match_parens () == MATCH_ERROR) return MATCH_ERROR; @@ -1473,7 +1473,7 @@ gfc_match_if (gfc_statement *if_type) gfc_free_expr (expr); return MATCH_ERROR; } - + if (gfc_notify_std (GFC_STD_F95_OBS, "Arithmetic IF " "statement at %C") == FAILURE) return MATCH_ERROR; @@ -1579,7 +1579,7 @@ gfc_match_if (gfc_statement *if_type) match ("write", gfc_match_write, ST_WRITE) /* The gfc_match_assignment() above may have returned a MATCH_NO - where the assignment was to a named constant. Check that + where the assignment was to a named constant. Check that special case here. */ m = gfc_match_assignment (); if (m == MATCH_NO) @@ -1907,7 +1907,7 @@ static match match_derived_type_spec (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN + 1]; - locus old_locus; + locus old_locus; gfc_symbol *derived; old_locus = gfc_current_locus; @@ -1930,7 +1930,7 @@ match_derived_type_spec (gfc_typespec *ts) return MATCH_YES; } - gfc_current_locus = old_locus; + gfc_current_locus = old_locus; return MATCH_NO; } @@ -2194,7 +2194,7 @@ cleanup: return MATCH_ERROR; } -/* Match the rest of a simple FORALL statement that follows an +/* Match the rest of a simple FORALL statement that follows an IF statement. */ static match @@ -2373,7 +2373,7 @@ gfc_match_do (void) return MATCH_NO; /* Check for balanced parens. */ - + if (gfc_match_parens () == MATCH_ERROR) return MATCH_ERROR; @@ -2585,7 +2585,7 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) " do-construct-name at %C") == FAILURE) return MATCH_ERROR; break; - + default: gfc_error ("%s statement at %C is not applicable to construct '%s'", gfc_ascii_statement (st), sym->name); @@ -3265,7 +3265,7 @@ gfc_match_goto (void) return MATCH_YES; } - /* The assigned GO TO statement. */ + /* The assigned GO TO statement. */ if (gfc_match_variable (&expr, 0) == MATCH_YES) { @@ -3432,6 +3432,7 @@ gfc_match_allocate (void) match m; locus old_locus, deferred_locus; bool saw_stat, saw_errmsg, saw_source, saw_mold, saw_deferred, b1, b2, b3; + bool saw_unlimited = false; head = tail = NULL; stat = errmsg = source = mold = tmp = NULL; @@ -3573,7 +3574,7 @@ gfc_match_allocate (void) } /* Enforce F03:C627. */ - if (ts.kind != tail->expr->ts.kind) + if (ts.kind != tail->expr->ts.kind && !UNLIMITED_POLY (tail->expr)) { gfc_error ("Kind type parameter for entity at %L differs from " "the kind type parameter of the typespec", @@ -3585,6 +3586,8 @@ gfc_match_allocate (void) if (tail->expr->ts.type == BT_DERIVED) tail->expr->ts.u.derived = gfc_use_derived (tail->expr->ts.u.derived); + saw_unlimited = saw_unlimited | UNLIMITED_POLY (tail->expr); + if (gfc_peek_ascii_char () == '(' && !sym->attr.dimension) { gfc_error ("Shape specification for allocatable scalar at %C"); @@ -3696,7 +3699,7 @@ alloc_opt_list: gfc_error ("Redundant MOLD tag found at %L ", &tmp->where); goto cleanup; } - + /* Check F08:C637. */ if (ts.type != BT_UNKNOWN) { @@ -3739,7 +3742,20 @@ alloc_opt_list: &deferred_locus); goto cleanup; } - + + /* Check F03:C625, */ + if (saw_unlimited && ts.type == BT_UNKNOWN && !source && !mold) + { + for (tail = head; tail; tail = tail->next) + { + if (UNLIMITED_POLY (tail->expr)) + gfc_error ("Unlimited polymorphic allocate-object at %L " + "requires either a type-spec or SOURCE tag " + "or a MOLD tag", &tail->expr->where); + } + goto cleanup; + } + new_st.op = EXEC_ALLOCATE; new_st.expr1 = stat; new_st.expr2 = errmsg; @@ -4067,7 +4083,7 @@ done: } -/* Match the call of a type-bound procedure, if CALL%var has already been +/* Match the call of a type-bound procedure, if CALL%var has already been matched and var found to be a derived-type variable. */ static match @@ -4081,7 +4097,7 @@ match_typebound_call (gfc_symtree* varst) base->symtree = varst; base->where = gfc_current_locus; gfc_set_sym_referenced (varst->n.sym); - + m = gfc_match_varspec (base, 0, true, true); if (m == MATCH_NO) gfc_error ("Expected component reference at %C"); @@ -4258,7 +4274,7 @@ cleanup: /* Given a name, return a pointer to the common head structure, creating it if it does not exist. If FROM_MODULE is nonzero, we - mangle the name so that it doesn't interfere with commons defined + mangle the name so that it doesn't interfere with commons defined in the using namespace. TODO: Add to global symbol tree. */ @@ -4403,7 +4419,7 @@ gfc_match_common (void) /* Store a ref to the common block for error checking. */ sym->common_block = t; sym->common_block->refs++; - + /* See if we know the current common block is bind(c), and if so, then see if we can check if the symbol is (which it'll need to be). This can happen if the bind(c) attr stmt was @@ -4423,13 +4439,13 @@ gfc_match_common (void) sym->name, &(sym->declared_at), t->name, t->name); } - + if (sym->attr.is_bind_c == 1) gfc_error_now ("Variable '%s' in common block " "'%s' at %C can not be bind(c) since " "it is not global", sym->name, t->name); } - + if (sym->attr.in_common) { gfc_error ("Symbol '%s' at %C is already in a COMMON block", @@ -4872,7 +4888,7 @@ cleanup: /* Check that a statement function is not recursive. This is done by looking for the statement function symbol(sym) by looking recursively through its - expression(e). If a reference to sym is found, true is returned. + expression(e). If a reference to sym is found, true is returned. 12.5.4 requires that any variable of function that is implicitly typed shall have that type confirmed by any subsequent type declaration. The implicit typing is conveniently done here. */ @@ -5207,47 +5223,100 @@ select_type_push (gfc_symbol *sel) } +/* Set the temporary for the current intrinsic SELECT TYPE selector. */ + +static gfc_symtree * +select_intrinsic_set_tmp (gfc_typespec *ts) +{ + char name[GFC_MAX_SYMBOL_LEN]; + gfc_symtree *tmp; + int charlen = 0; + + if (ts->type == BT_CLASS || ts->type == BT_DERIVED) + return NULL; + + if (select_type_stack->selector->ts.type == BT_CLASS + && !select_type_stack->selector->attr.class_ok) + return NULL; + + if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length + && ts->u.cl->length->expr_type == EXPR_CONSTANT) + charlen = mpz_get_si (ts->u.cl->length->value.integer); + + if (ts->type != BT_CHARACTER) + sprintf (name, "__tmp_%s_%d", gfc_basic_typename (ts->type), + ts->kind); + else + sprintf (name, "__tmp_%s_%d_%d", gfc_basic_typename (ts->type), + charlen, ts->kind); + + 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. */ + if (select_type_stack->selector->ts.type == BT_CLASS + && (CLASS_DATA (select_type_stack->selector)->attr.dimension + || CLASS_DATA (select_type_stack->selector)->attr.codimension)) + { + tmp->n.sym->attr.pointer = 1; + tmp->n.sym->attr.dimension + = CLASS_DATA (select_type_stack->selector)->attr.dimension; + tmp->n.sym->attr.codimension + = CLASS_DATA (select_type_stack->selector)->attr.codimension; + tmp->n.sym->as + = gfc_copy_array_spec (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; + + return tmp; +} + + /* Set up a temporary for the current TYPE IS / CLASS IS branch . */ static void select_type_set_tmp (gfc_typespec *ts) { char name[GFC_MAX_SYMBOL_LEN]; - gfc_symtree *tmp; + gfc_symtree *tmp = NULL; if (!ts) { select_type_stack->tmp = NULL; return; } - - if (!gfc_type_is_extensible (ts->u.derived)) - return; - if (ts->type == BT_CLASS) - sprintf (name, "__tmp_class_%s", ts->u.derived->name); - else - 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); + tmp = select_intrinsic_set_tmp (ts); - if (select_type_stack->selector->ts.type == BT_CLASS - && select_type_stack->selector->attr.class_ok) + if (tmp == NULL) { - tmp->n.sym->attr.pointer - = CLASS_DATA (select_type_stack->selector)->attr.class_pointer; + if (ts->type == BT_CLASS) + sprintf (name, "__tmp_class_%s", ts->u.derived->name); + else + 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. */ - if ((CLASS_DATA (select_type_stack->selector)->attr.dimension - || CLASS_DATA (select_type_stack->selector)->attr.codimension)) + if (select_type_stack->selector->ts.type == BT_CLASS + && select_type_stack->selector->attr.class_ok) { - tmp->n.sym->attr.dimension + tmp->n.sym->attr.pointer + = CLASS_DATA (select_type_stack->selector)->attr.class_pointer; + + /* Copy across the array spec to the selector. */ + if (CLASS_DATA (select_type_stack->selector)->attr.dimension + || CLASS_DATA (select_type_stack->selector)->attr.codimension) + { + tmp->n.sym->attr.dimension = CLASS_DATA (select_type_stack->selector)->attr.dimension; - tmp->n.sym->attr.codimension + tmp->n.sym->attr.codimension = CLASS_DATA (select_type_stack->selector)->attr.codimension; - tmp->n.sym->as + tmp->n.sym->as = gfc_copy_array_spec (CLASS_DATA (select_type_stack->selector)->as); - } + } } gfc_set_sym_referenced (tmp->n.sym); @@ -5257,6 +5326,7 @@ select_type_set_tmp (gfc_typespec *ts) if (ts->type == BT_CLASS) gfc_build_class_symbol (&tmp->n.sym->ts, &tmp->n.sym->attr, &tmp->n.sym->as, false); + } /* Add an association for it, so the rest of the parser knows it is an associate-name. The target will be set during resolution. */ @@ -5267,7 +5337,7 @@ select_type_set_tmp (gfc_typespec *ts) select_type_stack->tmp = tmp; } - + /* Match a SELECT TYPE statement. */ match @@ -5356,7 +5426,7 @@ gfc_match_select_type (void) select_type_push (expr1->symtree->n.sym); return MATCH_YES; - + cleanup: parent_ns = gfc_current_ns->parent; gfc_free_namespace (gfc_current_ns); @@ -5457,9 +5527,7 @@ gfc_match_type_is (void) c = gfc_get_case (); c->where = gfc_current_locus; - /* TODO: Once unlimited polymorphism is implemented, we will need to call - match_type_spec here. */ - if (match_derived_type_spec (&c->ts) == MATCH_ERROR) + if (match_type_spec (&c->ts) == MATCH_ERROR) goto cleanup; if (gfc_match_char (')') != MATCH_YES) @@ -5474,6 +5542,16 @@ gfc_match_type_is (void) new_st.op = EXEC_SELECT_TYPE; new_st.ext.block.case_list = c; + if (c->ts.type == BT_DERIVED && c->ts.u.derived + && (c->ts.u.derived->attr.sequence + || c->ts.u.derived->attr.is_bind_c)) + { + gfc_error ("The type-spec shall not specify a sequence derived " + "type or a type with the BIND attribute in SELECT " + "TYPE at %C [F2003:C815]"); + return MATCH_ERROR; + } + /* Create temporary variable. */ select_type_set_tmp (&c->ts); @@ -5546,7 +5624,7 @@ gfc_match_class_is (void) new_st.op = EXEC_SELECT_TYPE; new_st.ext.block.case_list = c; - + /* Create temporary variable. */ select_type_set_tmp (&c->ts); @@ -5564,7 +5642,7 @@ cleanup: /********************* WHERE subroutines ********************/ -/* Match the rest of a simple WHERE statement that follows an IF statement. +/* Match the rest of a simple WHERE statement that follows an IF statement. */ static match |