diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c index e0714e3..bc3148c 100644 --- a/gcc/fortran/array.c +++ b/gcc/fortran/array.c @@ -61,12 +61,13 @@ gfc_copy_array_ref (gfc_array_ref *src) expression. */ static match -match_subscript (gfc_array_ref *ar, int init) +match_subscript (gfc_array_ref *ar, int init, bool match_star) { match m; + bool star = false; int i; - i = ar->dimen; + i = ar->dimen + ar->codimen; ar->c_where[i] = gfc_current_locus; ar->start[i] = ar->end[i] = ar->stride[i] = NULL; @@ -81,9 +82,12 @@ match_subscript (gfc_array_ref *ar, int init) goto end_element; /* Get start element. */ - if (init) + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + + if (!star && init) m = gfc_match_init_expr (&ar->start[i]); - else + else if (!star) m = gfc_match_expr (&ar->start[i]); if (m == MATCH_NO) @@ -92,14 +96,22 @@ match_subscript (gfc_array_ref *ar, int init) return MATCH_ERROR; if (gfc_match_char (':') == MATCH_NO) - return MATCH_YES; + goto matched; + + if (star) + { + gfc_error ("Unexpected '*' in coarray subscript at %C"); + return MATCH_ERROR; + } /* Get an optional end element. Because we've seen the colon, we definitely have a range along this dimension. */ end_element: ar->dimen_type[i] = DIMEN_RANGE; - if (init) + if (match_star && (m = gfc_match_char ('*')) == MATCH_YES) + star = true; + else if (init) m = gfc_match_init_expr (&ar->end[i]); else m = gfc_match_expr (&ar->end[i]); @@ -110,6 +122,12 @@ end_element: /* See if we have an optional stride. */ if (gfc_match_char (':') == MATCH_YES) { + if (star) + { + gfc_error ("Strides not allowed in coarray subscript at %C"); + return MATCH_ERROR; + } + m = init ? gfc_match_init_expr (&ar->stride[i]) : gfc_match_expr (&ar->stride[i]); @@ -119,6 +137,10 @@ end_element: return MATCH_ERROR; } +matched: + if (star) + ar->dimen_type[i] = DIMEN_STAR; + return MATCH_YES; } @@ -128,14 +150,23 @@ end_element: to consist of init expressions. */ match -gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) +gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init, + int corank) { match m; + bool matched_bracket = false; memset (ar, '\0', sizeof (ar)); ar->where = gfc_current_locus; ar->as = as; + ar->type = AR_UNKNOWN; + + if (gfc_match_char ('[') == MATCH_YES) + { + matched_bracket = true; + goto coarray; + } if (gfc_match_char ('(') != MATCH_YES) { @@ -144,16 +175,17 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) return MATCH_YES; } - ar->type = AR_UNKNOWN; - for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++) { - m = match_subscript (ar, init); + m = match_subscript (ar, init, false); if (m == MATCH_ERROR) goto error; if (gfc_match_char (')') == MATCH_YES) - goto matched; + { + ar->dimen++; + goto coarray; + } if (gfc_match_char (',') != MATCH_YES) { @@ -164,12 +196,49 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init) gfc_error ("Array reference at %C cannot have more than %d dimensions", GFC_MAX_DIMENSIONS); + goto error; + +coarray: + if (!matched_bracket && gfc_match_char ('[') != MATCH_YES) + { + if (ar->dimen > 0) + goto matched; + else + goto error; + } + + if (corank == 0) + { + gfc_error ("Unexpected coarray designator at %C"); + goto error; + } + + for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++) + { + m = match_subscript (ar, init, ar->codimen == (corank - 1)); + if (m == MATCH_ERROR) + goto error; + + if (gfc_match_char (']') == MATCH_YES) + { + ar->codimen++; + goto matched; + } + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Invalid form of coarray reference at %C"); + goto error; + } + } + + gfc_error ("Array reference at %C cannot have more than %d dimensions", + GFC_MAX_DIMENSIONS); error: return MATCH_ERROR; matched: - ar->dimen++; return MATCH_YES; } @@ -188,7 +257,7 @@ gfc_free_array_spec (gfc_array_spec *as) if (as == NULL) return; - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { gfc_free_expr (as->lower[i]); gfc_free_expr (as->upper[i]); @@ -234,7 +303,7 @@ gfc_resolve_array_spec (gfc_array_spec *as, int check_constant) if (as == NULL) return SUCCESS; - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { e = as->lower[i]; if (resolve_array_bound (e, check_constant) == FAILURE) @@ -290,8 +359,8 @@ match_array_element_spec (gfc_array_spec *as) gfc_expr **upper, **lower; match m; - lower = &as->lower[as->rank - 1]; - upper = &as->upper[as->rank - 1]; + lower = &as->lower[as->rank + as->corank - 1]; + upper = &as->upper[as->rank + as->corank - 1]; if (gfc_match_char ('*') == MATCH_YES) { @@ -335,22 +404,19 @@ match_array_element_spec (gfc_array_spec *as) /* Matches an array specification, incidentally figuring out what sort - it is. */ + it is. Match either a normal array specification, or a coarray spec + or both. Optionally allow [:] for coarrays. */ match -gfc_match_array_spec (gfc_array_spec **asp) +gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim) { array_type current_type; gfc_array_spec *as; int i; - - if (gfc_match_char ('(') != MATCH_YES) - { - *asp = NULL; - return MATCH_NO; - } - + as = gfc_get_array_spec (); + as->corank = 0; + as->rank = 0; for (i = 0; i < GFC_MAX_DIMENSIONS; i++) { @@ -358,10 +424,19 @@ gfc_match_array_spec (gfc_array_spec **asp) as->upper[i] = NULL; } - as->rank = 1; + if (!match_dim) + goto coarray; + + if (gfc_match_char ('(') != MATCH_YES) + { + if (!match_codim) + goto done; + goto coarray; + } for (;;) { + as->rank++; current_type = match_array_element_spec (as); if (as->rank == 1) @@ -427,32 +502,138 @@ gfc_match_array_spec (gfc_array_spec **asp) goto cleanup; } - if (as->rank >= GFC_MAX_DIMENSIONS) + if (as->rank + as->corank >= GFC_MAX_DIMENSIONS) { gfc_error ("Array specification at %C has more than %d dimensions", GFC_MAX_DIMENSIONS); goto cleanup; } - if (as->rank >= 7 + if (as->corank + as->rank >= 7 && gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Array " "specification at %C with more than 7 dimensions") == FAILURE) goto cleanup; + } - as->rank++; + if (!match_codim) + goto done; + +coarray: + if (gfc_match_char ('[') != MATCH_YES) + goto done; + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Coarray declaration at %C") + == FAILURE) + goto cleanup; + + for (;;) + { + as->corank++; + current_type = match_array_element_spec (as); + + if (current_type == AS_UNKNOWN) + goto cleanup; + + if (as->corank == 1) + as->cotype = current_type; + else + switch (as->cotype) + { /* See how current spec meshes with the existing. */ + case AS_UNKNOWN: + goto cleanup; + + case AS_EXPLICIT: + if (current_type == AS_ASSUMED_SIZE) + { + as->cotype = AS_ASSUMED_SIZE; + break; + } + + if (current_type == AS_EXPLICIT) + break; + + gfc_error ("Bad array specification for an explicitly " + "shaped array at %C"); + + goto cleanup; + + case AS_ASSUMED_SHAPE: + if ((current_type == AS_ASSUMED_SHAPE) + || (current_type == AS_DEFERRED)) + break; + + gfc_error ("Bad array specification for assumed shape " + "array at %C"); + goto cleanup; + + case AS_DEFERRED: + if (current_type == AS_DEFERRED) + break; + + if (current_type == AS_ASSUMED_SHAPE) + { + as->cotype = AS_ASSUMED_SHAPE; + break; + } + + gfc_error ("Bad specification for deferred shape array at %C"); + goto cleanup; + + case AS_ASSUMED_SIZE: + gfc_error ("Bad specification for assumed size array at %C"); + goto cleanup; + } + + if (gfc_match_char (']') == MATCH_YES) + break; + + if (gfc_match_char (',') != MATCH_YES) + { + gfc_error ("Expected another dimension in array declaration at %C"); + goto cleanup; + } + + if (as->corank >= GFC_MAX_DIMENSIONS) + { + gfc_error ("Array specification at %C has more than %d " + "dimensions", GFC_MAX_DIMENSIONS); + goto cleanup; + } + } + + if (current_type == AS_EXPLICIT) + { + gfc_error ("Upper bound of last coarray dimension must be '*' at %C"); + goto cleanup; + } + + if (as->cotype == AS_ASSUMED_SIZE) + as->cotype = AS_EXPLICIT; + + if (as->rank == 0) + as->type = as->cotype; + +done: + if (as->rank == 0 && as->corank == 0) + { + *asp = NULL; + gfc_free_array_spec (as); + return MATCH_NO; } /* If a lower bounds of an assumed shape array is blank, put in one. */ if (as->type == AS_ASSUMED_SHAPE) { - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { if (as->lower[i] == NULL) as->lower[i] = gfc_int_expr (1); } } + *asp = as; + return MATCH_YES; cleanup: @@ -469,14 +650,64 @@ cleanup: gfc_try gfc_set_array_spec (gfc_symbol *sym, gfc_array_spec *as, locus *error_loc) { + int i; + if (as == NULL) return SUCCESS; - if (gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) + if (as->rank + && gfc_add_dimension (&sym->attr, sym->name, error_loc) == FAILURE) return FAILURE; - sym->as = as; + if (as->corank + && gfc_add_codimension (&sym->attr, sym->name, error_loc) == FAILURE) + return FAILURE; + + if (sym->as == NULL) + { + sym->as = as; + return SUCCESS; + } + + if (as->corank) + { + /* The "sym" has no corank (checked via gfc_add_codimension). Thus + the codimension is simply added. */ + gcc_assert (as->rank == 0 && sym->as->corank == 0); + sym->as->cotype = as->cotype; + sym->as->corank = as->corank; + for (i = 0; i < as->corank; i++) + { + sym->as->lower[sym->as->rank + i] = as->lower[i]; + sym->as->upper[sym->as->rank + i] = as->upper[i]; + } + } + else + { + /* The "sym" has no rank (checked via gfc_add_dimension). Thus + the dimension is added - but first the codimensions (if existing + need to be shifted to make space for the dimension. */ + gcc_assert (as->corank == 0 && sym->as->rank == 0); + + sym->as->rank = as->rank; + sym->as->type = as->type; + sym->as->cray_pointee = as->cray_pointee; + sym->as->cp_was_assumed = as->cp_was_assumed; + + for (i = 0; i < sym->as->corank; i++) + { + sym->as->lower[as->rank + i] = sym->as->lower[i]; + sym->as->upper[as->rank + i] = sym->as->upper[i]; + } + for (i = 0; i < as->rank; i++) + { + sym->as->lower[i] = as->lower[i]; + sym->as->upper[i] = as->upper[i]; + } + } + + gfc_free (as); return SUCCESS; } @@ -496,7 +727,7 @@ gfc_copy_array_spec (gfc_array_spec *src) *dest = *src; - for (i = 0; i < dest->rank; i++) + for (i = 0; i < dest->rank + dest->corank; i++) { dest->lower[i] = gfc_copy_expr (dest->lower[i]); dest->upper[i] = gfc_copy_expr (dest->upper[i]); @@ -543,6 +774,9 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) if (as1->rank != as2->rank) return 0; + if (as1->corank != as2->corank) + return 0; + if (as1->rank == 0) return 1; @@ -550,7 +784,7 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2) return 0; if (as1->type == AS_EXPLICIT) - for (i = 0; i < as1->rank; i++) + for (i = 0; i < as1->rank + as1->corank; i++) { if (compare_bounds (as1->lower[i], as2->lower[i]) == 0) return 0; diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c index 0d04d65..8c79bad 100644 --- a/gcc/fortran/data.c +++ b/gcc/fortran/data.c @@ -289,6 +289,14 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index) switch (ref->type) { case REF_ARRAY: + if (ref->u.ar.as->rank == 0) + { + gcc_assert (ref->u.ar.as->corank > 0); + if (init == NULL) + gfc_free (expr); + continue; + } + if (init && expr->expr_type != EXPR_ARRAY) { gfc_error ("'%s' at %L already is initialized at %L", diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c index 692078a..eda77ad 100644 --- a/gcc/fortran/decl.c +++ b/gcc/fortran/decl.c @@ -1057,6 +1057,7 @@ build_sym (const char *name, gfc_charlen *cl, dimension attribute. */ attr = current_attr; attr.dimension = 0; + attr.codimension = 0; if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE) return FAILURE; @@ -1430,7 +1431,12 @@ build_struct (const char *name, gfc_charlen *cl, gfc_expr **init, c->as = *as; if (c->as != NULL) - c->attr.dimension = 1; + { + if (c->as->corank) + c->attr.codimension = 1; + if (c->as->rank) + c->attr.dimension = 1; + } *as = NULL; /* Should this ever get more complicated, combine with similar section @@ -1589,7 +1595,7 @@ variable_decl (int elem) var_locus = gfc_current_locus; /* Now we could see the optional array spec. or character length. */ - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, true, true); if (gfc_option.flag_cray_pointer && m == MATCH_YES) cp_as = gfc_copy_array_spec (as); else if (m == MATCH_ERROR) @@ -1597,6 +1603,36 @@ variable_decl (int elem) if (m == MATCH_NO) as = gfc_copy_array_spec (current_as); + else if (current_as && as->corank == 0 && current_as->corank > 0) + { + int i; + as->cotype = current_as->cotype; + as->corank = current_as->corank; + for (i = 0; i < current_as->corank; i++) + { + as->lower[as->rank + i] = gfc_copy_expr (current_as->lower[i]); + as->upper[as->rank + i] = gfc_copy_expr (current_as->upper[i]); + } + } + else if (current_as && as->rank == 0 && current_as->rank > 0) + { + int i; + as->rank = current_as->rank; + as->type = current_as->type; + as->cray_pointee = current_as->cray_pointee; + as->cp_was_assumed = current_as->cp_was_assumed; + + for (i = 0; i < as->corank; i++) + { + as->lower[current_as->rank + i] = as->lower[i]; + as->upper[current_as->rank + i] = as->upper[i]; + } + for (i = 0; i < current_as->rank; i++) + { + as->lower[i] = gfc_copy_expr (current_as->lower[i]); + as->upper[i] = gfc_copy_expr (current_as->upper[i]); + } + } char_len = NULL; cl = NULL; @@ -2820,7 +2856,7 @@ match_attr_spec (void) DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL, DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE, DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE, - DECL_IS_BIND_C, DECL_ASYNCHRONOUS, DECL_NONE, + DECL_IS_BIND_C, DECL_CODIMENSION, DECL_ASYNCHRONOUS, DECL_NONE, GFC_DECL_END /* Sentinel */ } decl_types; @@ -2894,6 +2930,11 @@ match_attr_spec (void) goto cleanup; break; + case 'c': + if (match_string_p ("codimension")) + d = DECL_CODIMENSION; + break; + case 'd': if (match_string_p ("dimension")) d = DECL_DIMENSION; @@ -3041,7 +3082,34 @@ match_attr_spec (void) if (d == DECL_DIMENSION) { - m = gfc_match_array_spec (¤t_as); + gfc_array_spec *as = NULL; + + m = gfc_match_array_spec (&as, true, false); + if (current_as == NULL) + current_as = as; + else if (m == MATCH_YES) + { + int i; + gcc_assert (current_as->rank == 0 && current_as->corank > 0 + && as->rank > 0 && as->corank == 0); + current_as->rank = as->rank; + current_as->type = as->type; + current_as->cray_pointee = as->cray_pointee; + current_as->cp_was_assumed = as->cp_was_assumed; + + for (i = 0; i < current_as->corank; i++) + { + current_as->lower[as->rank + i] = current_as->lower[i]; + current_as->upper[as->rank + i] = current_as->upper[i]; + } + for (i = 0; i < as->rank; i++) + { + current_as->lower[i] = as->lower[i]; + current_as->upper[i] = as->upper[i]; + } + + gfc_free (as); + } if (m == MATCH_NO) { @@ -3052,6 +3120,40 @@ match_attr_spec (void) if (m == MATCH_ERROR) goto cleanup; } + + if (d == DECL_CODIMENSION) + { + gfc_array_spec *as = NULL; + + m = gfc_match_array_spec (&as, false, true); + if (current_as == NULL) + current_as = as; + else if (m == MATCH_YES) + { + int i; + gcc_assert (current_as->corank == 0 && current_as->rank > 0 + && as->corank > 0 && as->rank == 0); + current_as->corank = as->corank; + current_as->cotype = as->cotype; + + for (i = 0; i < as->corank; i++) + { + current_as->lower[current_as->rank + i] = as->lower[i]; + current_as->upper[current_as->rank + i] = as->upper[i]; + } + + gfc_free (as); + } + + if (m == MATCH_NO) + { + gfc_error ("Missing codimension specification at %C"); + m = MATCH_ERROR; + } + + if (m == MATCH_ERROR) + goto cleanup; + } } /* Since we've seen a double colon, we have to be looking at an @@ -3067,6 +3169,9 @@ match_attr_spec (void) case DECL_ASYNCHRONOUS: attr = "ASYNCHRONOUS"; break; + case DECL_CODIMENSION: + attr = "CODIMENSION"; + break; case DECL_DIMENSION: attr = "DIMENSION"; break; @@ -3135,9 +3240,9 @@ match_attr_spec (void) continue; if (gfc_current_state () == COMP_DERIVED - && d != DECL_DIMENSION && d != DECL_POINTER - && d != DECL_PRIVATE && d != DECL_PUBLIC - && d != DECL_NONE) + && d != DECL_DIMENSION && d != DECL_CODIMENSION + && d != DECL_POINTER && d != DECL_PRIVATE + && d != DECL_PUBLIC && d != DECL_NONE) { if (d == DECL_ALLOCATABLE) { @@ -3202,6 +3307,10 @@ match_attr_spec (void) t = gfc_add_asynchronous (¤t_attr, NULL, &seen_at[d]); break; + case DECL_CODIMENSION: + t = gfc_add_codimension (¤t_attr, NULL, &seen_at[d]); + break; + case DECL_DIMENSION: t = gfc_add_dimension (¤t_attr, NULL, &seen_at[d]); break; @@ -5476,6 +5585,12 @@ gfc_match_end (gfc_statement *st) eos_ok = 0; break; + case COMP_CRITICAL: + *st = ST_END_CRITICAL; + target = " critical"; + eos_ok = 0; + break; + case COMP_SELECT: case COMP_SELECT_TYPE: *st = ST_END_SELECT; @@ -5534,7 +5649,8 @@ gfc_match_end (gfc_statement *st) { if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT - && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK) + && *st != ST_END_FORALL && *st != ST_END_WHERE && *st != ST_END_BLOCK + && *st != ST_END_CRITICAL) return MATCH_YES; if (!block_name) @@ -5619,11 +5735,15 @@ attr_decl1 (void) /* Deal with possible array specification for certain attributes. */ if (current_attr.dimension + || current_attr.codimension || current_attr.allocatable || current_attr.pointer || current_attr.target) { - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, !current_attr.codimension, + !current_attr.dimension + && !current_attr.pointer + && !current_attr.target); if (m == MATCH_ERROR) goto cleanup; @@ -5643,6 +5763,14 @@ attr_decl1 (void) goto cleanup; } + if (current_attr.codimension && m == MATCH_NO) + { + gfc_error ("Missing array specification at %L in CODIMENSION " + "statement", &var_locus); + m = MATCH_ERROR; + goto cleanup; + } + if ((current_attr.allocatable || current_attr.pointer) && (m == MATCH_YES) && (as->type != AS_DEFERRED)) { @@ -5671,8 +5799,8 @@ attr_decl1 (void) } else { - if (current_attr.dimension == 0 - && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE) + if (current_attr.dimension == 0 && current_attr.codimension == 0 + && gfc_copy_attr (&sym->attr, ¤t_attr, &var_locus) == FAILURE) { m = MATCH_ERROR; goto cleanup; @@ -5770,7 +5898,7 @@ static match cray_pointer_decl (void) { match m; - gfc_array_spec *as; + gfc_array_spec *as = NULL; gfc_symbol *cptr; /* Pointer symbol. */ gfc_symbol *cpte; /* Pointee symbol. */ locus var_locus; @@ -5839,7 +5967,7 @@ cray_pointer_decl (void) } /* Check for an optional array spec. */ - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, true, false); if (m == MATCH_ERROR) { gfc_free_array_spec (as); @@ -5999,6 +6127,16 @@ gfc_match_allocatable (void) match +gfc_match_codimension (void) +{ + gfc_clear_attr (¤t_attr); + current_attr.codimension = 1; + + return attr_decl (); +} + + +match gfc_match_dimension (void) { gfc_clear_attr (¤t_attr); @@ -6486,11 +6624,19 @@ gfc_match_volatile (void) for(;;) { /* VOLATILE is special because it can be added to host-associated - symbols locally. */ + symbols locally. Except for coarrays. */ m = gfc_match_symbol (&sym, 1); switch (m) { case MATCH_YES: + /* F2008, C560+C561. VOLATILE for host-/use-associated variable or + for variable in a BLOCK which is defined outside of the BLOCK. */ + if (sym->ns != gfc_current_ns && sym->attr.codimension) + { + gfc_error ("Specifying VOLATILE for coarray variable '%s' at " + "%C, which is use-/host-associated", sym->name); + return MATCH_ERROR; + } if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus) == FAILURE) return MATCH_ERROR; diff --git a/gcc/fortran/dump-parse-tree.c b/gcc/fortran/dump-parse-tree.c index f363816..e722ff0 100644 --- a/gcc/fortran/dump-parse-tree.c +++ b/gcc/fortran/dump-parse-tree.c @@ -1,5 +1,5 @@ /* Parse tree dumper - Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009 + Copyright (C) 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. Contributed by Steven Bosscher @@ -141,9 +141,9 @@ show_array_spec (gfc_array_spec *as) return; } - fprintf (dumpfile, "(%d", as->rank); + fprintf (dumpfile, "(%d [%d]", as->rank, as->corank); - if (as->rank != 0) + if (as->rank + as->corank > 0) { switch (as->type) { @@ -157,7 +157,7 @@ show_array_spec (gfc_array_spec *as) } fprintf (dumpfile, " %s ", c); - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { show_expr (as->lower[i]); fputc (' ', dumpfile); @@ -591,6 +591,8 @@ show_attr (symbol_attribute *attr) fputs (" ALLOCATABLE", dumpfile); if (attr->asynchronous) fputs (" ASYNCHRONOUS", dumpfile); + if (attr->codimension) + fputs (" CODIMENSION", dumpfile); if (attr->dimension) fputs (" DIMENSION", dumpfile); if (attr->external) @@ -1273,6 +1275,10 @@ show_code_node (int level, gfc_code *c) break; + case EXEC_ERROR_STOP: + fputs ("ERROR ", dumpfile); + /* Fall through. */ + case EXEC_STOP: fputs ("STOP ", dumpfile); @@ -1283,6 +1289,52 @@ show_code_node (int level, gfc_code *c) break; + case EXEC_SYNC_ALL: + fputs ("SYNC ALL ", dumpfile); + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + + case EXEC_SYNC_MEMORY: + fputs ("SYNC MEMORY ", dumpfile); + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + + case EXEC_SYNC_IMAGES: + fputs ("SYNC IMAGES image-set=", dumpfile); + if (c->expr1 != NULL) + show_expr (c->expr1); + else + fputs ("* ", dumpfile); + if (c->expr2 != NULL) + { + fputs (" stat=", dumpfile); + show_expr (c->expr2); + } + if (c->expr3 != NULL) + { + fputs (" errmsg=", dumpfile); + show_expr (c->expr3); + } + break; + case EXEC_ARITHMETIC_IF: fputs ("IF ", dumpfile); show_expr (c->expr1); @@ -1400,6 +1452,13 @@ show_code_node (int level, gfc_code *c) fputs ("END FORALL", dumpfile); break; + case EXEC_CRITICAL: + fputs ("CRITICAL\n", dumpfile); + show_code (level + 1, c->block->next); + code_indent (level, 0); + fputs ("END CRITICAL", dumpfile); + break; + case EXEC_DO: fputs ("DO ", dumpfile); diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c index 58c9063..7703959 100644 --- a/gcc/fortran/expr.c +++ b/gcc/fortran/expr.c @@ -3204,6 +3204,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN) return SUCCESS; + /* F2008, C723 (pointer) and C726 (proc-pointer); for PURE also C1283. */ + if (lvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (lvalue)) + { + gfc_ref *ref; + for (ref = lvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Pointer object at %L shall not have a coindex", + &lvalue->where); + return FAILURE; + } + } + /* Checks on rvalue for procedure pointer assignments. */ if (proc_pointer) { @@ -3368,6 +3382,20 @@ gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue) return FAILURE; } + /* F2008, C725. For PURE also C1283. */ + if (rvalue->expr_type == EXPR_VARIABLE + && gfc_is_coindexed (rvalue)) + { + gfc_ref *ref; + for (ref = rvalue->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("Data target at %L shall not have a coindex", + &rvalue->where); + return FAILURE; + } + } + return SUCCESS; } @@ -3641,7 +3669,8 @@ gfc_traverse_expr (gfc_expr *expr, gfc_symbol *sym, return true; if (ref->u.c.component->as) - for (i = 0; i < ref->u.c.component->as->rank; i++) + for (i = 0; i < ref->u.c.component->as->rank + + ref->u.c.component->as->corank; i++) { if (gfc_traverse_expr (ref->u.c.component->as->lower[i], sym, func, f)) @@ -3835,3 +3864,75 @@ gfc_expr_replace_comp (gfc_expr *expr, gfc_component *dest) gfc_traverse_expr (expr, (gfc_symbol *)dest, &replace_comp, 0); } + +bool +gfc_is_coindexed (gfc_expr *e) +{ + gfc_ref *ref; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + return true; + + return false; +} + + +/* Check whether the expression has an ultimate allocatable component. + Being itself allocatable does not count. */ +bool +gfc_has_ultimate_allocatable (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return last->u.c.component->ts.u.derived->components->attr.alloc_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.alloc_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return e->ts.u.derived->components->attr.alloc_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.alloc_comp; + else + return false; +} + + +/* Check whether the expression has an pointer component. + Being itself a pointer does not count. */ +bool +gfc_has_ultimate_pointer (gfc_expr *e) +{ + gfc_ref *ref, *last = NULL; + + if (e->expr_type != EXPR_VARIABLE) + return false; + + for (ref = e->ref; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + last = ref; + + if (last && last->u.c.component->ts.type == BT_CLASS) + return last->u.c.component->ts.u.derived->components->attr.pointer_comp; + else if (last && last->u.c.component->ts.type == BT_DERIVED) + return last->u.c.component->ts.u.derived->attr.pointer_comp; + else if (last) + return false; + + if (e->ts.type == BT_CLASS) + return e->ts.u.derived->components->attr.pointer_comp; + else if (e->ts.type == BT_DERIVED) + return e->ts.u.derived->attr.pointer_comp; + else + return false; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index eeaf0af..2dd3715 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1,6 +1,6 @@ /* gfortran header file - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 - Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, + 2010 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -213,9 +213,9 @@ typedef enum ST_END_FILE, ST_FINAL, ST_FLUSH, ST_END_FORALL, ST_END_FUNCTION, ST_ENDIF, ST_END_INTERFACE, ST_END_MODULE, ST_END_PROGRAM, ST_END_SELECT, ST_END_SUBROUTINE, ST_END_WHERE, ST_END_TYPE, ST_ENTRY, ST_EQUIVALENCE, - ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, ST_GOTO, - ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, - ST_INQUIRE, ST_INTERFACE, + ST_ERROR_STOP, ST_EXIT, ST_FORALL, ST_FORALL_BLOCK, ST_FORMAT, ST_FUNCTION, + ST_GOTO, ST_IF_BLOCK, ST_IMPLICIT, ST_IMPLICIT_NONE, ST_IMPORT, + ST_INQUIRE, ST_INTERFACE, ST_SYNC_ALL, ST_SYNC_MEMORY, ST_SYNC_IMAGES, ST_PARAMETER, ST_MODULE, ST_MODULE_PROC, ST_NAMELIST, ST_NULLIFY, ST_OPEN, ST_PAUSE, ST_PRIVATE, ST_PROGRAM, ST_PUBLIC, ST_READ, ST_RETURN, ST_REWIND, ST_STOP, ST_SUBROUTINE, ST_TYPE, ST_USE, ST_WHERE_BLOCK, ST_WHERE, ST_WAIT, @@ -230,7 +230,7 @@ typedef enum ST_OMP_PARALLEL, ST_OMP_PARALLEL_DO, ST_OMP_PARALLEL_SECTIONS, ST_OMP_PARALLEL_WORKSHARE, ST_OMP_SECTIONS, ST_OMP_SECTION, ST_OMP_SINGLE, ST_OMP_THREADPRIVATE, ST_OMP_WORKSHARE, ST_OMP_TASK, ST_OMP_END_TASK, - ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC, + ST_OMP_TASKWAIT, ST_PROCEDURE, ST_GENERIC, ST_CRITICAL, ST_END_CRITICAL, ST_GET_FCN_CHARACTERISTICS, ST_NONE } gfc_statement; @@ -461,6 +461,7 @@ enum gfc_isym_id GFC_ISYM_NINT, GFC_ISYM_NOT, GFC_ISYM_NULL, + GFC_ISYM_NUMIMAGES, GFC_ISYM_OR, GFC_ISYM_PACK, GFC_ISYM_PERROR, @@ -649,7 +650,7 @@ extern const ext_attr_t ext_attr_list[]; typedef struct { /* Variable attributes. */ - unsigned allocatable:1, dimension:1, external:1, intrinsic:1, + unsigned allocatable:1, dimension:1, codimension:1, external:1, intrinsic:1, optional:1, pointer:1, target:1, value:1, volatile_:1, temporary:1, dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1, implied_index:1, subref_array_pointer:1, proc_pointer:1, asynchronous:1; @@ -733,7 +734,7 @@ typedef struct possibly nested. zero_comp is true if the derived type has no component at all. */ unsigned alloc_comp:1, pointer_comp:1, proc_pointer_comp:1, - private_comp:1, zero_comp:1; + private_comp:1, zero_comp:1, coarray_comp:1; /* Attributes set by compiler extensions (!GCC$ ATTRIBUTES). */ unsigned ext_attr:EXT_ATTR_NUM; @@ -865,7 +866,8 @@ gfc_typespec; typedef struct { int rank; /* A rank of zero means that a variable is a scalar. */ - array_type type; + int corank; + array_type type, cotype; struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS]; /* These two fields are used with the Cray Pointer extension. */ @@ -1434,13 +1436,15 @@ extern gfc_interface_info current_interface; enum gfc_array_ref_dimen_type { - DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_UNKNOWN + DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN }; typedef struct gfc_array_ref { ar_type type; int dimen; /* # of components in the reference */ + int codimen; + bool in_allocate; /* For coarray checks. */ locus where; gfc_array_spec *as; @@ -1975,12 +1979,13 @@ gfc_forall_iterator; typedef enum { EXEC_NOP = 1, EXEC_END_BLOCK, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, - EXEC_POINTER_ASSIGN, + EXEC_POINTER_ASSIGN, EXEC_CRITICAL, EXEC_ERROR_STOP, EXEC_GOTO, EXEC_CALL, EXEC_COMPCALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY, EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN, EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT, EXEC_BLOCK, EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT, EXEC_CALL_PPC, EXEC_ALLOCATE, EXEC_DEALLOCATE, EXEC_END_PROCEDURE, EXEC_SELECT_TYPE, + EXEC_SYNC_ALL, EXEC_SYNC_MEMORY, EXEC_SYNC_IMAGES, EXEC_OPEN, EXEC_CLOSE, EXEC_WAIT, EXEC_READ, EXEC_WRITE, EXEC_IOLENGTH, EXEC_TRANSFER, EXEC_DT_END, EXEC_BACKSPACE, EXEC_ENDFILE, EXEC_INQUIRE, EXEC_REWIND, EXEC_FLUSH, @@ -2397,6 +2402,7 @@ void gfc_set_sym_referenced (gfc_symbol *); gfc_try gfc_add_attribute (symbol_attribute *, locus *); gfc_try gfc_add_ext_attribute (symbol_attribute *, ext_attr_id_t, locus *); gfc_try gfc_add_allocatable (symbol_attribute *, locus *); +gfc_try gfc_add_codimension (symbol_attribute *, const char *, locus *); gfc_try gfc_add_dimension (symbol_attribute *, const char *, locus *); gfc_try gfc_add_external (symbol_attribute *, locus *); gfc_try gfc_add_intrinsic (symbol_attribute *, locus *); @@ -2629,6 +2635,11 @@ void gfc_expr_replace_comp (gfc_expr *, gfc_component *); bool gfc_is_proc_ptr_comp (gfc_expr *, gfc_component **); +bool gfc_is_coindexed (gfc_expr *); +bool gfc_has_ultimate_allocatable (gfc_expr *); +bool gfc_has_ultimate_pointer (gfc_expr *); + + /* st.c */ extern gfc_code new_st; diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c index 7bccaa6..84d7a13 100644 --- a/gcc/fortran/interface.c +++ b/gcc/fortran/interface.c @@ -1444,6 +1444,65 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, return 0; } + if (formal->attr.codimension) + { + gfc_ref *last = NULL; + + if (actual->expr_type != EXPR_VARIABLE + || (actual->ref == NULL + && !actual->symtree->n.sym->attr.codimension)) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray", + formal->name, &actual->where); + return 0; + } + + for (ref = actual->ref; ref; ref = ref->next) + { + if (ref->type == REF_ARRAY && ref->u.ar.codimen != 0) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray " + "and not coindexed", formal->name, &ref->u.ar.where); + return 0; + } + if (ref->type == REF_ARRAY && ref->u.ar.as->corank + && ref->u.ar.type != AR_FULL && ref->u.ar.dimen != 0) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray " + "and thus shall not have an array designator", + formal->name, &ref->u.ar.where); + return 0; + } + if (ref->type == REF_COMPONENT) + last = ref; + } + + if (last && !last->u.c.component->attr.codimension) + { + if (where) + gfc_error ("Actual argument to '%s' at %L must be a coarray", + formal->name, &actual->where); + return 0; + } + + /* F2008, 12.5.2.6. */ + if (formal->attr.allocatable && + ((last && last->u.c.component->as->corank != formal->as->corank) + || (!last + && actual->symtree->n.sym->as->corank != formal->as->corank))) + { + if (where) + gfc_error ("Corank mismatch in argument '%s' at %L (%d and %d)", + formal->name, &actual->where, formal->as->corank, + last ? last->u.c.component->as->corank + : actual->symtree->n.sym->as->corank); + return 0; + } + } + if (symbol_rank (formal) == actual->rank) return 1; @@ -1452,10 +1511,13 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, || formal->as->type == AS_DEFERRED) && actual->expr_type != EXPR_NULL; + /* Scalar & coindexed, see: F2008, Section 12.5.2.4. */ 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->rank == 0 && formal->as->type == AS_ASSUMED_SHAPE) + || (actual->rank == 0 && formal->attr.dimension + && gfc_is_coindexed (actual))) { if (where) gfc_error ("Rank mismatch in argument '%s' at %L (%d and %d)", @@ -1473,7 +1535,8 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual, - (F2003) if the actual argument is of type character. */ for (ref = actual->ref; ref; ref = ref->next) - if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT) + if (ref->type == REF_ARRAY && ref->u.ar.type == AR_ELEMENT + && ref->u.ar.dimen > 0) break; /* Not an array element. */ @@ -1983,6 +2046,57 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal, return 0; } + /* Fortran 2008, C1242. */ + if (f->sym->attr.pointer && gfc_is_coindexed (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L to pointer " + "dummy '%s'", + &a->expr->where, f->sym->name); + return 0; + } + + /* Fortran 2008, 12.5.2.5 (no constraint). */ + if (a->expr->expr_type == EXPR_VARIABLE + && f->sym->attr.intent != INTENT_IN + && f->sym->attr.allocatable + && gfc_is_coindexed (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L to allocatable " + "dummy '%s' requires INTENT(IN)", + &a->expr->where, f->sym->name); + return 0; + } + + /* Fortran 2008, C1237. */ + if (a->expr->expr_type == EXPR_VARIABLE + && (f->sym->attr.asynchronous || f->sym->attr.volatile_) + && gfc_is_coindexed (a->expr) + && (a->expr->symtree->n.sym->attr.volatile_ + || a->expr->symtree->n.sym->attr.asynchronous)) + { + if (where) + gfc_error ("Coindexed ASYNCHRONOUS or VOLATILE actual argument at " + "at %L requires that dummy %s' has neither " + "ASYNCHRONOUS nor VOLATILE", &a->expr->where, + f->sym->name); + return 0; + } + + /* Fortran 2008, 12.5.2.4 (no constraint). */ + if (a->expr->expr_type == EXPR_VARIABLE + && f->sym->attr.intent != INTENT_IN && !f->sym->attr.value + && gfc_is_coindexed (a->expr) + && gfc_has_ultimate_allocatable (a->expr)) + { + if (where) + gfc_error ("Coindexed actual argument at %L with allocatable " + "ultimate component to dummy '%s' requires either VALUE " + "or INTENT(IN)", &a->expr->where, f->sym->name); + return 0; + } + if (a->expr->expr_type != EXPR_NULL && compare_allocatable (f->sym, a->expr) == 0) { @@ -2366,6 +2480,36 @@ check_intents (gfc_formal_arglist *f, gfc_actual_arglist *a) return FAILURE; } } + + /* Fortran 2008, C1283. */ + if (gfc_pure (NULL) && gfc_is_coindexed (a->expr)) + { + if (f_intent == INTENT_INOUT || f_intent == INTENT_OUT) + { + gfc_error ("Coindexed actual argument at %L in PURE procedure " + "is passed to an INTENT(%s) argument", + &a->expr->where, gfc_intent_string (f_intent)); + return FAILURE; + } + + if (f->sym->attr.pointer) + { + gfc_error ("Coindexed actual argument at %L in PURE procedure " + "is passed to a POINTER dummy argument", + &a->expr->where); + return FAILURE; + } + } + + /* F2008, Section 12.5.2.4. */ + if (a->expr->ts.type == BT_CLASS && f->sym->ts.type == BT_CLASS + && gfc_is_coindexed (a->expr)) + { + gfc_error ("Coindexed polymorphic actual argument at %L is passed " + "polymorphic dummy argument '%s'", + &a->expr->where, f->sym->name); + return FAILURE; + } } return SUCCESS; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 7062312..e22c7bc 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2220,6 +2220,9 @@ add_functions (void) make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); + add_sym_0 ("num_images", GFC_ISYM_NUMIMAGES, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, + NULL, gfc_simplify_num_images, NULL); + add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack, ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index cf436db..2586702 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -297,6 +297,7 @@ gfc_expr *gfc_simplify_nearest (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_new_line (gfc_expr *); gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_null (gfc_expr *); +gfc_expr *gfc_simplify_num_images (void); gfc_expr *gfc_simplify_idnint (gfc_expr *); gfc_expr *gfc_simplify_not (gfc_expr *); gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 9d2ec79..aa0c71d 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -204,6 +204,7 @@ Some basic guidelines for editing this document: * @code{NINT}: NINT, Nearest whole number * @code{NOT}: NOT, Logical negation * @code{NULL}: NULL, Function that returns an disassociated pointer +* @code{NUM_IMAGES}: NUM_IMAGES, Number of images * @code{OR}: OR, Bitwise logical OR * @code{PACK}: PACK, Pack an array into an array of rank one * @code{PERROR}: PERROR, Print system error message @@ -8375,6 +8376,49 @@ REAL, POINTER, DIMENSION(:) :: VEC => NULL () +@node NUM_IMAGES +@section @code{NUM_IMAGES} --- Function that returns the number of images +@fnindex NUM_IMAGES +@cindex coarray, NUM_IMAGES +@cindex images, number of + +@table @asis +@item @emph{Description}: +Returns the number of images. + +@item @emph{Standard}: +Fortran 2008 and later + +@item @emph{Class}: +Transformational function + +@item @emph{Syntax}: +@code{RESULT = NUM_IMAGES()} + +@item @emph{Arguments}: None. + +@item @emph{Return value}: +Scalar default-kind integer. + +@item @emph{Example}: +@smallexample +INTEGER :: value[*] +INTEGER :: i +value = THIS_IMAGE() +SYNC ALL +IF (THIS_IMAGE() == 1) THEN + DO i = 1, NUM_IMAGES() + WRITE(*,'(2(a,i0))') 'value[', i, '] is ', value[i] + END DO +END IF +@end smallexample + +@item @emph{See also}: +@c FIXME: ref{THIS_IMAGE} +@end table + + + @node OR @section @code{OR} --- Bitwise logical OR @fnindex OR @@ -11237,14 +11281,21 @@ Fortran 95 elemental function: @ref{IEOR} @section @code{ISO_FORTRAN_ENV} @table @asis @item @emph{Standard}: -Fortran 2003 and later; @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64}, -@code{REAL32}, @code{REAL64}, @code{REAL128} are Fortran 2008 or later +Fortran 2003 and later, except when otherwise noted @end table The @code{ISO_FORTRAN_ENV} module provides the following scalar default-integer named constants: @table @asis +@item @code{ATOMIC_INT_KIND}: +Default-kind integer constant to be used as kind parameter when defining +integer variables used in atomic operations. (Fortran 2008 or later.) + +@item @code{ATOMIC_LOGICAL_KIND}: +Default-kind integer constant to be used as kind parameter when defining +logical variables used in atomic operations. (Fortran 2008 or later.) + @item @code{CHARACTER_STORAGE_SIZE}: Size in bits of the character storage unit. @@ -11258,10 +11309,10 @@ Size in bits of the file-storage unit. Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{READ} statement. -@item @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64} +@item @code{INT8}, @code{INT16}, @code{INT32}, @code{INT64}: Kind type parameters to specify an INTEGER type with a storage size of 16, 32, and 64 bits. It is negative if a target platform -does not support the particular kind. +does not support the particular kind. (Fortran 2008 or later.) @item @code{IOSTAT_END}: The value assigned to the variable passed to the IOSTAT= specifier of @@ -11271,6 +11322,11 @@ an input/output statement if an end-of-file condition occurred. The value assigned to the variable passed to the IOSTAT= specifier of an input/output statement if an end-of-record condition occurred. +@item @code{IOSTAT_INQUIRE_INTERNAL_UNIT}: +Scalar default-integer constant, used by @code{INQUIRE} for the +IOSTAT= specifier to denote an that a unit number identifies an +internal unit. (Fortran 2008 or later.) + @item @code{NUMERIC_STORAGE_SIZE}: The size in bits of the numeric storage unit. @@ -11278,10 +11334,29 @@ The size in bits of the numeric storage unit. Identifies the preconnected unit identified by the asterisk (@code{*}) in @code{WRITE} statement. -@item @code{REAL32}, @code{REAL64}, @code{REAL128} +@item @code{REAL32}, @code{REAL64}, @code{REAL128}: Kind type parameters to specify a REAL type with a storage size of 32, 64, and 128 bits. It is negative if a target platform -does not support the particular kind. +does not support the particular kind. (Fortran 2008 or later.) + +@item @code{STAT_LOCKED}: +Scalar default-integer constant used as STAT= return value by @code{LOCK} to +denote that the lock variable is locked by the executing image. (Fortran 2008 +or later.) + +@item @code{STAT_LOCKED_OTHER_IMAGE}: +Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to +denote that the lock variable is locked by another image. (Fortran 2008 or +later.) + +@item @code{STAT_STOPPED_IMAGE}: +Positive, scalar default-integer constant used as STAT= return value if the +argument in the statement requires synchronisation with an image, which has +initiated the termination of the execution. (Fortran 2008 or later.) + +@item @code{STAT_UNLOCKED}: +Scalar default-integer constant used as STAT= return value by @code{UNLOCK} to +denote that the lock variable is unlocked. (Fortran 2008 or later.) @end table diff --git a/gcc/fortran/iso-fortran-env.def b/gcc/fortran/iso-fortran-env.def index fa6071f..6c009f1 100644 --- a/gcc/fortran/iso-fortran-env.def +++ b/gcc/fortran/iso-fortran-env.def @@ -1,4 +1,4 @@ -/* Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc. +/* Copyright (C) 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. This file is part of GCC. @@ -25,6 +25,10 @@ along with GCC; see the file COPYING3. If not see -- the value it has -- the standard that supports this type */ +NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_INT_KIND, "atomic_int_kind", \ + gfc_default_integer_kind, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_ATOMIC_LOGICAL_KIND, "atomic_logical_kind", \ + gfc_default_logical_kind, GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_CHARACTER_STORAGE_SIZE, "character_storage_size", \ gfc_character_storage_size, GFC_STD_F2003) NAMED_INTCST (ISOFORTRANENV_ERROR_UNIT, "error_unit", GFC_STDERR_UNIT_NUMBER, \ @@ -45,6 +49,9 @@ NAMED_INTCST (ISOFORTRANENV_IOSTAT_END, "iostat_end", LIBERROR_END, \ GFC_STD_F2003) NAMED_INTCST (ISOFORTRANENV_IOSTAT_EOR, "iostat_eor", LIBERROR_EOR, \ GFC_STD_F2003) +NAMED_INTCST (ISOFORTRANENV_IOSTAT_INQUIRE_INTERNAL_UNIT, \ + "iostat_inquire_internal_unit", GFC_INQUIRE_INTERNAL_UNIT, \ + GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_NUMERIC_STORAGE_SIZE, "numeric_storage_size", \ gfc_numeric_storage_size, GFC_STD_F2003) NAMED_INTCST (ISOFORTRANENV_OUTPUT_UNIT, "output_unit", GFC_STDOUT_UNIT_NUMBER, \ @@ -55,3 +62,13 @@ NAMED_INTCST (ISOFORTRANENV_REAL64, "real64", \ gfc_get_real_kind_from_width_isofortranenv (64), GFC_STD_F2008) NAMED_INTCST (ISOFORTRANENV_REAL128, "real128", \ gfc_get_real_kind_from_width_isofortranenv (128), GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED, "stat_locked", \ + GFC_STAT_LOCKED, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_LOCKED_OTHER_IMAGE, \ + "stat_locked_other_image", \ + GFC_STAT_LOCKED_OTHER_IMAGE, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_STOPPED_IMAGE, "stat_stopped_image", \ + GFC_STAT_STOPPED_IMAGE, GFC_STD_F2008) +NAMED_INTCST (ISOFORTRANENV_FILE_STAT_UNLOCKED, "stat_unlocked", \ + GFC_STAT_UNLOCKED, GFC_STD_F2008) + diff --git a/gcc/fortran/libgfortran.h b/gcc/fortran/libgfortran.h index c39f54b..b612bd4 100644 --- a/gcc/fortran/libgfortran.h +++ b/gcc/fortran/libgfortran.h @@ -1,5 +1,5 @@ /* Header file to the Fortran front-end and runtime library - Copyright (C) 2007, 2008, 2009 Free Software Foundation, Inc. + Copyright (C) 2007, 2008, 2009, 2010 Free Software Foundation, Inc. This file is part of GCC. @@ -95,6 +95,15 @@ typedef enum } libgfortran_error_codes; +typedef enum +{ + GFC_STAT_UNLOCKED = 0, + GFC_STAT_LOCKED, + GFC_STAT_LOCKED_OTHER_IMAGE, + GFC_STAT_STOPPED_IMAGE, + GFC_INQUIRE_INTERNAL_UNIT /* Must be different from STAT_STOPPED_IMAGE. */ +} +libgfortran_stat_codes; /* Default unit number for preconnected standard input and output. */ #define GFC_STDIN_UNIT_NUMBER 5 diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c index c67427c..0d8518b 100644 --- a/gcc/fortran/match.c +++ b/gcc/fortran/match.c @@ -1,6 +1,6 @@ /* Matching subroutines in all sizes, shapes and colors. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 - Free Software Foundation, Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, + 2010 Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. @@ -949,6 +949,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) locus start; match m; + e1 = e2 = e3 = NULL; + /* Match the start of an iterator without affecting the symbol table. */ start = gfc_current_locus; @@ -962,9 +964,12 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) if (m != MATCH_YES) return MATCH_NO; - gfc_match_char ('='); - - e1 = e2 = e3 = NULL; + /* F2008, C617 & C565. */ + if (var->symtree->n.sym->attr.codimension) + { + gfc_error ("Loop variable at %C cannot be a coarray"); + goto cleanup; + } if (var->ref != NULL) { @@ -979,6 +984,8 @@ gfc_match_iterator (gfc_iterator *iter, int init_flag) goto cleanup; } + gfc_match_char ('='); + var->symtree->n.sym->attr.implied_index = 1; m = init_flag ? gfc_match_init_expr (&e1) : gfc_match_expr (&e1); @@ -1547,6 +1554,7 @@ gfc_match_if (gfc_statement *if_type) match ("cycle", gfc_match_cycle, ST_CYCLE) match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE) match ("end file", gfc_match_endfile, ST_END_FILE) + match ("error stop", gfc_match_error_stop, ST_ERROR_STOP) match ("exit", gfc_match_exit, ST_EXIT) match ("flush", gfc_match_flush, ST_FLUSH) match ("forall", match_simple_forall, ST_FORALL) @@ -1562,6 +1570,9 @@ gfc_match_if (gfc_statement *if_type) match ("rewind", gfc_match_rewind, ST_REWIND) match ("stop", gfc_match_stop, ST_STOP) match ("wait", gfc_match_wait, ST_WAIT) + match ("sync all", gfc_match_sync_all, ST_SYNC_CALL); + match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); + match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); match ("where", match_simple_where, ST_WHERE) match ("write", gfc_match_write, ST_WRITE) @@ -1708,6 +1719,53 @@ gfc_free_iterator (gfc_iterator *iter, int flag) } +/* Match a CRITICAL statement. */ +match +gfc_match_critical (void) +{ + gfc_st_label *label = NULL; + + if (gfc_match_label () == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match (" critical") != MATCH_YES) + return MATCH_NO; + + if (gfc_match_st_label (&label) == MATCH_ERROR) + return MATCH_ERROR; + + if (gfc_match_eos () != MATCH_YES) + { + gfc_syntax_error (ST_CRITICAL); + return MATCH_ERROR; + } + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement CRITICAL at %C in PURE procedure"); + return MATCH_ERROR; + } + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CRITICAL statement at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Nested CRITICAL block at %C"); + return MATCH_ERROR; + } + + new_st.op = EXEC_CRITICAL; + + if (label != NULL + && gfc_reference_st_label (label, ST_LABEL_TARGET) == FAILURE) + return MATCH_ERROR; + + return MATCH_YES; +} + + /* Match a BLOCK statement. */ match @@ -1871,6 +1929,12 @@ match_exit_cycle (gfc_statement st, gfc_exec_op op) break; else if (o == NULL && p->state == COMP_OMP_STRUCTURED_BLOCK) o = p; + else if (p->state == COMP_CRITICAL) + { + gfc_error("%s statement at %C leaves CRITICAL construct", + gfc_ascii_statement (st)); + return MATCH_ERROR; + } if (p == NULL) { @@ -1930,7 +1994,7 @@ gfc_match_cycle (void) } -/* Match a number or character constant after a STOP or PAUSE statement. */ +/* Match a number or character constant after an (ALL) STOP or PAUSE statement. */ static match gfc_match_stopcode (gfc_statement st) @@ -1978,7 +2042,27 @@ gfc_match_stopcode (gfc_statement st) goto cleanup; } - new_st.op = st == ST_STOP ? EXEC_STOP : EXEC_PAUSE; + if (st == ST_STOP && gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement STOP at %C in CRITICAL block"); + return MATCH_ERROR; + } + + switch (st) + { + case ST_STOP: + new_st.op = EXEC_STOP; + break; + case ST_ERROR_STOP: + new_st.op = EXEC_ERROR_STOP; + break; + case ST_PAUSE: + new_st.op = EXEC_PAUSE; + break; + default: + gcc_unreachable (); + } + new_st.expr1 = e; new_st.ext.stop_code = stop_code; @@ -2022,6 +2106,193 @@ gfc_match_stop (void) } +/* Match the ERROR STOP statement. */ + +match +gfc_match_error_stop (void) +{ + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: ERROR STOP statement at %C") + == FAILURE) + return MATCH_ERROR; + + return gfc_match_stopcode (ST_ERROR_STOP); +} + + +/* Match SYNC ALL/IMAGES/MEMORY statement. Syntax: + SYNC ALL [(sync-stat-list)] + SYNC MEMORY [(sync-stat-list)] + SYNC IMAGES (image-set [, sync-stat-list] ) + with sync-stat is int-expr or *. */ + +static match +sync_statement (gfc_statement st) +{ + match m; + gfc_expr *tmp, *imageset, *stat, *errmsg; + bool saw_stat, saw_errmsg; + + tmp = imageset = stat = errmsg = NULL; + saw_stat = saw_errmsg = false; + + if (gfc_pure (NULL)) + { + gfc_error ("Image control statement SYNC at %C in PURE procedure"); + return MATCH_ERROR; + } + + if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: SYNC statement at %C") + == FAILURE) + return MATCH_ERROR; + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement SYNC at %C in CRITICAL block"); + return MATCH_ERROR; + } + + if (gfc_match_eos () == MATCH_YES) + { + if (st == ST_SYNC_IMAGES) + goto syntax; + goto done; + } + + if (gfc_match_char ('(') != MATCH_YES) + goto syntax; + + if (st == ST_SYNC_IMAGES) + { + /* Denote '*' as imageset == NULL. */ + m = gfc_match_char ('*'); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + if (gfc_match ("%e", &imageset) != MATCH_YES) + goto syntax; + } + m = gfc_match_char (','); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_NO) + { + m = gfc_match_char (')'); + if (m == MATCH_YES) + goto done; + goto syntax; + } + } + + for (;;) + { + m = gfc_match (" stat = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_stat) + { + gfc_error ("Redundant STAT tag found at %L ", &tmp->where); + goto cleanup; + } + stat = tmp; + saw_stat = true; + + if (gfc_match_char (',') == MATCH_YES) + continue; + } + + m = gfc_match (" errmsg = %v", &tmp); + if (m == MATCH_ERROR) + goto syntax; + if (m == MATCH_YES) + { + if (saw_errmsg) + { + gfc_error ("Redundant ERRMSG tag found at %L ", &tmp->where); + goto cleanup; + } + errmsg = tmp; + saw_errmsg = true; + + if (gfc_match_char (',') == MATCH_YES) + continue; + } + + gfc_gobble_whitespace (); + + if (gfc_peek_char () == ')') + break; + + goto syntax; + } + + if (gfc_match (" )%t") != MATCH_YES) + goto syntax; + +done: + switch (st) + { + case ST_SYNC_ALL: + new_st.op = EXEC_SYNC_ALL; + break; + case ST_SYNC_IMAGES: + new_st.op = EXEC_SYNC_IMAGES; + break; + case ST_SYNC_MEMORY: + new_st.op = EXEC_SYNC_MEMORY; + break; + default: + gcc_unreachable (); + } + + new_st.expr1 = imageset; + new_st.expr2 = stat; + new_st.expr3 = errmsg; + + return MATCH_YES; + +syntax: + gfc_syntax_error (st); + +cleanup: + gfc_free_expr (tmp); + gfc_free_expr (imageset); + gfc_free_expr (stat); + gfc_free_expr (errmsg); + + return MATCH_ERROR; +} + + +/* Match SYNC ALL statement. */ + +match +gfc_match_sync_all (void) +{ + return sync_statement (ST_SYNC_ALL); +} + + +/* Match SYNC IMAGES statement. */ + +match +gfc_match_sync_images (void) +{ + return sync_statement (ST_SYNC_IMAGES); +} + + +/* Match SYNC MEMORY statement. */ + +match +gfc_match_sync_memory (void) +{ + return sync_statement (ST_SYNC_MEMORY); +} + + /* Match a CONTINUE statement. */ match @@ -2850,6 +3121,13 @@ gfc_match_return (void) gfc_compile_state s; e = NULL; + + if (gfc_find_state (COMP_CRITICAL) == SUCCESS) + { + gfc_error ("Image control statement RETURN at %C in CRITICAL block"); + return MATCH_ERROR; + } + if (gfc_match_eos () == MATCH_YES) goto done; @@ -3291,7 +3569,7 @@ gfc_match_common (void) /* Deal with an optional array specification after the symbol name. */ - m = gfc_match_array_spec (&as); + m = gfc_match_array_spec (&as, true, true); if (m == MATCH_ERROR) goto cleanup; diff --git a/gcc/fortran/match.h b/gcc/fortran/match.h index 3c0f1c0..319a02e 100644 --- a/gcc/fortran/match.h +++ b/gcc/fortran/match.h @@ -69,15 +69,20 @@ match gfc_match_assignment (void); match gfc_match_if (gfc_statement *); match gfc_match_else (void); match gfc_match_elseif (void); +match gfc_match_critical (void); match gfc_match_block (void); match gfc_match_do (void); match gfc_match_cycle (void); match gfc_match_exit (void); match gfc_match_pause (void); match gfc_match_stop (void); +match gfc_match_error_stop (void); match gfc_match_continue (void); match gfc_match_assign (void); match gfc_match_goto (void); +match gfc_match_sync_all (void); +match gfc_match_sync_images (void); +match gfc_match_sync_memory (void); match gfc_match_allocate (void); match gfc_match_nullify (void); @@ -163,6 +168,7 @@ void gfc_set_constant_character_len (int, gfc_expr *, int); /* Matchers for attribute declarations. */ match gfc_match_allocatable (void); match gfc_match_asynchronous (void); +match gfc_match_codimension (void); match gfc_match_dimension (void); match gfc_match_external (void); match gfc_match_gcc_attributes (void); @@ -209,8 +215,8 @@ gfc_try gfc_reduce_init_expr (gfc_expr *expr); match gfc_match_init_expr (gfc_expr **); /* array.c. */ -match gfc_match_array_spec (gfc_array_spec **); -match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int); +match gfc_match_array_spec (gfc_array_spec **, bool, bool); +match gfc_match_array_ref (gfc_array_ref *, gfc_array_spec *, int, int); match gfc_match_array_constructor (gfc_expr **); /* interface.c. */ diff --git a/gcc/fortran/module.c b/gcc/fortran/module.c index 0fc1921..5c574bb 100644 --- a/gcc/fortran/module.c +++ b/gcc/fortran/module.c @@ -78,7 +78,7 @@ along with GCC; see the file COPYING3. If not see /* Don't put any single quote (') in MOD_VERSION, if yout want it to be recognized. */ -#define MOD_VERSION "4" +#define MOD_VERSION "5" /* Structure that describes a position within a module file. */ @@ -1672,7 +1672,8 @@ typedef enum AB_CRAY_POINTER, AB_CRAY_POINTEE, AB_THREADPRIVATE, AB_ALLOC_COMP, AB_POINTER_COMP, AB_PRIVATE_COMP, AB_VALUE, AB_VOLATILE, AB_PROTECTED, AB_IS_BIND_C, AB_IS_C_INTEROP, AB_IS_ISO_C, AB_ABSTRACT, AB_ZERO_COMP, - AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS + AB_IS_CLASS, AB_PROCEDURE, AB_PROC_POINTER, AB_ASYNCHRONOUS, AB_CODIMENSION, + AB_COARRAY_COMP } ab_attribute; @@ -1681,6 +1682,7 @@ static const mstring attr_bits[] = minit ("ALLOCATABLE", AB_ALLOCATABLE), minit ("ASYNCHRONOUS", AB_ASYNCHRONOUS), minit ("DIMENSION", AB_DIMENSION), + minit ("CODIMENSION", AB_CODIMENSION), minit ("EXTERNAL", AB_EXTERNAL), minit ("INTRINSIC", AB_INTRINSIC), minit ("OPTIONAL", AB_OPTIONAL), @@ -1708,6 +1710,7 @@ static const mstring attr_bits[] = minit ("IS_ISO_C", AB_IS_ISO_C), minit ("VALUE", AB_VALUE), minit ("ALLOC_COMP", AB_ALLOC_COMP), + minit ("COARRAY_COMP", AB_COARRAY_COMP), minit ("POINTER_COMP", AB_POINTER_COMP), minit ("PRIVATE_COMP", AB_PRIVATE_COMP), minit ("ZERO_COMP", AB_ZERO_COMP), @@ -1798,6 +1801,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_ASYNCHRONOUS, attr_bits); if (attr->dimension) MIO_NAME (ab_attribute) (AB_DIMENSION, attr_bits); + if (attr->codimension) + MIO_NAME (ab_attribute) (AB_CODIMENSION, attr_bits); if (attr->external) MIO_NAME (ab_attribute) (AB_EXTERNAL, attr_bits); if (attr->intrinsic) @@ -1864,6 +1869,8 @@ mio_symbol_attribute (symbol_attribute *attr) MIO_NAME (ab_attribute) (AB_POINTER_COMP, attr_bits); if (attr->private_comp) MIO_NAME (ab_attribute) (AB_PRIVATE_COMP, attr_bits); + if (attr->coarray_comp) + MIO_NAME (ab_attribute) (AB_COARRAY_COMP, attr_bits); if (attr->zero_comp) MIO_NAME (ab_attribute) (AB_ZERO_COMP, attr_bits); if (attr->is_class) @@ -1897,6 +1904,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_DIMENSION: attr->dimension = 1; break; + case AB_CODIMENSION: + attr->codimension = 1; + break; case AB_EXTERNAL: attr->external = 1; break; @@ -1984,6 +1994,9 @@ mio_symbol_attribute (symbol_attribute *attr) case AB_ALLOC_COMP: attr->alloc_comp = 1; break; + case AB_COARRAY_COMP: + attr->coarray_comp = 1; + break; case AB_POINTER_COMP: attr->pointer_comp = 1; break; @@ -2131,9 +2144,10 @@ mio_array_spec (gfc_array_spec **asp) } mio_integer (&as->rank); + mio_integer (&as->corank); as->type = MIO_NAME (array_type) (as->type, array_spec_types); - for (i = 0; i < as->rank; i++) + for (i = 0; i < as->rank + as->corank; i++) { mio_expr (&as->lower[i]); mio_expr (&as->upper[i]); @@ -5401,6 +5415,11 @@ use_iso_fortran_env_module (void) gfc_option.flag_default_integer ? "-fdefault-integer-8" : "-fdefault-real-8"); + if (gfc_notify_std (symbol[i].standard, "The symbol '%s', referrenced " + "at %C, is not in the selected standard", + symbol[i].name) == FAILURE) + continue; + create_int_parameter (u->local_name[0] ? u->local_name : symbol[i].name, symbol[i].value, mod, INTMOD_ISO_FORTRAN_ENV, @@ -5411,6 +5430,10 @@ use_iso_fortran_env_module (void) for (i = 0; symbol[i].name; i++) { local_name = NULL; + + if ((gfc_option.allow_std & symbol[i].standard) == 0) + break; + for (u = gfc_rename_list; u; u = u->next) { if (strcmp (symbol[i].name, u->use_name) == 0) diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 9e8a123..190148c 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1,6 +1,6 @@ /* Main parser. Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, - 2009 + 2009, 2010 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -138,6 +138,7 @@ decode_specification_statement (void) break; case 'c': + match ("codimension", gfc_match_codimension, ST_ATTR_DECL); break; case 'd': @@ -291,9 +292,9 @@ decode_statement (void) gfc_undo_symbols (); gfc_current_locus = old_locus; - /* Check for the IF, DO, SELECT, WHERE, FORALL and BLOCK statements, which - might begin with a block label. The match functions for these - statements are unusual in that their keyword is not seen before + /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, and BLOCK + statements, which might begin with a block label. The match functions for + these statements are unusual in that their keyword is not seen before the matcher is called. */ if (gfc_match_if (&st) == MATCH_YES) @@ -311,8 +312,9 @@ decode_statement (void) gfc_undo_symbols (); gfc_current_locus = old_locus; - match (NULL, gfc_match_block, ST_BLOCK); match (NULL, gfc_match_do, ST_DO); + match (NULL, gfc_match_block, ST_BLOCK); + match (NULL, gfc_match_critical, ST_CRITICAL); match (NULL, gfc_match_select, ST_SELECT_CASE); match (NULL, gfc_match_select_type, ST_SELECT_TYPE); @@ -348,6 +350,7 @@ decode_statement (void) match ("common", gfc_match_common, ST_COMMON); match ("contains", gfc_match_eos, ST_CONTAINS); match ("class", gfc_match_class_is, ST_CLASS_IS); + match ("codimension", gfc_match_codimension, ST_ATTR_DECL); break; case 'd': @@ -362,6 +365,7 @@ decode_statement (void) match ("else", gfc_match_else, ST_ELSE); match ("else where", gfc_match_elsewhere, ST_ELSEWHERE); match ("else if", gfc_match_elseif, ST_ELSEIF); + match ("error stop", gfc_match_error_stop, ST_ERROR_STOP); match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); if (gfc_match_end (&st) == MATCH_YES) @@ -432,6 +436,9 @@ decode_statement (void) match ("sequence", gfc_match_eos, ST_SEQUENCE); match ("stop", gfc_match_stop, ST_STOP); match ("save", gfc_match_save, ST_ATTR_DECL); + match ("sync all", gfc_match_sync_all, ST_SYNC_ALL); + match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES); + match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY); break; case 't': @@ -936,7 +943,8 @@ next_statement (void) case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ - case ST_OMP_BARRIER: case ST_OMP_TASKWAIT + case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \ + case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY /* Statements that mark other executable statements. */ @@ -948,7 +956,7 @@ next_statement (void) case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \ case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \ - case ST_OMP_TASK + case ST_OMP_TASK: case ST_CRITICAL /* Declaration statements */ @@ -1082,6 +1090,7 @@ check_statement_label (gfc_statement st) case ST_ENDDO: case ST_ENDIF: case ST_END_SELECT: + case ST_END_CRITICAL: case_executable: case_exec_markers: type = ST_LABEL_TARGET; @@ -1176,6 +1185,9 @@ gfc_ascii_statement (gfc_statement st) case ST_CONTAINS: p = "CONTAINS"; break; + case ST_CRITICAL: + p = "CRITICAL"; + break; case ST_CYCLE: p = "CYCLE"; break; @@ -1209,6 +1221,9 @@ gfc_ascii_statement (gfc_statement st) case ST_END_BLOCK_DATA: p = "END BLOCK DATA"; break; + case ST_END_CRITICAL: + p = "END CRITICAL"; + break; case ST_ENDDO: p = "END DO"; break; @@ -1251,6 +1266,9 @@ gfc_ascii_statement (gfc_statement st) case ST_EQUIVALENCE: p = "EQUIVALENCE"; break; + case ST_ERROR_STOP: + p = "ERROR STOP"; + break; case ST_EXIT: p = "EXIT"; break; @@ -1339,6 +1357,15 @@ gfc_ascii_statement (gfc_statement st) case ST_STOP: p = "STOP"; break; + case ST_SYNC_ALL: + p = "SYNC ALL"; + break; + case ST_SYNC_IMAGES: + p = "SYNC IMAGES"; + break; + case ST_SYNC_MEMORY: + p = "SYNC MEMORY"; + break; case ST_SUBROUTINE: p = "SUBROUTINE"; break; @@ -1555,6 +1582,7 @@ accept_statement (gfc_statement st) case ST_ENDIF: case ST_END_SELECT: + case ST_END_CRITICAL: if (gfc_statement_label != NULL) { new_st.op = EXEC_END_BLOCK; @@ -2086,6 +2114,11 @@ endType: && c->ts.u.derived->attr.proc_pointer_comp)) sym->attr.proc_pointer_comp = 1; + /* Looking for coarray components. */ + if (c->attr.codimension + || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable)) + sym->attr.coarray_comp = 1; + /* Look for private components. */ if (sym->component_access == ACCESS_PRIVATE || c->attr.access == ACCESS_PRIVATE @@ -3047,6 +3080,61 @@ check_do_closure (void) static void parse_progunit (gfc_statement); +/* Parse a CRITICAL block. */ + +static void +parse_critical_block (void) +{ + gfc_code *top, *d; + gfc_state_data s; + gfc_statement st; + + s.ext.end_do_label = new_st.label1; + + accept_statement (ST_CRITICAL); + top = gfc_state_stack->tail; + + push_state (&s, COMP_CRITICAL, gfc_new_block); + + d = add_statement (); + d->op = EXEC_CRITICAL; + top->block = d; + + do + { + st = parse_executable (ST_NONE); + + switch (st) + { + case ST_NONE: + unexpected_eof (); + break; + + case ST_END_CRITICAL: + if (s.ext.end_do_label != NULL + && s.ext.end_do_label != gfc_statement_label) + gfc_error_now ("Statement label in END CRITICAL at %C does not " + "match CRITIAL label"); + + if (gfc_statement_label != NULL) + { + new_st.op = EXEC_NOP; + add_statement (); + } + break; + + default: + unexpected_statement (st); + break; + } + } + while (st != ST_END_CRITICAL); + + pop_state (); + accept_statement (st); +} + + /* Set up the local namespace for a BLOCK construct. */ gfc_namespace* @@ -3472,9 +3560,12 @@ parse_executable (gfc_statement st) case ST_CYCLE: case ST_PAUSE: case ST_STOP: + case ST_ERROR_STOP: case ST_END_SUBROUTINE: case ST_DO: + case ST_CRITICAL: + case ST_BLOCK: case ST_FORALL: case ST_WHERE: case ST_SELECT_CASE: @@ -3522,6 +3613,10 @@ parse_executable (gfc_statement st) return ST_IMPLIED_ENDDO; break; + case ST_CRITICAL: + parse_critical_block (); + break; + case ST_WHERE_BLOCK: parse_where_block (); break; diff --git a/gcc/fortran/parse.h b/gcc/fortran/parse.h index e0a2969..5da9939 100644 --- a/gcc/fortran/parse.h +++ b/gcc/fortran/parse.h @@ -32,7 +32,7 @@ typedef enum COMP_BLOCK_DATA, COMP_INTERFACE, COMP_DERIVED, COMP_DERIVED_CONTAINS, COMP_BLOCK, COMP_IF, COMP_DO, COMP_SELECT, COMP_FORALL, COMP_WHERE, COMP_CONTAINS, COMP_ENUM, - COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK + COMP_SELECT_TYPE, COMP_OMP_STRUCTURED_BLOCK, COMP_CRITICAL } gfc_compile_state; diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c index 113729f..34b6874 100644 --- a/gcc/fortran/primary.c +++ b/gcc/fortran/primary.c @@ -1746,7 +1746,25 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail = NULL; gfc_gobble_whitespace (); + + 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); + return MATCH_ERROR; + } + } + if ((equiv_flag && gfc_peek_ascii_char () == '(') + || gfc_peek_ascii_char () == '[' || sym->attr.codimension || (sym->attr.dimension && !sym->attr.proc_pointer && !gfc_is_proc_ptr_comp (primary, NULL) && !(gfc_matching_procptr_assignment @@ -1761,7 +1779,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail->type = REF_ARRAY; m = gfc_match_array_ref (&tail->u.ar, equiv_flag ? NULL : sym->as, - equiv_flag); + equiv_flag, sym->as ? sym->as->corank : 0); if (m != MATCH_YES) return m; @@ -1771,7 +1789,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail = extend_ref (primary, tail); tail->type = REF_ARRAY; - m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag); + m = gfc_match_array_ref (&tail->u.ar, NULL, equiv_flag, 0); if (m != MATCH_YES) return m; } @@ -1881,7 +1899,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, tail = extend_ref (primary, tail); tail->type = REF_ARRAY; - m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag); + m = gfc_match_array_ref (&tail->u.ar, component->as, equiv_flag, + component->as->corank); if (m != MATCH_YES) return m; } @@ -1894,7 +1913,8 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag, m = gfc_match_array_ref (&tail->u.ar, component->ts.u.derived->components->as, - equiv_flag); + equiv_flag, + component->ts.u.derived->components->as->corank); if (m != MATCH_YES) return m; } @@ -1949,6 +1969,13 @@ check_substring: } } + /* F2008, C727. */ + if (primary->expr_type == EXPR_PPC && gfc_is_coindexed (primary)) + { + gfc_error ("Coindexed procedure-pointer component at %C"); + return MATCH_ERROR; + } + return MATCH_YES; } @@ -2023,7 +2050,9 @@ gfc_variable_attr (gfc_expr *expr, gfc_typespec *ts) break; case AR_ELEMENT: - allocatable = pointer = 0; + /* Handle coarrays. */ + if (ref->u.ar.dimen > 0) + allocatable = pointer = 0; break; case AR_UNKNOWN: @@ -2349,6 +2378,15 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result, if (m == MATCH_ERROR) goto cleanup; + /* F2008, R457/C725, for PURE C1283. */ + if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val)) + { + gfc_error ("Coindexed expression to pointer component '%s' in " + "structure constructor at %C!", comp_tail->name); + goto cleanup; + } + + /* If not explicitly a parent constructor, gather up the components and build one. */ if (comp && comp == sym->components diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 24ec7a8..902c7be 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -77,6 +77,8 @@ static int current_entry_id; /* We use bitmaps to determine if a branch target is valid. */ static bitmap_obstack labels_obstack; +static bool inquiry_argument = false; + int gfc_is_formal_arg (void) { @@ -258,6 +260,14 @@ resolve_formal_arglist (gfc_symbol *proc) if (gfc_elemental (proc)) { + /* F2008, C1289. */ + if (sym->attr.codimension) + { + gfc_error ("Coarray dummy argument '%s' at %L to elemental " + "procedure", sym->name, &sym->declared_at); + continue; + } + if (sym->as != NULL) { gfc_error ("Argument '%s' of elemental procedure at %L must " @@ -931,6 +941,17 @@ resolve_structure_cons (gfc_expr *expr) "component '%s' at %L in PURE procedure", comp->name, &cons->expr->where); } + + /* F2003, C1272 (3). */ + if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE + && (gfc_impure_variable (cons->expr->symtree->n.sym) + || gfc_is_coindexed (cons->expr))) + { + t = FAILURE; + gfc_error ("Invalid expression in the derived type constructor for pointer " + "component '%s' at %L in PURE procedure", comp->name, + &cons->expr->where); + } } return t; @@ -955,7 +976,7 @@ was_declared (gfc_symbol *sym) if (a.allocatable || a.dimension || a.dummy || a.external || a.intrinsic || a.optional || a.pointer || a.save || a.target || a.volatile_ || a.value || a.access != ACCESS_UNKNOWN || a.intent != INTENT_UNKNOWN - || a.asynchronous) + || a.asynchronous || a.codimension) return 1; return 0; @@ -1311,7 +1332,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, gfc_expr *e; int save_need_full_assumed_size; gfc_component *comp; - + for (; arg; arg = arg->next) { e = arg->expr; @@ -1541,6 +1562,15 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype, } } } + + /* Fortran 2008, C1237. */ + if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e) + && gfc_has_ultimate_pointer (e)) + { + gfc_error ("Coindexed actual argument at %L with ultimate pointer " + "component", &e->where); + return FAILURE; + } } return SUCCESS; @@ -2582,11 +2612,16 @@ resolve_function (gfc_expr *expr) if (expr->symtree && expr->symtree->n.sym) p = expr->symtree->n.sym->attr.proc; + if (expr->value.function.isym && expr->value.function.isym->inquiry) + inquiry_argument = true; no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL; + if (resolve_actual_arglist (expr->value.function.actual, p, no_formal_args) == FAILURE) return FAILURE; + inquiry_argument = false; + /* Need to setup the call to the correct c_associated, depending on the number of cptrs to user gives to compare. */ if (sym && sym->attr.is_iso_c == 1) @@ -3747,6 +3782,17 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) { mpz_t last_value; + if (ar->dimen_type[i] == DIMEN_STAR) + { + gcc_assert (ar->stride[i] == NULL); + /* This implies [*] as [*:] and [*:3] are not possible. */ + if (ar->start[i] == NULL) + { + gcc_assert (ar->end[i] == NULL); + return SUCCESS; + } + } + /* Given start, end and stride values, calculate the minimum and maximum referenced indexes. */ @@ -3755,21 +3801,37 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as) case DIMEN_VECTOR: break; + case DIMEN_STAR: + /* Check only the lower bound as the upper one is '*'. */ case DIMEN_ELEMENT: if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT) { - gfc_warning ("Array reference at %L is out of bounds " - "(%ld < %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->lower[i]->value.integer), i+1); + if (i < as->rank) + gfc_warning ("Array reference at %L is out of bounds " + "(%ld < %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->lower[i]->value.integer), i+1); + else + gfc_warning ("Array reference at %L is out of bounds " + "(%ld < %ld) in codimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->lower[i]->value.integer), + i + 1 - as->rank); return SUCCESS; } if (compare_bound (ar->start[i], as->upper[i]) == CMP_GT) { - gfc_warning ("Array reference at %L is out of bounds " - "(%ld > %ld) in dimension %d", &ar->c_where[i], - mpz_get_si (ar->start[i]->value.integer), - mpz_get_si (as->upper[i]->value.integer), i+1); + if (i < as->rank) + gfc_warning ("Array reference at %L is out of bounds " + "(%ld > %ld) in dimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->upper[i]->value.integer), i+1); + else + gfc_warning ("Array reference at %L is out of bounds " + "(%ld > %ld) in codimension %d", &ar->c_where[i], + mpz_get_si (ar->start[i]->value.integer), + mpz_get_si (as->upper[i]->value.integer), + i + 1 - as->rank); return SUCCESS; } @@ -3889,10 +3951,32 @@ compare_spec_to_ref (gfc_array_ref *ar) return FAILURE; } + /* ar->codimen == 0 is a local array. */ + if (as->corank != ar->codimen && ar->codimen != 0) + { + gfc_error ("Coindex rank mismatch in array reference at %L (%d/%d)", + &ar->where, ar->codimen, as->corank); + return FAILURE; + } + for (i = 0; i < as->rank; i++) if (check_dimension (i, ar, as) == FAILURE) return FAILURE; + /* Local access has no coarray spec. */ + if (ar->codimen != 0) + for (i = as->rank; i < as->rank + as->corank; i++) + { + if (ar->dimen_type[i] != DIMEN_ELEMENT && !ar->in_allocate) + { + gfc_error ("Coindex of codimension %d must be a scalar at %L", + i + 1 - as->rank, &ar->where); + return FAILURE; + } + if (check_dimension (i, ar, as) == FAILURE) + return FAILURE; + } + return SUCCESS; } @@ -4061,7 +4145,7 @@ resolve_array_ref (gfc_array_ref *ar) int i, check_scalar; gfc_expr *e; - for (i = 0; i < ar->dimen; i++) + for (i = 0; i < ar->dimen + ar->codimen; i++) { check_scalar = ar->dimen_type[i] == DIMEN_RANGE; @@ -4095,6 +4179,9 @@ resolve_array_ref (gfc_array_ref *ar) } } + if (ar->type == AR_FULL && ar->as->rank == 0) + ar->type = AR_ELEMENT; + /* If the reference type is unknown, figure out what kind it is. */ if (ar->type == AR_UNKNOWN) @@ -4299,6 +4386,13 @@ resolve_ref (gfc_expr *expr) switch (ref->u.ar.type) { case AR_FULL: + /* Coarray scalar. */ + if (ref->u.ar.as->rank == 0) + { + current_part_dimension = 0; + break; + } + /* Fall through. */ case AR_SECTION: current_part_dimension = 1; break; @@ -4568,6 +4662,47 @@ resolve_procedure: if (t == SUCCESS && resolve_procedure_expression (e) == FAILURE) t = FAILURE; + /* F2008, C617 and C1229. */ + if (!inquiry_argument && (e->ts.type == BT_CLASS || e->ts.type == BT_DERIVED) + && gfc_is_coindexed (e)) + { + gfc_ref *ref, *ref2 = NULL; + + if (e->ts.type == BT_CLASS) + { + gfc_error ("Polymorphic subobject of coindexed object at %L", + &e->where); + t = FAILURE; + } + + for (ref = e->ref; ref; ref = ref->next) + { + if (ref->type == REF_COMPONENT) + ref2 = ref; + if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0) + break; + } + + for ( ; ref; ref = ref->next) + if (ref->type == REF_COMPONENT) + break; + + /* Expression itself is coindexed object. */ + if (ref == NULL) + { + gfc_component *c; + c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components; + for ( ; c; c = c->next) + if (c->attr.allocatable && c->ts.type == BT_CLASS) + { + gfc_error ("Coindexed object with polymorphic allocatable " + "subcomponent at %L", &e->where); + t = FAILURE; + break; + } + } + } + return t; } @@ -5155,7 +5290,7 @@ resolve_compcall (gfc_expr* e, bool fcn, bool class_members) of f03 OOP. As soon as vtables are in place and contain pointers to methods, this will no longer be necessary. */ static gfc_expr *list_e; -static void check_class_members (gfc_symbol *); +static gfc_try check_class_members (gfc_symbol *); static gfc_try class_try; static bool fcn_flag; @@ -5164,11 +5299,11 @@ static void check_members (gfc_symbol *derived) { if (derived->attr.flavor == FL_DERIVED) - check_class_members (derived); + (void) check_class_members (derived); } -static void +static gfc_try check_class_members (gfc_symbol *derived) { gfc_expr *e; @@ -5185,7 +5320,7 @@ check_class_members (gfc_symbol *derived) { gfc_error ("no typebound available procedure named '%s' at %L", e->value.compcall.name, &e->where); - return; + return FAILURE; } /* If we have to match a passed class member, force the actual @@ -5195,6 +5330,9 @@ check_class_members (gfc_symbol *derived) if (e->value.compcall.base_object == NULL) e->value.compcall.base_object = extract_compcall_passed_object (e); + if (e->value.compcall.base_object == NULL) + return FAILURE; + if (!derived->attr.abstract) { e->value.compcall.base_object->ts.type = BT_DERIVED; @@ -5232,6 +5370,8 @@ check_class_members (gfc_symbol *derived) /* Burrow down into grandchildren types. */ if (derived->f2k_derived) gfc_traverse_ns (derived->f2k_derived, check_members); + + return SUCCESS; } @@ -5385,7 +5525,9 @@ resolve_typebound_function (gfc_expr* e) class_try = SUCCESS; fcn_flag = true; list_e = gfc_copy_expr (e); - check_class_members (derived); + + if (check_class_members (derived) == FAILURE) + return FAILURE; class_try = (resolve_compcall (e, true, false) == SUCCESS) ? class_try : FAILURE; @@ -5445,7 +5587,9 @@ resolve_typebound_subroutine (gfc_code *code) class_try = SUCCESS; fcn_flag = false; list_e = gfc_copy_expr (code->expr1); - check_class_members (derived); + + if (check_class_members (derived) == FAILURE) + return FAILURE; class_try = (resolve_typebound_call (code) == SUCCESS) ? class_try : FAILURE; @@ -5577,10 +5721,15 @@ gfc_try gfc_resolve_expr (gfc_expr *e) { gfc_try t; + bool inquiry_save; if (e == NULL) return SUCCESS; + inquiry_save = inquiry_argument; + if (e->expr_type != EXPR_VARIABLE) + inquiry_argument = false; + switch (e->expr_type) { case EXPR_OP: @@ -5668,6 +5817,8 @@ gfc_resolve_expr (gfc_expr *e) if (e->ts.type == BT_CHARACTER && t == SUCCESS && !e->ts.u.cl) fixup_charlen (e); + inquiry_argument = inquiry_save; + return t; } @@ -6114,7 +6265,9 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2) static gfc_try resolve_allocate_expr (gfc_expr *e, gfc_code *code) { - int i, pointer, allocatable, dimension, check_intent_in, is_abstract; + int i, pointer, allocatable, dimension, check_intent_in, is_abstract, + coindexed = false; + int codimension; symbol_attribute attr; gfc_ref *ref, *ref2; gfc_array_ref *ar; @@ -6126,8 +6279,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) /* Check INTENT(IN), unless the object is a sub-component of a pointer. */ check_intent_in = 1; + /* Mark the ultimost array component as being in allocate to allow DIMEN_STAR + checking of coarrays. */ + for (ref = e->ref; ref; ref = ref->next) + if (ref->next == NULL) + break; + + if (ref && ref->type == REF_ARRAY) + ref->u.ar.in_allocate = true; + if (gfc_resolve_expr (e) == FAILURE) - return FAILURE; + goto failure; /* Make sure the expression is allocatable or a pointer. If it is pointer, the next-to-last reference must be a pointer. */ @@ -6145,6 +6307,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) attr = gfc_expr_attr (e); pointer = attr.pointer; dimension = attr.dimension; + codimension = attr.codimension; } else { @@ -6153,6 +6316,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = sym->ts.u.derived->components->attr.allocatable; pointer = sym->ts.u.derived->components->attr.pointer; dimension = sym->ts.u.derived->components->attr.dimension; + codimension = sym->ts.u.derived->components->attr.codimension; is_abstract = sym->ts.u.derived->components->attr.abstract; } else @@ -6160,6 +6324,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = sym->attr.allocatable; pointer = sym->attr.pointer; dimension = sym->attr.dimension; + codimension = sym->attr.codimension; } for (ref = e->ref; ref; ref2 = ref, ref = ref->next) @@ -6170,17 +6335,27 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) switch (ref->type) { case REF_ARRAY: + coindexed = coindexed ? true : ref->u.ar.codimen > 0; if (ref->next != NULL) pointer = 0; break; case REF_COMPONENT: + /* F2008, C644. */ + if (gfc_is_coindexed (e)) + { + gfc_error ("Coindexed allocatable object at %L", + &e->where); + goto failure; + } + c = ref->u.c.component; if (c->ts.type == BT_CLASS) { allocatable = c->ts.u.derived->components->attr.allocatable; pointer = c->ts.u.derived->components->attr.pointer; dimension = c->ts.u.derived->components->attr.dimension; + codimension = c->ts.u.derived->components->attr.codimension; is_abstract = c->ts.u.derived->components->attr.abstract; } else @@ -6188,6 +6363,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) allocatable = c->attr.allocatable; pointer = c->attr.pointer; dimension = c->attr.dimension; + codimension = c->attr.codimension; is_abstract = c->attr.abstract; } break; @@ -6204,7 +6380,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { gfc_error ("Allocate-object at %L must be ALLOCATABLE or a POINTER", &e->where); - return FAILURE; + goto failure; } /* Some checks for the SOURCE tag. */ @@ -6215,13 +6391,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) { gfc_error ("Type of entity at %L is type incompatible with " "source-expr at %L", &e->where, &code->expr3->where); - return FAILURE; + goto failure; } /* Check F03:C632 and restriction following Note 6.18. */ if (code->expr3->rank > 0 && conformable_arrays (code->expr3, e) == FAILURE) - return FAILURE; + goto failure; /* Check F03:C633. */ if (code->expr3->ts.kind != e->ts.kind) @@ -6229,7 +6405,7 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gfc_error ("The allocate-object at %L and the source-expr at %L " "shall have the same kind type parameter", &e->where, &code->expr3->where); - return FAILURE; + goto failure; } } else if (is_abstract&& code->ext.alloc.ts.type == BT_UNKNOWN) @@ -6237,14 +6413,14 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) gcc_assert (e->ts.type == BT_CLASS); gfc_error ("Allocating %s of ABSTRACT base type at %L requires a " "type-spec or SOURCE=", sym->name, &e->where); - return FAILURE; + goto failure; } if (check_intent_in && sym->attr.intent == INTENT_IN) { gfc_error ("Cannot allocate INTENT(IN) variable '%s' at %L", sym->name, &e->where); - return FAILURE; + goto failure; } if (!code->expr3) @@ -6277,16 +6453,17 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) } } - if (pointer || dimension == 0) - return SUCCESS; + if (pointer || (dimension == 0 && codimension == 0)) + goto success; /* Make sure the next-to-last reference node is an array specification. */ - if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL) + if (ref2 == NULL || ref2->type != REF_ARRAY || ref2->u.ar.type == AR_FULL + || (dimension && ref2->u.ar.dimen == 0)) { gfc_error ("Array specification required in ALLOCATE statement " "at %L", &e->where); - return FAILURE; + goto failure; } /* Make sure that the array section reference makes sense in the @@ -6294,6 +6471,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) ar = &ref2->u.ar; + if (codimension && ar->codimen == 0) + { + gfc_error ("Coarray specification required in ALLOCATE statement " + "at %L", &e->where); + goto failure; + } + for (i = 0; i < ar->dimen; i++) { if (ref2->u.ar.type == AR_ELEMENT) @@ -6314,13 +6498,13 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code) case DIMEN_UNKNOWN: case DIMEN_VECTOR: + case DIMEN_STAR: gfc_error ("Bad array specification in ALLOCATE statement at %L", &e->where); - return FAILURE; + goto failure; } check_symbols: - for (a = code->ext.alloc.list; a; a = a->next) { sym = a->expr->symtree->n.sym; @@ -6337,12 +6521,46 @@ check_symbols: gfc_error ("'%s' must not appear in the array specification at " "%L in the same ALLOCATE statement where it is " "itself allocated", sym->name, &ar->where); - return FAILURE; + goto failure; } } } + for (i = ar->dimen; i < ar->codimen + ar->dimen; i++) + { + if (ar->dimen_type[i] == DIMEN_ELEMENT + || ar->dimen_type[i] == DIMEN_RANGE) + { + if (i == (ar->dimen + ar->codimen - 1)) + { + gfc_error ("Expected '*' in coindex specification in ALLOCATE " + "statement at %L", &e->where); + goto failure; + } + break; + } + + if (ar->dimen_type[i] == DIMEN_STAR && i == (ar->dimen + ar->codimen - 1) + && ar->stride[i] == NULL) + break; + + gfc_error ("Bad coarray specification in ALLOCATE statement at %L", + &e->where); + goto failure; + } + + if (codimension) + { + gfc_error ("Sorry, allocatable coarrays are no yet supported coarray at %L", + &e->where); + goto failure; + } + +success: return SUCCESS; + +failure: + return FAILURE; } static void @@ -7315,6 +7533,48 @@ find_reachable_labels (gfc_code *block) } } + +static void +resolve_sync (gfc_code *code) +{ + /* Check imageset. The * case matches expr1 == NULL. */ + if (code->expr1) + { + if (code->expr1->ts.type != BT_INTEGER || code->expr1->rank > 1) + gfc_error ("Imageset argument at %L must be a scalar or rank-1 " + "INTEGER expression", &code->expr1->where); + if (code->expr1->expr_type == EXPR_CONSTANT && code->expr1->rank == 0 + && mpz_cmp_si (code->expr1->value.integer, 1) < 0) + gfc_error ("Imageset argument at %L must between 1 and num_images()", + &code->expr1->where); + else if (code->expr1->expr_type == EXPR_ARRAY + && gfc_simplify_expr (code->expr1, 0) == SUCCESS) + { + gfc_constructor *cons; + for (cons = code->expr1->value.constructor; cons; cons = cons->next) + if (cons->expr->expr_type == EXPR_CONSTANT + && mpz_cmp_si (cons->expr->value.integer, 1) < 0) + gfc_error ("Imageset argument at %L must between 1 and " + "num_images()", &cons->expr->where); + } + } + + /* Check STAT. */ + if (code->expr2 + && (code->expr2->ts.type != BT_INTEGER || code->expr2->rank != 0 + || code->expr2->expr_type != EXPR_VARIABLE)) + gfc_error ("STAT= argument at %L must be a scalar INTEGER variable", + &code->expr2->where); + + /* Check ERRMSG. */ + if (code->expr3 + && (code->expr3->ts.type != BT_CHARACTER || code->expr3->rank != 0 + || code->expr3->expr_type != EXPR_VARIABLE)) + gfc_error ("ERRMSG= argument at %L must be a scalar CHARACTER variable", + &code->expr3->where); +} + + /* Given a branch to a label, see if the branch is conforming. The code node describes where the branch is located. */ @@ -7355,15 +7615,36 @@ resolve_branch (gfc_st_label *label, gfc_code *code) the bitmap reachable_labels. */ if (bitmap_bit_p (cs_base->reachable_labels, label->value)) - return; + { + /* Check now whether there is a CRITICAL construct; if so, check + whether the label is still visible outside of the CRITICAL block, + which is invalid. */ + for (stack = cs_base; stack; stack = stack->prev) + if (stack->current->op == EXEC_CRITICAL + && bitmap_bit_p (stack->reachable_labels, label->value)) + gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" + " at %L", &code->loc, &label->where); + + return; + } /* Step four: If we haven't found the label in the bitmap, it may still be the label of the END of the enclosing block, in which case we find it by going up the code_stack. */ for (stack = cs_base; stack; stack = stack->prev) - if (stack->current->next && stack->current->next->here == label) - break; + { + if (stack->current->next && stack->current->next->here == label) + break; + if (stack->current->op == EXEC_CRITICAL) + { + /* Note: A label at END CRITICAL does not leave the CRITICAL + construct as END CRITICAL is still part of it. */ + gfc_error ("GOTO statement at %L leaves CRITICAL construct for label" + " at %L", &code->loc, &label->where); + return; + } + } if (stack) { @@ -7788,6 +8069,7 @@ gfc_resolve_blocks (gfc_code *b, gfc_namespace *ns) case EXEC_FORALL: case EXEC_DO: case EXEC_DO_WHILE: + case EXEC_CRITICAL: case EXEC_READ: case EXEC_WRITE: case EXEC_IOLENGTH: @@ -7959,17 +8241,35 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) && lhs->expr_type == EXPR_VARIABLE && lhs->ts.u.derived->attr.pointer_comp && rhs->expr_type == EXPR_VARIABLE - && gfc_impure_variable (rhs->symtree->n.sym)) + && (gfc_impure_variable (rhs->symtree->n.sym) + || gfc_is_coindexed (rhs))) + { + /* F2008, C1283. */ + if (gfc_is_coindexed (rhs)) + gfc_error ("Coindexed expression at %L is assigned to " + "a derived type variable with a POINTER " + "component in a PURE procedure", + &rhs->where); + else + gfc_error ("The impure variable at %L is assigned to " + "a derived type variable with a POINTER " + "component in a PURE procedure (12.6)", + &rhs->where); + return rval; + } + + /* Fortran 2008, C1283. */ + if (gfc_is_coindexed (lhs)) { - gfc_error ("The impure variable at %L is assigned to " - "a derived type variable with a POINTER " - "component in a PURE procedure (12.6)", - &rhs->where); + gfc_error ("Assignment to coindexed variable at %L in a PURE " + "procedure", &rhs->where); return rval; } } /* F03:7.4.1.2. */ + /* FIXME: Valid in Fortran 2008, unless the LHS is both polymorphic + and coindexed; cf. F2008, 7.2.1.2 and PR 43366. */ if (lhs->ts.type == BT_CLASS) { gfc_error ("Variable must not be polymorphic in assignment at %L", @@ -7977,6 +8277,14 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns) return false; } + /* F2008, Section 7.2.1.2. */ + if (gfc_is_coindexed (lhs) && gfc_has_ultimate_allocatable (lhs)) + { + gfc_error ("Coindexed variable must not be have an allocatable ultimate " + "component in assignment at %L", &lhs->where); + return false; + } + gfc_check_assign (lhs, rhs, 1); return false; } @@ -8068,10 +8376,18 @@ resolve_code (gfc_code *code, gfc_namespace *ns) case EXEC_CYCLE: case EXEC_PAUSE: case EXEC_STOP: + case EXEC_ERROR_STOP: case EXEC_EXIT: case EXEC_CONTINUE: case EXEC_DT_END: case EXEC_ASSIGN_CALL: + case EXEC_CRITICAL: + break; + + case EXEC_SYNC_ALL: + case EXEC_SYNC_IMAGES: + case EXEC_SYNC_MEMORY: + resolve_sync (code); break; case EXEC_ENTRY: @@ -8619,13 +8935,12 @@ is_non_constant_shape_array (gfc_symbol *sym) /* Unfortunately, !gfc_is_compile_time_shape hits a legal case that has not been simplified; parameter array references. Do the simplification now. */ - for (i = 0; i < sym->as->rank; i++) + for (i = 0; i < sym->as->rank + sym->as->corank; i++) { e = sym->as->lower[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) not_constant = true; - e = sym->as->upper[i]; if (e && (resolve_index_expr (e) == FAILURE || !gfc_is_constant_expr (e))) @@ -9075,7 +9390,7 @@ resolve_fl_variable (gfc_symbol *sym, int mp_flag) if (sym->attr.allocatable || sym->attr.external || sym->attr.dummy || sym->attr.intrinsic || sym->attr.result) no_init_flag = 1; - else if (sym->attr.dimension && !sym->attr.pointer + else if ((sym->attr.dimension || sym->attr.codimension) && !sym->attr.pointer && is_non_constant_shape_array (sym)) { no_init_flag = automatic_flag = 1; @@ -10359,6 +10674,15 @@ resolve_fl_derived (gfc_symbol *sym) super_type = gfc_get_derived_super_type (sym); + /* F2008, C432. */ + if (super_type && sym->attr.coarray_comp && !super_type->attr.coarray_comp) + { + gfc_error ("As extending type '%s' at %L has a coarray component, " + "parent type '%s' shall also have one", sym->name, + &sym->declared_at, super_type->name); + return FAILURE; + } + /* Ensure the extended type gets resolved before we do. */ if (super_type && resolve_fl_derived (super_type) == FAILURE) return FAILURE; @@ -10373,6 +10697,35 @@ resolve_fl_derived (gfc_symbol *sym) 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 " + "deferred shape", c->name, &c->loc); + return FAILURE; + } + + /* F2008, C443. */ + if (c->attr.codimension && c->ts.type == BT_DERIVED + && c->ts.u.derived->ts.is_iso_c) + { + gfc_error ("Component '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", c->name, &c->loc); + return FAILURE; + } + + /* F2008, C444. */ + if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp + && (c->attr.codimension || c->attr.pointer || c->attr.dimension + || c->attr.allocatable)) + { + gfc_error ("Component '%s' at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + c->name, &c->loc); + return FAILURE; + } + if (c->attr.proc_pointer && c->ts.interface) { if (c->ts.interface->attr.procedure) @@ -11203,6 +11556,62 @@ resolve_symbol (gfc_symbol *sym) } } + /* F2008, C526. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || sym->attr.codimension) + && sym->attr.result) + gfc_error ("Function result '%s' at %L shall not be a coarray or have " + "a coarray component", sym->name, &sym->declared_at); + + /* F2008, C524. */ + if (sym->attr.codimension && sym->ts.type == BT_DERIVED + && sym->ts.u.derived->ts.is_iso_c) + gfc_error ("Variable '%s' at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) " + "shall not be a coarray", sym->name, &sym->declared_at); + + /* F2008, C525. */ + if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp + && (sym->attr.codimension || sym->attr.pointer || sym->attr.dimension + || sym->attr.allocatable)) + gfc_error ("Variable '%s' at %L with coarray component " + "shall be a nonpointer, nonallocatable scalar", + sym->name, &sym->declared_at); + + /* F2008, C526. The function-result case was handled above. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || sym->attr.codimension) + && !(sym->attr.allocatable || sym->attr.dummy || sym->attr.save + || sym->ns->proc_name->attr.flavor == FL_MODULE + || sym->ns->proc_name->attr.is_main_program + || sym->attr.function || sym->attr.result || sym->attr.use_assoc)) + gfc_error ("Variable '%s' at %L is a coarray or has a coarray " + "component and is not ALLOCATABLE, SAVE nor a " + "dummy argument", sym->name, &sym->declared_at); + /* F2008, C528. */ /* FIXME: sym->as check due to PR 43412. */ + else if (sym->attr.codimension && !sym->attr.allocatable + && sym->as && sym->as->cotype == AS_DEFERRED) + gfc_error ("Coarray variable '%s' at %L shall not have codimensions with " + "deferred shape", sym->name, &sym->declared_at); + else if (sym->attr.codimension && sym->attr.allocatable + && (sym->as->type != AS_DEFERRED || sym->as->cotype != AS_DEFERRED)) + gfc_error ("Allocatable coarray variable '%s' at %L must have " + "deferred shape", sym->name, &sym->declared_at); + + + /* F2008, C541. */ + if (((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.coarray_comp) + || (sym->attr.codimension && sym->attr.allocatable)) + && sym->attr.dummy && sym->attr.intent == INTENT_OUT) + gfc_error ("Variable '%s' at %L is INTENT(OUT) and can thus not be an " + "allocatable coarray or have coarray components", + sym->name, &sym->declared_at); + + if (sym->attr.codimension && sym->attr.dummy + && sym->ns->proc_name && sym->ns->proc_name->attr.is_bind_c) + gfc_error ("Coarray dummy variable '%s' at %L not allowed in BIND(C) " + "procedure '%s'", sym->name, &sym->declared_at, + sym->ns->proc_name->name); + switch (sym->attr.flavor) { case FL_VARIABLE: @@ -11375,6 +11784,13 @@ check_data_variable (gfc_data_variable *var, locus *where) if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer) has_pointer = 1; + if (ref->type == REF_ARRAY && ref->u.ar.codimen) + { + gfc_error ("DATA element '%s' at %L cannot have a coindex", + sym->name, where); + return FAILURE; + } + if (has_pointer && ref->type == REF_ARRAY && ref->u.ar.type != AR_FULL) diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 8768cb6..9d14ef1 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -1928,6 +1928,7 @@ gfc_simplify_exp (gfc_expr *x) return range_check (result, "EXP"); } + gfc_expr * gfc_simplify_exponent (gfc_expr *x) { @@ -3935,6 +3936,17 @@ gfc_simplify_null (gfc_expr *mold) gfc_expr * +gfc_simplify_num_images (void) +{ + gfc_expr *result; + /* FIXME: gfc_current_locus is wrong. */ + result = gfc_constant_result (BT_INTEGER, gfc_default_integer_kind, &gfc_current_locus); + mpz_set_si (result->value.integer, 1); + return result; +} + + +gfc_expr * gfc_simplify_or (gfc_expr *x, gfc_expr *y) { gfc_expr *result; diff --git a/gcc/fortran/st.c b/gcc/fortran/st.c index f1765e6..3f98c60 100644 --- a/gcc/fortran/st.c +++ b/gcc/fortran/st.c @@ -98,6 +98,7 @@ gfc_free_statement (gfc_code *p) case EXEC_IF: case EXEC_PAUSE: case EXEC_STOP: + case EXEC_ERROR_STOP: case EXEC_EXIT: case EXEC_WHERE: case EXEC_IOLENGTH: @@ -108,6 +109,10 @@ gfc_free_statement (gfc_code *p) case EXEC_LABEL_ASSIGN: case EXEC_ENTRY: case EXEC_ARITHMETIC_IF: + case EXEC_CRITICAL: + case EXEC_SYNC_ALL: + case EXEC_SYNC_IMAGES: + case EXEC_SYNC_MEMORY: break; case EXEC_BLOCK: diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c index 0cbbacc..8aa57b6 100644 --- a/gcc/fortran/symbol.c +++ b/gcc/fortran/symbol.c @@ -370,7 +370,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) *cray_pointee = "CRAY POINTEE", *data = "DATA", *value = "VALUE", *volatile_ = "VOLATILE", *is_protected = "PROTECTED", *is_bind_c = "BIND(C)", *procedure = "PROCEDURE", - *asynchronous = "ASYNCHRONOUS"; + *asynchronous = "ASYNCHRONOUS", *codimension = "CODIMENSION"; static const char *threadprivate = "THREADPRIVATE"; const char *a1, *a2; @@ -476,11 +476,13 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (in_common, dummy); conf (in_common, allocatable); + conf (in_common, codimension); conf (in_common, result); conf (dummy, result); conf (in_equivalence, use_assoc); + conf (in_equivalence, codimension); conf (in_equivalence, dummy); conf (in_equivalence, target); conf (in_equivalence, pointer); @@ -502,6 +504,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (is_bind_c, cray_pointer); conf (is_bind_c, cray_pointee); + conf (is_bind_c, codimension); conf (is_bind_c, allocatable); conf (is_bind_c, elemental); @@ -512,6 +515,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) /* Cray pointer/pointee conflicts. */ conf (cray_pointer, cray_pointee); conf (cray_pointer, dimension); + conf (cray_pointer, codimension); conf (cray_pointer, pointer); conf (cray_pointer, target); conf (cray_pointer, allocatable); @@ -523,6 +527,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (cray_pointer, entry); conf (cray_pointee, allocatable); + conf (cray_pointer, codimension); conf (cray_pointee, intent); conf (cray_pointee, optional); conf (cray_pointee, dummy); @@ -546,8 +551,11 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (value, function) conf (value, volatile_) conf (value, dimension) + conf (value, codimension) conf (value, external) + conf (codimension, result) + if (attr->value && (attr->intent == INTENT_OUT || attr->intent == INTENT_INOUT)) { @@ -575,6 +583,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf (procedure, allocatable) conf (procedure, dimension) + conf (procedure, codimension) conf (procedure, intrinsic) conf (procedure, is_protected) conf (procedure, target) @@ -600,6 +609,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) case FL_BLOCK_DATA: case FL_MODULE: case FL_LABEL: + conf2 (codimension); conf2 (dimension); conf2 (dummy); conf2 (volatile_); @@ -652,6 +662,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (volatile_); conf2 (asynchronous); conf2 (in_namelist); + conf2 (codimension); conf2 (dimension); conf2 (function); conf2 (threadprivate); @@ -721,6 +732,7 @@ check_conflict (symbol_attribute *attr, const char *name, locus *where) conf2 (threadprivate); conf2 (value); conf2 (is_bind_c); + conf2 (codimension); conf2 (result); break; @@ -865,6 +877,32 @@ gfc_add_allocatable (symbol_attribute *attr, locus *where) gfc_try +gfc_add_codimension (symbol_attribute *attr, const char *name, locus *where) +{ + + if (check_used (attr, name, where)) + return FAILURE; + + if (attr->codimension) + { + duplicate_attr ("CODIMENSION", where); + return FAILURE; + } + + if (attr->flavor == FL_PROCEDURE && attr->if_source == IFSRC_IFBODY + && gfc_find_state (COMP_INTERFACE) == FAILURE) + { + gfc_error ("CODIMENSION specified for '%s' outside its INTERFACE body " + "at %L", name, where); + return FAILURE; + } + + attr->codimension = 1; + return check_conflict (attr, name, where); +} + + +gfc_try gfc_add_dimension (symbol_attribute *attr, const char *name, locus *where) { @@ -1095,7 +1133,7 @@ gfc_add_volatile (symbol_attribute *attr, const char *name, locus *where) { /* No check_used needed as 11.2.1 of the F2003 standard allows that the local identifier made accessible by a use statement can be - given a VOLATILE attribute. */ + given a VOLATILE attribute - unless it is a coarray (F2008, C560). */ if (attr->volatile_ && attr->volatile_ns == gfc_current_ns) if (gfc_notify_std (GFC_STD_LEGACY, @@ -1676,6 +1714,8 @@ gfc_copy_attr (symbol_attribute *dest, symbol_attribute *src, locus *where) if (src->dimension && gfc_add_dimension (dest, NULL, where) == FAILURE) goto fail; + if (src->codimension && gfc_add_codimension (dest, NULL, where) == FAILURE) + goto fail; if (src->optional && gfc_add_optional (dest, where) == FAILURE) goto fail; if (src->pointer && gfc_add_pointer (dest, where) == FAILURE) @@ -4712,6 +4752,7 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr, c->attr.pointer = attr->pointer || attr->dummy; c->attr.allocatable = attr->allocatable; c->attr.dimension = attr->dimension; + c->attr.codimension = attr->codimension; c->attr.abstract = ts->u.derived->attr.abstract; c->as = (*as); c->initializer = gfc_get_expr (); diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 5eeead8..2326cf0 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -2531,6 +2531,9 @@ gfc_conv_array_ref (gfc_se * se, gfc_array_ref * ar, gfc_symbol * sym, gfc_se indexse; gfc_se tmpse; + if (ar->dimen == 0) + return; + /* Handle scalarized references separately. */ if (ar->type != AR_ELEMENT) { @@ -3958,7 +3961,8 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) /* Find the last reference in the chain. */ while (ref && ref->next != NULL) { - gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); + gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT + || (ref->u.ar.dimen == 0 && ref->u.ar.codimen > 0)); prev_ref = ref; ref = ref->next; } @@ -3966,6 +3970,18 @@ gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat) if (ref == NULL || ref->type != REF_ARRAY) return false; + /* Return if this is a scalar coarray. */ + if (!prev_ref && !expr->symtree->n.sym->attr.dimension) + { + gcc_assert (expr->symtree->n.sym->attr.codimension); + return false; + } + else if (prev_ref && !prev_ref->u.c.component->attr.dimension) + { + gcc_assert (prev_ref->u.c.component->attr.codimension); + return false; + } + if (!prev_ref) allocatable_array = expr->symtree->n.sym->attr.allocatable; else @@ -6338,6 +6354,13 @@ gfc_walk_variable_expr (gfc_ss * ss, gfc_expr * expr) continue; ar = &ref->u.ar; + + if (ar->as->rank == 0) + { + /* Scalar coarray. */ + continue; + } + switch (ar->type) { case AR_ELEMENT: diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 3dc070c..58acf3d 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -85,6 +85,7 @@ tree gfor_fndecl_pause_numeric; tree gfor_fndecl_pause_string; tree gfor_fndecl_stop_numeric; tree gfor_fndecl_stop_string; +tree gfor_fndecl_error_stop_string; tree gfor_fndecl_runtime_error; tree gfor_fndecl_runtime_error_at; tree gfor_fndecl_runtime_warning_at; @@ -2719,6 +2720,13 @@ gfc_build_builtin_function_decls (void) /* Stop doesn't return. */ TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1; + gfor_fndecl_error_stop_string = + gfc_build_library_function_decl (get_identifier (PREFIX("error_stop_string")), + void_type_node, 2, pchar_type_node, + gfc_int4_type_node); + /* ERROR STOP doesn't return. */ + TREE_THIS_VOLATILE (gfor_fndecl_error_stop_string) = 1; + gfor_fndecl_pause_numeric = gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")), void_type_node, 1, gfc_int4_type_node); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index b9ea557..abe1ed3 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -1848,6 +1848,7 @@ gfc_add_interface_mapping (gfc_interface_mapping * mapping, new_sym->as = gfc_copy_array_spec (sym->as); new_sym->attr.referenced = 1; new_sym->attr.dimension = sym->attr.dimension; + new_sym->attr.codimension = sym->attr.codimension; new_sym->attr.pointer = sym->attr.pointer; new_sym->attr.allocatable = sym->attr.allocatable; new_sym->attr.flavor = sym->attr.flavor; @@ -2076,7 +2077,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) break; case GFC_ISYM_SIZE: - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) @@ -2114,7 +2115,7 @@ gfc_map_intrinsic_function (gfc_expr *expr, gfc_interface_mapping *mapping) /* TODO These implementations of lbound and ubound do not limit if the size < 0, according to F95's 13.14.53 and 13.14.113. */ - if (!sym->as) + if (!sym->as || sym->as->rank == 0) return false; if (arg2 && arg2->expr_type == EXPR_CONSTANT) diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index 60bffdf..58c9f3e 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -576,7 +576,7 @@ gfc_trans_pause (gfc_code * code) to a runtime library call. */ tree -gfc_trans_stop (gfc_code * code) +gfc_trans_stop (gfc_code *code, bool error_stop) { tree gfc_int4_type_node = gfc_get_int_type (4); gfc_se se; @@ -586,7 +586,6 @@ gfc_trans_stop (gfc_code * code) gfc_init_se (&se, NULL); gfc_start_block (&se.pre); - if (code->expr1 == NULL) { tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code); @@ -597,8 +596,9 @@ gfc_trans_stop (gfc_code * code) { gfc_conv_expr_reference (&se, code->expr1); tmp = build_call_expr_loc (input_location, - gfor_fndecl_stop_string, 2, - se.expr, se.string_length); + error_stop ? gfor_fndecl_error_stop_string + : gfor_fndecl_stop_string, + 2, se.expr, se.string_length); } gfc_add_expr_to_block (&se.pre, tmp); @@ -609,6 +609,47 @@ gfc_trans_stop (gfc_code * code) } +tree +gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused))) +{ + gfc_se se; + + if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) + { + gfc_init_se (&se, NULL); + gfc_start_block (&se.pre); + } + + /* Check SYNC IMAGES(imageset) for valid image index. + FIXME: Add a check for image-set arrays. */ + if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) + && code->expr1->rank == 0) + { + tree cond; + gfc_conv_expr (&se, code->expr1); + cond = fold_build2 (NE_EXPR, boolean_type_node, se.expr, + build_int_cst (TREE_TYPE (se.expr), 1)); + gfc_trans_runtime_check (true, false, cond, &se.pre, + &code->expr1->where, "Invalid image number " + "%d in SYNC IMAGES", + fold_convert (integer_type_node, se.expr)); + } + + /* If STAT is present, set it to zero. */ + if (code->expr2) + { + gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); + gfc_conv_expr (&se, code->expr2); + gfc_add_modify (&se.pre, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); + } + + if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) + return gfc_finish_block (&se.pre); + + return NULL_TREE; +} + + /* Generate GENERIC for the IF construct. This function also deals with the simple IF statement, because the front end translates the IF statement into an IF construct. @@ -769,6 +810,21 @@ gfc_trans_arithmetic_if (gfc_code * code) } +/* Translate a CRITICAL block. */ +tree +gfc_trans_critical (gfc_code *code) +{ + stmtblock_t block; + tree tmp; + + gfc_start_block (&block); + tmp = gfc_trans_code (code->block->next); + gfc_add_expr_to_block (&block, tmp); + + return gfc_finish_block (&block); +} + + /* Translate a BLOCK construct. This is basically what we would do for a procedure body. */ diff --git a/gcc/fortran/trans-stmt.h b/gcc/fortran/trans-stmt.h index 46abc09..42be0d7 100644 --- a/gcc/fortran/trans-stmt.h +++ b/gcc/fortran/trans-stmt.h @@ -36,13 +36,14 @@ tree gfc_trans_class_assign (gfc_code *code); /* trans-stmt.c */ tree gfc_trans_cycle (gfc_code *); +tree gfc_trans_critical (gfc_code *); tree gfc_trans_exit (gfc_code *); tree gfc_trans_label_assign (gfc_code *); tree gfc_trans_label_here (gfc_code *); tree gfc_trans_goto (gfc_code *); tree gfc_trans_entry (gfc_code *); tree gfc_trans_pause (gfc_code *); -tree gfc_trans_stop (gfc_code *); +tree gfc_trans_stop (gfc_code *, bool); tree gfc_trans_call (gfc_code *, bool, tree, tree, bool); tree gfc_trans_return (gfc_code *); tree gfc_trans_if (gfc_code *); @@ -51,6 +52,7 @@ tree gfc_trans_block_construct (gfc_code *); tree gfc_trans_do (gfc_code *, tree); tree gfc_trans_do_while (gfc_code *); tree gfc_trans_select (gfc_code *); +tree gfc_trans_sync (gfc_code *, gfc_exec_op); tree gfc_trans_forall (gfc_code *); tree gfc_trans_where (gfc_code *); tree gfc_trans_allocate (gfc_code *); diff --git a/gcc/fortran/trans.c b/gcc/fortran/trans.c index 6958f02..b5ff619 100644 --- a/gcc/fortran/trans.c +++ b/gcc/fortran/trans.c @@ -1105,6 +1105,10 @@ trans_code (gfc_code * code, tree cond) res = NULL_TREE; break; + case EXEC_CRITICAL: + res = gfc_trans_critical (code); + break; + case EXEC_CYCLE: res = gfc_trans_cycle (code); break; @@ -1126,7 +1130,8 @@ trans_code (gfc_code * code, tree cond) break; case EXEC_STOP: - res = gfc_trans_stop (code); + case EXEC_ERROR_STOP: + res = gfc_trans_stop (code, code->op == EXEC_ERROR_STOP); break; case EXEC_CALL: @@ -1191,6 +1196,12 @@ trans_code (gfc_code * code, tree cond) res = gfc_trans_flush (code); break; + case EXEC_SYNC_ALL: + case EXEC_SYNC_IMAGES: + case EXEC_SYNC_MEMORY: + res = gfc_trans_sync (code, code->op); + break; + case EXEC_FORALL: res = gfc_trans_forall (code); break; diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h index 30a7753..53c1dc6 100644 --- a/gcc/fortran/trans.h +++ b/gcc/fortran/trans.h @@ -533,6 +533,7 @@ extern GTY(()) tree gfor_fndecl_pause_numeric; extern GTY(()) tree gfor_fndecl_pause_string; extern GTY(()) tree gfor_fndecl_stop_numeric; extern GTY(()) tree gfor_fndecl_stop_string; +extern GTY(()) tree gfor_fndecl_error_stop_string; extern GTY(()) tree gfor_fndecl_runtime_error; extern GTY(()) tree gfor_fndecl_runtime_error_at; extern GTY(()) tree gfor_fndecl_runtime_warning_at; diff --git a/gcc/testsuite/gfortran.dg/coarray_1.f90 b/gcc/testsuite/gfortran.dg/coarray_1.f90 new file mode 100644 index 0000000..ba10d64 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_1.f90 @@ -0,0 +1,18 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Coarray support +! PR fortran/18918 +! +implicit none +integer :: n +critical ! { dg-error "Fortran 2008:" } + sync all() ! { dg-error "Fortran 2008:" } +end critical ! { dg-error "Expecting END PROGRAM" } +sync memory ! { dg-error "Fortran 2008:" } +sync images(*) ! { dg-error "Fortran 2008:" } + +! num_images is implicitly defined: +n = num_images() ! { dg-error "convert UNKNOWN to INTEGER" } +error stop 'stop' ! { dg-error "Fortran 2008:" } +end diff --git a/gcc/testsuite/gfortran.dg/coarray_2.f90 b/gcc/testsuite/gfortran.dg/coarray_2.f90 new file mode 100644 index 0000000..1fcb9b8 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_2.f90 @@ -0,0 +1,46 @@ +! { dg-do run } +! { dg-shouldfail "error stop" } +! +! Coarray support +! PR fortran/18918 + +implicit none +integer :: n +character(len=30) :: str +critical +end critical +myCr: critical +end critical myCr + sync all + sync all ( ) + n = 5 + sync all (stat=n) + if (n /= 0) call abort() + n = 5 + sync all (stat=n,errmsg=str) + if (n /= 0) call abort() + sync all (errmsg=str) + + sync memory + sync memory ( ) + n = 5 + sync memory (stat=n) + if (n /= 0) call abort() + n = 5 + sync memory (errmsg=str,stat=n) + if (n /= 0) call abort() + sync memory (errmsg=str) + +sync images (*, stat=n) +sync images (1, errmsg=str) +sync images ([1],errmsg=str,stat=n) + +sync images (*) +sync images (1) +sync images ([1]) + +if (num_images() /= 1) call abort() +error stop 'stop' +end + +! { dg-output "ERROR STOP stop" } diff --git a/gcc/testsuite/gfortran.dg/coarray_3.f90 b/gcc/testsuite/gfortran.dg/coarray_3.f90 new file mode 100644 index 0000000..648f2fa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_3.f90 @@ -0,0 +1,99 @@ +! { dg-do compile } +! +! Coarray support +! PR fortran/18918 + +implicit none +integer :: n, m(1), k +character(len=30) :: str(2) + +critical fkl ! { dg-error "Syntax error in CRITICAL" } +end critical fkl ! { dg-error "Expecting END PROGRAM" } + +sync all (stat=1) ! { dg-error "Syntax error in SYNC ALL" } +sync all ( stat = n,stat=k) ! { dg-error "Redundant STAT" } +sync memory (errmsg=str) +sync memory (errmsg=n) ! { dg-error "must be a scalar CHARACTER variable" } +sync images (*, stat=1.0) ! { dg-error "Syntax error in SYNC IMAGES" } +sync images (-1) ! { dg-error "must between 1 and num_images" } +sync images (1) +sync images ( [ 1 ]) +sync images ( m(1:0) ) +sync images ( reshape([1],[1,1])) ! { dg-error "must be a scalar or rank-1" } +end + +subroutine foo +critical + stop 'error' ! { dg-error "Image control statement STOP" } + sync all ! { dg-error "Image control statement SYNC" } + return 1 ! { dg-error "Image control statement RETURN" } + critical ! { dg-error "Nested CRITICAL block" } + end critical +end critical ! { dg-error "Expecting END SUBROUTINE" } +end + +subroutine bar() +do + critical + cycle ! { dg-error "leaves CRITICAL construct" } + end critical +end do + +outer: do + critical + do + exit + exit outer ! { dg-error "leaves CRITICAL construct" } + end do + end critical +end do outer +end subroutine bar + + +subroutine sub() +333 continue ! { dg-error "leaves CRITICAL construct" } +do + critical + if (.false.) then + goto 333 ! { dg-error "leaves CRITICAL construct" } + goto 777 +777 end if + end critical +end do + +if (.true.) then +outer: do + critical + do + goto 444 + goto 555 ! { dg-error "leaves CRITICAL construct" } + end do +444 continue + end critical + end do outer +555 end if ! { dg-error "leaves CRITICAL construct" } +end subroutine sub + +pure subroutine pureSub() + critical ! { dg-error "Image control statement CRITICAL" } + end critical ! { dg-error "Expecting END SUBROUTINE statement" } + sync all ! { dg-error "Image control statement SYNC" } + error stop ! { dg-error "not allowed in PURE procedure" } +end subroutine pureSub + + +SUBROUTINE TEST + goto 10 ! { dg-warning "is not in the same block" } + CRITICAL + goto 5 ! OK +5 continue ! { dg-warning "is not in the same block" } + goto 10 ! OK + goto 20 ! { dg-error "leaves CRITICAL construct" } + goto 30 ! { dg-error "leaves CRITICAL construct" } +10 END CRITICAL ! { dg-warning "is not in the same block" } + goto 5 ! { dg-warning "is not in the same block" } +20 continue ! { dg-error "leaves CRITICAL construct" } + BLOCK +30 continue ! { dg-error "leaves CRITICAL construct" } + END BLOCK +end SUBROUTINE TEST diff --git a/gcc/testsuite/gfortran.dg/coarray_4.f90 b/gcc/testsuite/gfortran.dg/coarray_4.f90 new file mode 100644 index 0000000..cb693ea --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_4.f90 @@ -0,0 +1,86 @@ +! { dg-do compile } +! +! Coarray support -- corank declarations +! PR fortran/18918 +! + +subroutine valid(n, c, f) + implicit none + integer :: n + integer, save :: a[*], b(4)[-1:4,*] + real :: c(*)[1,0:3,3:*] + real :: f(n)[0:n,-100:*] + integer, allocatable :: d[:], e(:)[:,:] + integer, save, codimension[1,*] :: g, h(7), i(6)[*], j[*] + integer :: k + codimension :: k[*] + save :: k + integer :: ii = 7 + block + integer, save :: kk[ii, *] ! { dg-error "cannot have the SAVE attribute" } + end block +end subroutine valid + +subroutine valid2() + type t + integer, allocatable :: a[:] + end type t + type, extends(t) :: tt + integer, allocatable :: b[:] + end type tt + type(tt), save :: foo + type(tt) :: bar ! { dg-error "is a coarray or has a coarray component" } +end subroutine valid2 + +subroutine invalid(n) + implicit none + integer :: n + integer :: k[*] ! { dg-error "not ALLOCATABLE, SAVE nor a dummy" } + integer :: h(3)[*] ! { dg-error "not ALLOCATABLE, SAVE nor a dummy" } + integer, save :: a[*] + codimension :: a[1,*] ! { dg-error "Duplicate CODIMENSION attribute" } + complex, save :: hh(n)[*] ! { dg-error "cannot have the SAVE attribute" } + integer :: j = 6 + + integer, save :: hf1[j,*] ! { dg-error "cannot appear in the expression|cannot have the SAVE attribute" } + integer, save :: hf2[n,*] ! { dg-error "cannot have the SAVE attribute" } + integer, save :: hf3(4)[j,*] ! { dg-error "cannot appear in the expression|cannot have the SAVE attribute" } + integer, save :: hf4(5)[n,*] ! { dg-error "cannot have the SAVE attribute" } + + integer, allocatable :: a2[*] ! { dg-error "must have deferred shape" } + integer, allocatable :: a3(:)[*] ! { dg-error "must have deferred shape" } + integer, allocatable :: a4[*] ! { dg-error "must have deferred shape" } +end subroutine invalid + +subroutine invalid2 + use iso_c_binding + implicit none + type t0 + integer, allocatable :: a[:,:,:] + end type t0 + type t + end type t + type, extends(t) :: tt ! { dg-error "has a coarray component, parent type" } + integer, allocatable :: a[:] + end type tt + type ttt + integer, pointer :: a[:] ! { dg-error "must be allocatable" } + end type ttt + type t4 + integer, allocatable :: b[4,*] ! { dg-error "with deferred shape" } + end type t4 + type t5 + type(c_ptr), allocatable :: p[:] ! { dg-error "shall not be a coarray" } + end type t5 + type(t0), save :: t0_1[*] ! { dg-error "shall be a nonpointer, nonallocatable scalar" } + type(t0), allocatable :: t0_2[:] ! { dg-error "shall be a nonpointer, nonallocatable scalar" } + type(c_ptr), save :: pp[*] ! { dg-error "shall not be a coarray" } +end subroutine invalid2 + +elemental subroutine elem(a) ! { dg-error "Coarray dummy argument" } + integer, intent(in) :: a[*] +end subroutine + +function func() result(res) + integer :: res[*] ! { dg-error "CODIMENSION attribute conflicts with RESULT" } +end function func diff --git a/gcc/testsuite/gfortran.dg/coarray_5.f90 b/gcc/testsuite/gfortran.dg/coarray_5.f90 new file mode 100644 index 0000000..46aa311 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_5.f90 @@ -0,0 +1,10 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Coarray support -- corank declarations +! PR fortran/18918 +! + +integer :: a, b[*] ! { dg-error "Fortran 2008: Coarray declaration" } +codimension :: a[*] ! { dg-error "Fortran 2008: Coarray declaration" } +end diff --git a/gcc/testsuite/gfortran.dg/coarray_6.f90 b/gcc/testsuite/gfortran.dg/coarray_6.f90 new file mode 100644 index 0000000..b6d8b49 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_6.f90 @@ -0,0 +1,84 @@ +! { dg-do compile } +! +! Coarray support -- corank declarations +! PR fortran/18918 +! +module m2 + use iso_c_binding + integer(c_int), bind(C) :: a[*] ! { dg-error "BIND.C. attribute conflicts with CODIMENSION" } + + type, bind(C) :: t ! { dg-error "cannot have the ALLOCATABLE" } + integer(c_int), allocatable :: a[:] ! { dg-error "cannot have the ALLOCATABLE" } + integer(c_int) :: b[*] ! { dg-error "must be allocatable" } + end type t +end module m2 + +subroutine bind(a) bind(C) ! { dg-error "Coarray dummy variable" } + use iso_c_binding + integer(c_int) :: a[*] +end subroutine bind + +subroutine allo(x) ! { dg-error "can thus not be an allocatable coarray" } + integer, allocatable, intent(out) :: x[:] +end subroutine allo + +module m + integer :: modvar[*] ! OK, implicit save + type t + complex, allocatable :: b(:,:,:,:)[:,:,:] + end type t +end module m + +subroutine bar() + integer, parameter :: a[*] = 4 ! { dg-error "PARAMETER attribute conflicts with CODIMENSION" } + integer, pointer :: b[:] ! { dg-error "is not ALLOCATABLE, SAVE nor a dummy" } +end subroutine bar + +subroutine vol() + integer,save :: a[*] + block + volatile :: a ! { dg-error "Specifying VOLATILE for coarray" } + end block +contains + subroutine int() + volatile :: a ! { dg-error "Specifying VOLATILE for coarray" } + end subroutine int +end subroutine vol + + +function func() result(func2) ! { dg-error "shall not be a coarray or have a coarray component" } + use m + type(t) :: func2 +end function func + +subroutine invalid() + type t + integer, allocatable :: a[:] + end type t + type t2 + type(t), allocatable :: b ! { dg-error "nonpointer, nonallocatable scalar" } + end type t2 + type t3 + type(t), pointer :: c ! { dg-error "nonpointer, nonallocatable scalar" } + end type t3 + type t4 + type(t) :: d(4) ! { dg-error "nonpointer, nonallocatable scalar" } + end type t4 +end subroutine invalid + +subroutine valid(a) + integer :: a(:)[4,-1:6,4:*] + type t + integer, allocatable :: a[:] + end type t + type t2 + type(t) :: b + end type t2 + type(t2), save :: xt2[*] +end subroutine valid + +program main + integer :: A[*] ! Valid, implicit SAVE attribute +end program main + +! { dg-final { cleanup-modules "m" } } diff --git a/gcc/testsuite/gfortran.dg/coarray_7.f90 b/gcc/testsuite/gfortran.dg/coarray_7.f90 new file mode 100644 index 0000000..a32bf88 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_7.f90 @@ -0,0 +1,194 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000" } +! +! PR fortran/18918 +! +! Coarray expressions. +! +program test + implicit none + type t3 + integer, allocatable :: a + end type t3 + type t4 + type(t3) :: xt3 + end type t4 + type t + integer, pointer :: ptr + integer, allocatable :: alloc(:) + end type t + type(t), target :: i[*] + type(t), allocatable :: ca[:] + type(t4), target :: tt4[*] + type(t4), allocatable :: ca2[:] + integer, volatile :: volat[*] + integer, asynchronous :: async[*] + integer :: caf1[1,*], caf2[*] + allocate(i%ptr) + call foo(i%ptr) + call foo(i[1]%ptr) ! { dg-error "Coindexed actual argument at .1. to pointer dummy" } + call bar(i%ptr) + call bar(i[1]%ptr) ! OK, value of ptr target + call bar(i[1]%alloc(1)) ! OK + call typeDummy(i) ! OK + call typeDummy(i[1]) ! { dg-error "with ultimate pointer component" } + call typeDummy2(ca) ! OK + call typeDummy2(ca[1]) ! { dg-error "with ultimate pointer component" } + call typeDummy3(tt4%xt3) ! OK + call typeDummy3(tt4[1]%xt3) ! { dg-error "requires either VALUE or INTENT.IN." } + call typeDummy4(ca2) ! OK + call typeDummy4(ca2[1]) ! { dg-error "requires INTENT.IN." } +! Note: Checking an VOLATILE dummy is not possible as volatile + intent(in) +! is not possible + + call asyn(volat) + call asyn(async) + call asyn(volat[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" } + call asyn(async[1]) ! { dg-error "Coindexed ASYNCHRONOUS or VOLATILE actual argument" } + + call coarray(caf1) ! rank mismatch; OK, for non allocatable coarrays + call coarray(caf2) + call coarray(caf2[1]) ! { dg-error "must be a coarray" } + call ups(i) + call ups(i[1]) ! { dg-error "with ultimate pointer component" } + call ups(i%ptr) + call ups(i[1]%ptr) ! OK - passes target not pointer +contains + subroutine asyn(a) + integer, intent(in), asynchronous :: a + end subroutine asyn + subroutine bar(a) + integer :: a + end subroutine bar + subroutine foo(a) + integer, pointer :: a + end subroutine foo + subroutine coarray(a) + integer :: a[*] + end subroutine coarray + subroutine typeDummy(a) + type(t) :: a + end subroutine typeDummy + subroutine typeDummy2(a) + type(t),allocatable :: a + end subroutine typeDummy2 + subroutine typeDummy3(a) + type(t3) :: a + end subroutine typeDummy3 + subroutine typeDummy4(a) + type(t4), allocatable :: a + end subroutine typeDummy4 +end program test + + +subroutine alloc() +type t + integer, allocatable :: a(:) +end type t +type(t), save :: a[*] +type(t), allocatable :: b(:)[:], C[:] + +allocate(b(1)) ! { dg-error "Coarray specification" } +allocate(a[3]%a(5)) ! { dg-error "Coindexed allocatable" } +allocate(c[*]) ! { dg-error "Sorry" } +allocate(b(3)[5:*]) ! { dg-error "Sorry" } +allocate(a%a(5)) ! OK +end subroutine alloc + + +subroutine dataPtr() + integer, save, target :: a[*] + data a/5/ ! OK + data a[1]/5/ ! { dg-error "cannot have a coindex" } + type t + integer, pointer :: p + end type t + type(t), save :: x[*] + + type t2 + integer :: a(1) + end type t2 + type(t2) y + data y%a/4/ + + + x[1]%p => a ! { dg-error "shall not have a coindex" } + x%p => a[1] ! { dg-error "shall not have a coindex" } +end subroutine dataPtr + + +subroutine test3() +implicit none +type t + integer :: a(1) +end type t +type(t), save :: x[*] +data x%a/4/ + + integer, save :: y(1)[*] !(1) + call sub(x(1:1)[1]) ! { dg-error "Rank mismatch" } +contains + subroutine sub(a) ! { dg-error "shall not have codimensions with deferred shape" } + integer :: a(:)[:] + end subroutine sub +end subroutine test3 + + +subroutine test4() + integer, save :: i[*] + integer :: j + call foo(i) + call foo(j) ! { dg-error "must be a coarray" } +contains + subroutine foo(a) + integer :: a[*] + end subroutine foo +end subroutine test4 + + +subroutine allocateTest() + implicit none + real, allocatable,dimension(:,:), codimension[:,:] :: a,b,c + integer :: n, q + n = 1 + q = 1 + allocate(a(n,n)[q,*]) ! { dg-error "Sorry" } + allocate(b(n,n)[q,*]) ! { dg-error "Sorry" } + allocate(c(n,n)[q,*]) ! { dg-error "Sorry" } +end subroutine allocateTest + + +subroutine testAlloc3 +implicit none +integer, allocatable :: a(:,:,:)[:,:] +integer, allocatable, dimension(:),codimension[:] :: b(:,:,:)[:,:] +integer, allocatable, dimension(:,:),codimension[:,:,:] :: c +integer, allocatable, dimension(:,:),codimension[:,:,:] :: d[:,:] +integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: e(:,:) +integer, allocatable, dimension(:,:,:),codimension[:,:,:] :: f(:,:)[:,:] + +allocate(a(1,2,3)[4,*]) ! { dg-error "Sorry" } +allocate(b(1,2,3)[4,*]) ! { dg-error "Sorry" } +allocate(c(1,2)[3,4,*]) ! { dg-error "Sorry" } +allocate(d(1,2)[3,*]) ! { dg-error "Sorry" } +allocate(e(1,2)[3,4,*]) ! { dg-error "Sorry" } +allocate(f(1,2)[3,*]) ! { dg-error "Sorry" } +end subroutine testAlloc3 + + +subroutine testAlloc4() + implicit none + type co_double_3 + double precision, allocatable :: array(:) + end type co_double_3 + type(co_double_3),save, codimension[*] :: work + allocate(work%array(1)) + print *, size(work%array) +end subroutine testAlloc4 + +subroutine test5() + implicit none + integer, save :: i[*] + print *, i[*] ! { dg-error "Coindex of codimension 1 must be a scalar" } +end subroutine test5 + diff --git a/gcc/testsuite/gfortran.dg/coarray_8.f90 b/gcc/testsuite/gfortran.dg/coarray_8.f90 new file mode 100644 index 0000000..0ab1190 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/coarray_8.f90 @@ -0,0 +1,191 @@ +! { dg-do compile } +! { dg-options "-fmax-errors=1000" } +! +! PR fortran/18918 +! +! Coarray expressions. +! +module mod2 + implicit none + type t + procedure(sub), pointer :: ppc + contains + procedure :: tbp => sub + end type t + type t2 + class(t), allocatable :: poly + end type t2 +contains + subroutine sub(this) + class(t), intent(in) :: this + end subroutine sub +end module mod2 + +subroutine procTest(y,z) + use mod2 + implicit none + type(t), save :: x[*] + type(t) :: y[*] + type(t2) :: z[*] + + x%ppc => sub + call x%ppc() ! OK + call x%tbp() ! OK + call x[1]%tbp ! OK, not polymorphic + ! Invalid per C726 + call x[1]%ppc ! { dg-error "Coindexed procedure-pointer component" } + + y%ppc => sub + call y%ppc() ! OK + call y%tbp() ! OK + call y[1]%tbp ! OK, coindexed polymorphic object but not poly. subobj. + call y[1]%ppc ! { dg-error "Coindexed procedure-pointer component" } + + ! Invalid per C1229 + z%poly%ppc => sub + call z%poly%ppc() ! OK + call z%poly%tbp() ! OK + call z[1]%poly%tbp ! { dg-error "Polymorphic subobject of coindexed" } + call z[1]%poly%ppc ! { dg-error "Coindexed procedure-pointer component" } +end subroutine procTest + + +module m + type t1 + integer, pointer :: p + end type t1 + type t2 + integer :: i + end type t2 + type t + integer, allocatable :: a[:] + type(t1), allocatable :: b[:] + type(t2), allocatable :: c[:] + end type t +contains + pure subroutine p2(x) + integer, intent(inout) :: x + end subroutine p2 + pure subroutine p3(x) + integer, pointer :: x + end subroutine p3 + pure subroutine p1(x) + type(t), intent(inout) :: x + integer, target :: tgt1 + x%a = 5 + x%a[6] = 9 ! { dg-error "Assignment to coindexed variable" } + x%b%p => tgt1 + x%b[1]%p => tgt1 ! { dg-error "shall not have a coindex" } + x%b%p => x%b[1]%p ! { dg-error "shall not have a coindex" } + x%b = t1(x%b[1]%p) ! { dg-error "Coindexed expression to pointer component" } + x%b = x%b[1] ! { dg-error "derived type variable with a POINTER component in a PURE" } + call p2 (x%c[1]%i) ! { dg-error "Coindexed actual argument" } + call p3 (x%b[1]%p) ! { dg-error "to pointer dummy" } + end subroutine p1 + subroutine nonPtr() + type(t1), save :: a[*] + type(t2), save :: b[*] + integer, target :: tgt1 + a%p => tgt1 + a[1]%p => tgt1 ! { dg-error "shall not have a coindex" } + a%p => a[2]%p ! { dg-error "shall not have a coindex" } + a = t1(a[1]%p) ! { dg-error "Coindexed expression to pointer component" } + call p2 (b[1]%i) ! OK + call p2 (a[1]%p) ! OK - pointer target and not pointer + end subroutine nonPtr +end module m + + +module mmm3 + type t + integer, allocatable :: a(:) + end type t +contains + subroutine assign(x) + type(t) :: x[*] + allocate(x%a(3)) + x%a = [ 1, 2, 3] + x[1]%a = [ 1, 2, 3] ! OK - if shapes are the same, otherwise wrong + ! (no reallocate on assignment) + end subroutine assign + subroutine assign2(x,y) + type(t),allocatable :: x[:] + type(t) :: y + x = y + x[1] = y ! { dg-error "must not be have an allocatable ultimate component" } + end subroutine assign2 +end module mmm3 + + +module mmm4 + implicit none +contains + subroutine t1(x) + integer :: x(1) + end subroutine t1 + subroutine t3(x) + character :: x(*) + end subroutine t3 + subroutine t2() + integer, save :: x[*] + integer, save :: y(1)[*] + character(len=20), save :: z[*] + + call t1(x) ! { dg-error "Rank mismatch" } + call t1(x[1]) ! { dg-error "Rank mismatch" } + + call t1(y(1)) ! OK + call t1(y(1)[1]) ! { dg-error "Rank mismatch" } + + call t3(z) ! OK + call t3(z[1]) ! { dg-error "Rank mismatch" } + end subroutine t2 +end module mmm4 + + +subroutine tfgh() + integer :: i(2) + DATA i/(i, i=1,2)/ ! { dg-error "Expected PARAMETER symbol" } + do i = 1, 5 ! { dg-error "cannot be a sub-component" } + end do ! { dg-error "Expecting END SUBROUTINE" } +end subroutine tfgh + +subroutine tfgh2() + integer, save :: x[*] + integer :: i(2) + DATA i/(x, x=1,2)/ ! { dg-error "Expected PARAMETER symbol" } + do x = 1, 5 ! { dg-error "cannot be a coarray" } + end do ! { dg-error "Expecting END SUBROUTINE" } +end subroutine tfgh2 + + +subroutine f4f4() + type t + procedure(), pointer, nopass :: ppt => null() + end type t + external foo + type(t), save :: x[*] + x%ppt => foo + x[1]%ppt => foo ! { dg-error "shall not have a coindex" } +end subroutine f4f4 + + +subroutine corank() + integer, allocatable :: a[:,:] + call one(a) ! OK + call two(a) ! { dg-error "Corank mismatch in argument" } +contains + subroutine one(x) + integer :: x[*] + end subroutine one + subroutine two(x) + integer, allocatable :: x[:] + end subroutine two +end subroutine corank + +subroutine assign42() + integer, allocatable :: z(:)[:] + z(:)[1] = z +end subroutine assign42 + +! { dg-final { cleanup-modules "mod2 m mmm3 mmm4" } } diff --git a/gcc/testsuite/gfortran.dg/iso_fortran_env_5.f90 b/gcc/testsuite/gfortran.dg/iso_fortran_env_5.f90 new file mode 100644 index 0000000..92c2e40 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_fortran_env_5.f90 @@ -0,0 +1,27 @@ +! { dg-do compile } +! { dg-options "-O2 -fdump-tree-original" } +! +! Check for new F2008 integer constants, needed for +! coarray support (cf. PR fortran/18918) +! + +USE iso_fortran_env +implicit none +integer :: i +integer(kind=ATOMIC_INT_KIND) :: atomic_int +logical(kind=ATOMIC_LOGICAL_KIND) :: atomic_bool + +i = 0 +if (IOSTAT_INQUIRE_INTERNAL_UNIT <= 0) call abort() +if (IOSTAT_INQUIRE_INTERNAL_UNIT == STAT_STOPPED_IMAGE) call abort() +if (STAT_STOPPED_IMAGE <= 0) call abort() + +if ((STAT_LOCKED_OTHER_IMAGE == STAT_LOCKED) & + .or.(STAT_LOCKED_OTHER_IMAGE == STAT_UNLOCKED)) call abort() +if (STAT_LOCKED == STAT_UNLOCKED) call abort() + +end + +! { dg-final { scan-tree-dump-times "abort" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } } + diff --git a/gcc/testsuite/gfortran.dg/iso_fortran_env_6.f90 b/gcc/testsuite/gfortran.dg/iso_fortran_env_6.f90 new file mode 100644 index 0000000..951e138 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/iso_fortran_env_6.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-std=f2003" } +! +! Check for new F2008 integer constants, needed for +! coarray support (cf. PR fortran/18918) +! + +USE iso_fortran_env +implicit none +integer(kind=ATOMIC_INT_KIND) :: atomic_int ! { dg-error "has no IMPLICIT type" } +logical(kind=ATOMIC_LOGICAL_KIND) :: atomic_bool ! { dg-error "has no IMPLICIT type" } + +if (IOSTAT_INQUIRE_INTERNAL_UNIT <= 0) call abort() ! { dg-error "has no IMPLICIT type" } +print *,STAT_STOPPED_IMAGE ! { dg-error "has no IMPLICIT type" } +print *, STAT_LOCKED_OTHER_IMAGE ! { dg-error "has no IMPLICIT type" } +print *, STAT_LOCKED ! { dg-error "has no IMPLICIT type" } +print *, STAT_UNLOCKED ! { dg-error "has no IMPLICIT type" } +end + +module m +USE iso_fortran_env, only: ATOMIC_INT_KIND ! { dg-error "is not in the selected standard" } +implicit none +end module m + +module m2 +USE iso_fortran_env, only: foo => STAT_UNLOCKED ! { dg-error "is not in the selected standard" } +implicit none +end module m2 + +module m3 +USE iso_fortran_env, foo => IOSTAT_INQUIRE_INTERNAL_UNIT ! { dg-error "not found" } +implicit none +end module m3 diff --git a/libgfortran/gfortran.map b/libgfortran/gfortran.map index 3541d14..bcca957 100644 --- a/libgfortran/gfortran.map +++ b/libgfortran/gfortran.map @@ -1098,6 +1098,11 @@ GFORTRAN_1.2 { _gfortran_is_extension_of; } GFORTRAN_1.1; +GFORTRAN_1.3 { + global: + _gfortran_error_stop_string; +} GFORTRAN_1.2; + F2C_1.0 { global: _gfortran_f2c_specific__abs_c4; diff --git a/libgfortran/runtime/stop.c b/libgfortran/runtime/stop.c index 8c4247d..bda6b89 100644 --- a/libgfortran/runtime/stop.c +++ b/libgfortran/runtime/stop.c @@ -53,3 +53,22 @@ stop_string (const char *string, GFC_INTEGER_4 len) sys_exit (0); } + +extern void error_stop_string (const char *, GFC_INTEGER_4); +export_proto(error_stop_string); + + +/* Per Fortran 2008, section 8.4: "Execution of a STOP statement initiates + normal termination of execution. Execution of an ERROR STOP statement + initiates error termination of execution." Thus, error_stop_string returns + a nonzero exit status code. */ +void +error_stop_string (const char *string, GFC_INTEGER_4 len) +{ + st_printf ("ERROR STOP "); + while (len--) + st_printf ("%c", *(string++)); + st_printf ("\n"); + + sys_exit (1); +}