2010-04-06 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
+ * array.c (gfc_free_array_spec,gfc_resolve_array_spec,
+ match_array_element_spec,gfc_copy_array_spec,
+ gfc_compare_array_spec): Include corank.
+ (match_array_element_spec,gfc_set_array_spec): Support codimension.
+ * decl.c (build_sym,build_struct,variable_decl,
+ match_attr_spec,attr_decl1,cray_pointer_decl,
+ gfc_match_volatile): Add codimension.
+ (gfc_match_codimension): New function.
+ * dump-parse-tree.c (show_array_spec,show_attr): Support codimension.
+ * gfortran.h (symbol_attribute,gfc_array_spec): Ditto.
+ (gfc_add_codimension): New function prototype.
+ * match.h (gfc_match_codimension): New function prototype.
+ (gfc_match_array_spec): Update prototype
+ * match.c (gfc_match_common): Update gfc_match_array_spec call.
+ * module.c (MOD_VERSION): Bump.
+ (mio_symbol_attribute): Support coarray attributes.
+ (mio_array_spec): Add corank support.
+ * parse.c (decode_specification_statement,decode_statement,
+ parse_derived): Add coarray support.
+ * resolve.c (resolve_formal_arglist, was_declared,
+ is_non_constant_shape_array, resolve_fl_variable,
+ resolve_fl_derived, resolve_symbol): Add coarray support.
+ * symbol.c (check_conflict, gfc_add_volatile, gfc_copy_attr,
+ gfc_build_class_symbol): Add coarray support.
+ (gfc_add_codimension): New function.
+
+2010-04-06 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
* iso-fortran-env.def: Add the integer parameters atomic_int_kind,
atomic_logical_kind, iostat_inquire_internal_unit, stat_locked,
stat_locked_other_image, stat_stopped_image and stat_unlocked of
#include "system.h"
#include "gfortran.h"
#include "match.h"
-#include "constructor.h"
/**************** Array reference matching subroutines *****************/
expression. */
static match
-match_subscript (gfc_array_ref *ar, int init, bool match_star)
+match_subscript (gfc_array_ref *ar, int init)
{
match m;
- bool star = false;
int i;
- i = ar->dimen + ar->codimen;
+ i = ar->dimen;
ar->c_where[i] = gfc_current_locus;
ar->start[i] = ar->end[i] = ar->stride[i] = NULL;
goto end_element;
/* Get start element. */
- if (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
- star = true;
-
- if (!star && init)
+ if (init)
m = gfc_match_init_expr (&ar->start[i]);
- else if (!star)
+ else
m = gfc_match_expr (&ar->start[i]);
if (m == MATCH_NO)
return MATCH_ERROR;
if (gfc_match_char (':') == MATCH_NO)
- goto matched;
-
- if (star)
- {
- gfc_error ("Unexpected '*' in coarray subscript at %C");
- return MATCH_ERROR;
- }
+ return MATCH_YES;
/* 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 (match_star && (m = gfc_match_char ('*')) == MATCH_YES)
- star = true;
- else if (init)
+ if (init)
m = gfc_match_init_expr (&ar->end[i]);
else
m = gfc_match_expr (&ar->end[i]);
/* 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]);
return MATCH_ERROR;
}
-matched:
- if (star)
- ar->dimen_type[i] = DIMEN_STAR;
-
return MATCH_YES;
}
to consist of init expressions. */
match
-gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
- int corank)
+gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init)
{
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)
{
return MATCH_YES;
}
+ ar->type = AR_UNKNOWN;
+
for (ar->dimen = 0; ar->dimen < GFC_MAX_DIMENSIONS; ar->dimen++)
{
- m = match_subscript (ar, init, false);
+ m = match_subscript (ar, init);
if (m == MATCH_ERROR)
- return MATCH_ERROR;
+ goto error;
if (gfc_match_char (')') == MATCH_YES)
- {
- ar->dimen++;
- goto coarray;
- }
+ goto matched;
if (gfc_match_char (',') != MATCH_YES)
{
gfc_error ("Invalid form of array reference at %C");
- return MATCH_ERROR;
+ goto error;
}
}
gfc_error ("Array reference at %C cannot have more than %d dimensions",
GFC_MAX_DIMENSIONS);
- return MATCH_ERROR;
-
-coarray:
- if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
- {
- if (ar->dimen > 0)
- return MATCH_YES;
- else
- return MATCH_ERROR;
- }
-
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- return MATCH_ERROR;
- }
-
- if (corank == 0)
- {
- gfc_error ("Unexpected coarray designator at %C");
- return MATCH_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)
- return MATCH_ERROR;
- if (gfc_match_char (']') == MATCH_YES)
- {
- ar->codimen++;
- return MATCH_YES;
- }
-
- if (gfc_match_char (',') != MATCH_YES)
- {
- gfc_error ("Invalid form of coarray reference at %C");
- return MATCH_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;
}
if (gfc_match_char ('*') == MATCH_YES)
{
- *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ *lower = gfc_int_expr (1);
return AS_ASSUMED_SIZE;
}
if (gfc_match_char (':') == MATCH_NO)
{
- *lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ *lower = gfc_int_expr (1);
return AS_EXPLICIT;
}
gfc_match_array_spec (gfc_array_spec **asp, bool match_dim, bool match_codim)
{
array_type current_type;
+ array_type coarray_type = AS_UNKNOWN;
gfc_array_spec *as;
int i;
== FAILURE)
goto cleanup;
- if (gfc_option.coarray == GFC_FCOARRAY_NONE)
- {
- gfc_fatal_error ("Coarrays disabled at %C, use -fcoarray= to enable");
- goto cleanup;
- }
-
for (;;)
{
as->corank++;
if (current_type == AS_UNKNOWN)
goto cleanup;
+ if (as->rank && as->type != AS_DEFERRED && current_type == AS_DEFERRED)
+ {
+ gfc_error ("Array at %C has non-deferred shape and deferred "
+ "coshape");
+ goto cleanup;
+ }
+ if (as->rank && as->type == AS_DEFERRED && current_type != AS_DEFERRED)
+ {
+ gfc_error ("Array at %C has deferred shape and non-deferred "
+ "coshape");
+ goto cleanup;
+ }
+
if (as->corank == 1)
- as->cotype = current_type;
+ coarray_type = current_type;
else
- switch (as->cotype)
+ switch (coarray_type)
{ /* 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;
+ coarray_type = AS_ASSUMED_SIZE;
break;
}
if (current_type == AS_ASSUMED_SHAPE)
{
- as->cotype = AS_ASSUMED_SHAPE;
+ as->type = AS_ASSUMED_SHAPE;
break;
}
goto cleanup;
}
- if (as->cotype == AS_ASSUMED_SIZE)
- as->cotype = AS_EXPLICIT;
-
- if (as->rank == 0)
- as->type = as->cotype;
+ if (as->rank == 0 && coarray_type == AS_ASSUMED_SIZE)
+ as->type = AS_EXPLICIT;
+ else if (as->rank == 0)
+ as->type = coarray_type;
done:
if (as->rank == 0 && as->corank == 0)
for (i = 0; i < as->rank + as->corank; i++)
{
if (as->lower[i] == NULL)
- as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ as->lower[i] = gfc_int_expr (1);
}
}
return SUCCESS;
}
+ if (sym->as->type == AS_DEFERRED && as->type != AS_DEFERRED)
+ {
+ gfc_error ("'%s' at %L has deferred shape and non-deferred coshape",
+ sym->name, error_loc);
+ return FAILURE;
+ }
+
+ if (sym->as->type != AS_DEFERRED && as->type == AS_DEFERRED)
+ {
+ gfc_error ("'%s' at %L has non-deferred shape and deferred coshape",
+ sym->name, error_loc);
+ return FAILURE;
+ }
+
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++)
{
/****************** Array constructor functions ******************/
+/* Start an array constructor. The constructor starts with zero
+ elements and should be appended to by gfc_append_constructor(). */
+
+gfc_expr *
+gfc_start_constructor (bt type, int kind, locus *where)
+{
+ gfc_expr *result;
+
+ result = gfc_get_expr ();
+
+ result->expr_type = EXPR_ARRAY;
+ result->rank = 1;
+
+ result->ts.type = type;
+ result->ts.kind = kind;
+ result->where = *where;
+ return result;
+}
+
+
+/* Given an array constructor expression, append the new expression
+ node onto the constructor. */
+
+void
+gfc_append_constructor (gfc_expr *base, gfc_expr *new_expr)
+{
+ gfc_constructor *c;
+
+ if (base->value.constructor == NULL)
+ base->value.constructor = c = gfc_get_constructor ();
+ else
+ {
+ c = base->value.constructor;
+ while (c->next)
+ c = c->next;
+
+ c->next = gfc_get_constructor ();
+ c = c->next;
+ }
+
+ c->expr = new_expr;
+
+ if (new_expr
+ && (new_expr->ts.type != base->ts.type || new_expr->ts.kind != base->ts.kind))
+ gfc_internal_error ("gfc_append_constructor(): New node has wrong kind");
+}
+
+
+/* Given an array constructor expression, insert the new expression's
+ constructor onto the base's one according to the offset. */
+
+void
+gfc_insert_constructor (gfc_expr *base, gfc_constructor *c1)
+{
+ gfc_constructor *c, *pre;
+ expr_t type;
+ int t;
+
+ type = base->expr_type;
+
+ if (base->value.constructor == NULL)
+ base->value.constructor = c1;
+ else
+ {
+ c = pre = base->value.constructor;
+ while (c)
+ {
+ if (type == EXPR_ARRAY)
+ {
+ t = mpz_cmp (c->n.offset, c1->n.offset);
+ if (t < 0)
+ {
+ pre = c;
+ c = c->next;
+ }
+ else if (t == 0)
+ {
+ gfc_error ("duplicated initializer");
+ break;
+ }
+ else
+ break;
+ }
+ else
+ {
+ pre = c;
+ c = c->next;
+ }
+ }
+
+ if (pre != c)
+ {
+ pre->next = c1;
+ c1->next = c;
+ }
+ else
+ {
+ c1->next = c;
+ base->value.constructor = c1;
+ }
+ }
+}
+
+
+/* Get a new constructor. */
+
+gfc_constructor *
+gfc_get_constructor (void)
+{
+ gfc_constructor *c;
+
+ c = XCNEW (gfc_constructor);
+ c->expr = NULL;
+ c->iterator = NULL;
+ c->next = NULL;
+ mpz_init_set_si (c->n.offset, 0);
+ mpz_init_set_si (c->repeat, 0);
+ return c;
+}
+
+
+/* Free chains of gfc_constructor structures. */
+
+void
+gfc_free_constructor (gfc_constructor *p)
+{
+ gfc_constructor *next;
+
+ if (p == NULL)
+ return;
+
+ for (; p; p = next)
+ {
+ next = p->next;
+
+ if (p->expr)
+ gfc_free_expr (p->expr);
+ if (p->iterator != NULL)
+ gfc_free_iterator (p->iterator, 1);
+ mpz_clear (p->n.offset);
+ mpz_clear (p->repeat);
+ gfc_free (p);
+ }
+}
+
/* Given an expression node that might be an array constructor and a
symbol, make sure that no iterators in this or child constructors
duplicate was found. */
static int
-check_duplicate_iterator (gfc_constructor_base base, gfc_symbol *master)
+check_duplicate_iterator (gfc_constructor *c, gfc_symbol *master)
{
- gfc_constructor *c;
gfc_expr *e;
- for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+ for (; c; c = c->next)
{
e = c->expr;
/* Forward declaration because these functions are mutually recursive. */
-static match match_array_cons_element (gfc_constructor_base *);
+static match match_array_cons_element (gfc_constructor **);
/* Match a list of array elements. */
static match
-match_array_list (gfc_constructor_base *result)
+match_array_list (gfc_constructor **result)
{
- gfc_constructor_base head;
- gfc_constructor *p;
+ gfc_constructor *p, *head, *tail, *new_cons;
gfc_iterator iter;
locus old_loc;
gfc_expr *e;
if (m != MATCH_YES)
goto cleanup;
+ tail = head;
+
if (gfc_match_char (',') != MATCH_YES)
{
m = MATCH_NO;
if (m == MATCH_ERROR)
goto cleanup;
- m = match_array_cons_element (&head);
+ m = match_array_cons_element (&new_cons);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto cleanup; /* Could be a complex constant */
}
+ tail->next = new_cons;
+ tail = new_cons;
+
if (gfc_match_char (',') != MATCH_YES)
{
if (n > 2)
goto cleanup;
}
- e = gfc_get_array_expr (BT_UNKNOWN, 0, &old_loc);
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_ARRAY;
+ e->where = old_loc;
e->value.constructor = head;
- p = gfc_constructor_append_expr (result, e, &gfc_current_locus);
+ p = gfc_get_constructor ();
+ p->where = gfc_current_locus;
p->iterator = gfc_get_iterator ();
*p->iterator = iter;
+ p->expr = e;
+ *result = p;
+
return MATCH_YES;
syntax:
m = MATCH_ERROR;
cleanup:
- gfc_constructor_free (head);
+ gfc_free_constructor (head);
gfc_free_iterator (&iter, 0);
gfc_current_locus = old_loc;
return m;
single expression or a list of elements. */
static match
-match_array_cons_element (gfc_constructor_base *result)
+match_array_cons_element (gfc_constructor **result)
{
+ gfc_constructor *p;
gfc_expr *expr;
match m;
if (m != MATCH_YES)
return m;
- gfc_constructor_append_expr (result, expr, &gfc_current_locus);
+ p = gfc_get_constructor ();
+ p->where = gfc_current_locus;
+ p->expr = expr;
+
+ *result = p;
return MATCH_YES;
}
match
gfc_match_array_constructor (gfc_expr **result)
{
- gfc_constructor_base head, new_cons;
+ gfc_constructor *head, *tail, *new_cons;
gfc_expr *expr;
gfc_typespec ts;
locus where;
end_delim = " /)";
where = gfc_current_locus;
- head = new_cons = NULL;
+ head = tail = NULL;
seen_ts = false;
/* Try to match an optional "type-spec ::" */
for (;;)
{
- m = match_array_cons_element (&head);
+ m = match_array_cons_element (&new_cons);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO)
goto syntax;
+ if (head == NULL)
+ head = new_cons;
+ else
+ tail->next = new_cons;
+
+ tail = new_cons;
+
if (gfc_match_char (',') == MATCH_NO)
break;
}
goto syntax;
done:
+ expr = gfc_get_expr ();
+
+ expr->expr_type = EXPR_ARRAY;
+
+ expr->value.constructor = head;
/* Size must be calculated at resolution time. */
+
if (seen_ts)
- {
- expr = gfc_get_array_expr (ts.type, ts.kind, &where);
- expr->ts = ts;
- }
+ expr->ts = ts;
else
- expr = gfc_get_array_expr (BT_UNKNOWN, 0, &where);
-
- expr->value.constructor = head;
+ expr->ts.type = BT_UNKNOWN;
+
if (expr->ts.u.cl)
expr->ts.u.cl->length_from_typespec = seen_ts;
+ expr->where = where;
+ expr->rank = 1;
+
*result = expr;
return MATCH_YES;
gfc_error ("Syntax error in array constructor at %C");
cleanup:
- gfc_constructor_free (head);
+ gfc_free_constructor (head);
return MATCH_ERROR;
}
/* Recursive work function for gfc_check_constructor_type(). */
static gfc_try
-check_constructor_type (gfc_constructor_base base, bool convert)
+check_constructor_type (gfc_constructor *c, bool convert)
{
- gfc_constructor *c;
gfc_expr *e;
- for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+ for (; c; c = c->next)
{
e = c->expr;
static cons_stack *base;
-static gfc_try check_constructor (gfc_constructor_base, gfc_try (*) (gfc_expr *));
+static gfc_try check_constructor (gfc_constructor *, gfc_try (*) (gfc_expr *));
/* Check an EXPR_VARIABLE expression in a constructor to make sure
that that variable is an iteration variables. */
constructor, giving variables with the names of iterators a pass. */
static gfc_try
-check_constructor (gfc_constructor_base ctor, gfc_try (*check_function) (gfc_expr *))
+check_constructor (gfc_constructor *c, gfc_try (*check_function) (gfc_expr *))
{
cons_stack element;
gfc_expr *e;
gfc_try t;
- gfc_constructor *c;
- for (c = gfc_constructor_first (ctor); c; c = gfc_constructor_next (c))
+ for (; c; c = c->next)
{
e = c->expr;
typedef struct
{
- gfc_constructor_base base;
+ gfc_constructor *new_head, *new_tail;
int extract_count, extract_n;
gfc_expr *extracted;
mpz_t *count;
mpz_t *offset;
gfc_component *component;
+ mpz_t *repeat;
gfc_try (*expand_work_function) (gfc_expr *);
}
static expand_info current_expand;
-static gfc_try expand_constructor (gfc_constructor_base);
+static gfc_try expand_constructor (gfc_constructor *);
/* Work function that counts the number of elements present in a
static gfc_try
expand (gfc_expr *e)
{
- gfc_constructor *c = gfc_constructor_append_expr (¤t_expand.base,
- e, &e->where);
+ if (current_expand.new_head == NULL)
+ current_expand.new_head = current_expand.new_tail =
+ gfc_get_constructor ();
+ else
+ {
+ current_expand.new_tail->next = gfc_get_constructor ();
+ current_expand.new_tail = current_expand.new_tail->next;
+ }
+
+ current_expand.new_tail->where = e->where;
+ current_expand.new_tail->expr = e;
- c->n.component = current_expand.component;
+ mpz_set (current_expand.new_tail->n.offset, *current_expand.offset);
+ current_expand.new_tail->n.component = current_expand.component;
+ mpz_set (current_expand.new_tail->repeat, *current_expand.repeat);
return SUCCESS;
}
if (p == NULL)
return; /* Variable not found */
- gfc_replace_expr (e, gfc_get_int_expr (gfc_default_integer_kind, NULL, 0));
+ gfc_replace_expr (e, gfc_int_expr (0));
mpz_set (e->value.integer, p->value);
passed expression. */
static gfc_try
-expand_constructor (gfc_constructor_base base)
+expand_constructor (gfc_constructor *c)
{
- gfc_constructor *c;
gfc_expr *e;
- for (c = gfc_constructor_first (base); c; c = gfc_constructor_next(c))
+ for (; c; c = c->next)
{
if (c->iterator != NULL)
{
gfc_free_expr (e);
return FAILURE;
}
- current_expand.offset = &c->offset;
+ current_expand.offset = &c->n.offset;
current_expand.component = c->n.component;
+ current_expand.repeat = &c->repeat;
if (current_expand.expand_work_function (e) == FAILURE)
return FAILURE;
}
}
-/* Given an array expression and an element number (starting at zero),
- return a pointer to the array element. NULL is returned if the
- size of the array has been exceeded. The expression node returned
- remains a part of the array and should not be freed. Access is not
- efficient at all, but this is another place where things do not
- have to be particularly fast. */
-
-static gfc_expr *
-gfc_get_array_element (gfc_expr *array, int element)
-{
- expand_info expand_save;
- gfc_expr *e;
- gfc_try rc;
-
- expand_save = current_expand;
- current_expand.extract_n = element;
- current_expand.expand_work_function = extract_element;
- current_expand.extracted = NULL;
- current_expand.extract_count = 0;
-
- iter_stack = NULL;
-
- rc = expand_constructor (array->value.constructor);
- e = current_expand.extracted;
- current_expand = expand_save;
-
- if (rc == FAILURE)
- return NULL;
-
- return e;
-}
-
-
/* Top level subroutine for expanding constructors. We only expand
constructor if they are small enough. */
gfc_expr *f;
gfc_try rc;
- /* If we can successfully get an array element at the max array size then
- the array is too big to expand, so we just return. */
f = gfc_get_array_element (e, gfc_option.flag_max_array_constructor);
if (f != NULL)
{
return SUCCESS;
}
- /* We now know the array is not too big so go ahead and try to expand it. */
expand_save = current_expand;
- current_expand.base = NULL;
+ current_expand.new_head = current_expand.new_tail = NULL;
iter_stack = NULL;
if (expand_constructor (e->value.constructor) == FAILURE)
{
- gfc_constructor_free (current_expand.base);
+ gfc_free_constructor (current_expand.new_head);
rc = FAILURE;
goto done;
}
- gfc_constructor_free (e->value.constructor);
- e->value.constructor = current_expand.base;
+ gfc_free_constructor (e->value.constructor);
+ e->value.constructor = current_expand.new_head;
rc = SUCCESS;
{
expand_info expand_save;
gfc_try rc;
+ gfc_constructor * con;
+
+ rc = SUCCESS;
- iter_stack = NULL;
- expand_save = current_expand;
- current_expand.expand_work_function = is_constant_element;
+ if (e->value.constructor
+ && e->value.constructor->expr->expr_type == EXPR_ARRAY)
+ {
+ /* Expand the constructor. */
+ iter_stack = NULL;
+ expand_save = current_expand;
+ current_expand.expand_work_function = is_constant_element;
- rc = expand_constructor (e->value.constructor);
+ rc = expand_constructor (e->value.constructor);
+
+ current_expand = expand_save;
+ }
+ else
+ {
+ /* No need to expand this further. */
+ for (con = e->value.constructor; con; con = con->next)
+ {
+ if (con->expr->expr_type == EXPR_CONSTANT)
+ continue;
+ else
+ {
+ if (!gfc_is_constant_expr (con->expr))
+ rc = FAILURE;
+ }
+ }
+ }
- current_expand = expand_save;
if (rc == FAILURE)
return 0;
int
gfc_expanded_ac (gfc_expr *e)
{
- gfc_constructor *c;
+ gfc_constructor *p;
if (e->expr_type == EXPR_ARRAY)
- for (c = gfc_constructor_first (e->value.constructor);
- c; c = gfc_constructor_next (c))
- if (c->iterator != NULL || !gfc_expanded_ac (c->expr))
+ for (p = e->value.constructor; p; p = p->next)
+ if (p->iterator != NULL || !gfc_expanded_ac (p->expr))
return 0;
return 1;
be of the same type. */
static gfc_try
-resolve_array_list (gfc_constructor_base base)
+resolve_array_list (gfc_constructor *p)
{
gfc_try t;
- gfc_constructor *c;
t = SUCCESS;
- for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
+ for (; p; p = p->next)
{
- if (c->iterator != NULL
- && gfc_resolve_iterator (c->iterator, false) == FAILURE)
+ if (p->iterator != NULL
+ && gfc_resolve_iterator (p->iterator, false) == FAILURE)
t = FAILURE;
- if (gfc_resolve_expr (c->expr) == FAILURE)
+ if (gfc_resolve_expr (p->expr) == FAILURE)
t = FAILURE;
}
if (expr->ts.u.cl == NULL)
{
- for (p = gfc_constructor_first (expr->value.constructor);
- p; p = gfc_constructor_next (p))
+ for (p = expr->value.constructor; p; p = p->next)
if (p->expr->ts.u.cl != NULL)
{
/* Ensure that if there is a char_len around that it is
/* Check that all constant string elements have the same length until
we reach the end or find a variable-length one. */
- for (p = gfc_constructor_first (expr->value.constructor);
- p; p = gfc_constructor_next (p))
+ for (p = expr->value.constructor; p; p = p->next)
{
int current_length = -1;
gfc_ref *ref;
gcc_assert (found_length != -1);
/* Update the character length of the array constructor. */
- expr->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, found_length);
+ expr->ts.u.cl->length = gfc_int_expr (found_length);
}
else
{
(without typespec) all elements are verified to have the same length
anyway. */
if (found_length != -1)
- for (p = gfc_constructor_first (expr->value.constructor);
- p; p = gfc_constructor_next (p))
+ for (p = expr->value.constructor; p; p = p->next)
if (p->expr->expr_type == EXPR_CONSTANT)
{
gfc_expr *cl = NULL;
/* Copy an iterator structure. */
-gfc_iterator *
-gfc_copy_iterator (gfc_iterator *src)
+static gfc_iterator *
+copy_iterator (gfc_iterator *src)
{
gfc_iterator *dest;
}
+/* Copy a constructor structure. */
+
+gfc_constructor *
+gfc_copy_constructor (gfc_constructor *src)
+{
+ gfc_constructor *dest;
+ gfc_constructor *tail;
+
+ if (src == NULL)
+ return NULL;
+
+ dest = tail = NULL;
+ while (src)
+ {
+ if (dest == NULL)
+ dest = tail = gfc_get_constructor ();
+ else
+ {
+ tail->next = gfc_get_constructor ();
+ tail = tail->next;
+ }
+ tail->where = src->where;
+ tail->expr = gfc_copy_expr (src->expr);
+ tail->iterator = copy_iterator (src->iterator);
+ mpz_set (tail->n.offset, src->n.offset);
+ tail->n.component = src->n.component;
+ mpz_set (tail->repeat, src->repeat);
+ src = src->next;
+ }
+
+ return dest;
+}
+
+
+/* Given an array expression and an element number (starting at zero),
+ return a pointer to the array element. NULL is returned if the
+ size of the array has been exceeded. The expression node returned
+ remains a part of the array and should not be freed. Access is not
+ efficient at all, but this is another place where things do not
+ have to be particularly fast. */
+
+gfc_expr *
+gfc_get_array_element (gfc_expr *array, int element)
+{
+ expand_info expand_save;
+ gfc_expr *e;
+ gfc_try rc;
+
+ expand_save = current_expand;
+ current_expand.extract_n = element;
+ current_expand.expand_work_function = extract_element;
+ current_expand.extracted = NULL;
+ current_expand.extract_count = 0;
+
+ iter_stack = NULL;
+
+ rc = expand_constructor (array->value.constructor);
+ e = current_expand.extracted;
+ current_expand = expand_save;
+
+ if (rc == FAILURE)
+ return NULL;
+
+ return e;
+}
+
+
/********* Subroutines for determining the size of an array *********/
/* These are needed just to accommodate RESHAPE(). There are no
for (ref = e->ref; ref; ref = ref->next)
if (ref->type == REF_ARRAY
- && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION
- || (ref->u.ar.type == AR_ELEMENT && ref->u.ar.dimen == 0)))
+ && (ref->u.ar.type == AR_FULL || ref->u.ar.type == AR_SECTION))
break;
if (ref == NULL)
#include "match.h"
#include "parse.h"
#include "flags.h"
-#include "constructor.h"
+
/* Macros to access allocate memory for gfc_data_variable,
gfc_data_value and gfc_data. */
/************************ Declaration statements *********************/
-
-/* Auxilliary function to merge DIMENSION and CODIMENSION array specs. */
-
-static void
-merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
-{
- int i;
-
- if (to->rank == 0 && from->rank > 0)
- {
- to->rank = from->rank;
- to->type = from->type;
- to->cray_pointee = from->cray_pointee;
- to->cp_was_assumed = from->cp_was_assumed;
-
- for (i = 0; i < to->corank; i++)
- {
- to->lower[from->rank + i] = to->lower[i];
- to->upper[from->rank + i] = to->upper[i];
- }
- for (i = 0; i < from->rank; i++)
- {
- if (copy)
- {
- to->lower[i] = gfc_copy_expr (from->lower[i]);
- to->upper[i] = gfc_copy_expr (from->upper[i]);
- }
- else
- {
- to->lower[i] = from->lower[i];
- to->upper[i] = from->upper[i];
- }
- }
- }
- else if (to->corank == 0 && from->corank > 0)
- {
- to->corank = from->corank;
- to->cotype = from->cotype;
-
- for (i = 0; i < from->corank; i++)
- {
- if (copy)
- {
- to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
- to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
- }
- else
- {
- to->lower[to->rank + i] = from->lower[i];
- to->upper[to->rank + i] = from->upper[i];
- }
- }
- }
-}
-
-
/* Match an intent specification. Since this can only happen after an
INTENT word, a legal intent-spec must follow. */
if (gfc_notify_std (GFC_STD_F95_OBS, "Obsolescent feature: "
"Old-style character length at %C") == FAILURE)
return MATCH_ERROR;
- *expr = gfc_get_int_expr (gfc_default_integer_kind, NULL, length);
+ *expr = gfc_int_expr (length);
return m;
}
sym->attr.class_ok = (sym->attr.dummy
|| sym->attr.pointer
|| sym->attr.allocatable) ? 1 : 0;
- gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as, false);
+ gfc_build_class_symbol (&sym->ts, &sym->attr, &sym->as);
}
return SUCCESS;
if (init->expr_type == EXPR_CONSTANT)
{
clen = init->value.character.length;
- sym->ts.u.cl->length
- = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, clen);
+ sym->ts.u.cl->length = gfc_int_expr (clen);
}
else if (init->expr_type == EXPR_ARRAY)
{
- gfc_constructor *c;
- c = gfc_constructor_first (init->value.constructor);
- clen = c->expr->value.character.length;
- sym->ts.u.cl->length
- = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, clen);
+ gfc_expr *p = init->value.constructor->expr;
+ clen = p->value.character.length;
+ sym->ts.u.cl->length = gfc_int_expr (clen);
}
else if (init->ts.u.cl && init->ts.u.cl->length)
sym->ts.u.cl->length =
else if (sym->ts.u.cl->length->expr_type == EXPR_CONSTANT)
{
int len = mpz_get_si (sym->ts.u.cl->length->value.integer);
+ gfc_constructor * p;
if (init->expr_type == EXPR_CONSTANT)
gfc_set_constant_character_len (len, init, -1);
else if (init->expr_type == EXPR_ARRAY)
{
- gfc_constructor *c;
-
/* Build a new charlen to prevent simplification from
deleting the length before it is resolved. */
init->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
init->ts.u.cl->length = gfc_copy_expr (sym->ts.u.cl->length);
- for (c = gfc_constructor_first (init->value.constructor);
- c; c = gfc_constructor_next (c))
- gfc_set_constant_character_len (len, c->expr, -1);
+ for (p = init->value.constructor; p; p = p->next)
+ gfc_set_constant_character_len (len, p->expr, -1);
}
}
}
if (init->ts.is_iso_c)
sym->ts.f90_type = init->ts.f90_type;
}
-
+
/* Add initializer. Make sure we keep the ranks sane. */
if (sym->attr.dimension && init->rank == 0)
{
mpz_t size;
gfc_expr *array;
+ gfc_constructor *c;
int n;
if (sym->attr.flavor == FL_PARAMETER
&& init->expr_type == EXPR_CONSTANT
&& spec_size (sym->as, &size) == SUCCESS
&& mpz_cmp_si (size, 0) > 0)
{
- array = gfc_get_array_expr (init->ts.type, init->ts.kind,
- &init->where);
- for (n = 0; n < (int)mpz_get_si (size); n++)
- gfc_constructor_append_expr (&array->value.constructor,
- n == 0
- ? init
- : gfc_copy_expr (init),
+ array = gfc_start_constructor (init->ts.type, init->ts.kind,
&init->where);
-
+
+ array->value.constructor = c = NULL;
+ for (n = 0; n < (int)mpz_get_si (size); n++)
+ {
+ if (array->value.constructor == NULL)
+ {
+ array->value.constructor = c = gfc_get_constructor ();
+ c->expr = init;
+ }
+ else
+ {
+ c->next = gfc_get_constructor ();
+ c = c->next;
+ c->expr = gfc_copy_expr (init);
+ }
+ }
+
array->shape = gfc_get_shape (sym->as->rank);
for (n = 0; n < sym->as->rank; n++)
spec_dimen_size (sym->as, n, &array->shape[n]);
else if (mpz_cmp (c->ts.u.cl->length->value.integer,
c->initializer->ts.u.cl->length->value.integer))
{
- gfc_constructor *ctor;
- ctor = gfc_constructor_first (c->initializer->value.constructor);
+ bool has_ts;
+ gfc_constructor *ctor = c->initializer->value.constructor;
+
+ has_ts = (c->initializer->ts.u.cl
+ && c->initializer->ts.u.cl->length_from_typespec);
if (ctor)
{
int first_len;
- bool has_ts = (c->initializer->ts.u.cl
- && c->initializer->ts.u.cl->length_from_typespec);
/* Remember the length of the first element for checking
that all elements *in the constructor* have the same
gcc_assert (ctor->expr->ts.type == BT_CHARACTER);
first_len = ctor->expr->value.character.length;
- for ( ; ctor; ctor = gfc_constructor_next (ctor))
- if (ctor->expr->expr_type == EXPR_CONSTANT)
+ for (; ctor; ctor = ctor->next)
{
- gfc_set_constant_character_len (len, ctor->expr,
- has_ts ? -1 : first_len);
- ctor->expr->ts.u.cl->length = gfc_copy_expr (c->ts.u.cl->length);
+ if (ctor->expr->expr_type == EXPR_CONSTANT)
+ gfc_set_constant_character_len (len, ctor->expr,
+ has_ts ? -1 : first_len);
}
}
}
scalar:
if (c->ts.type == BT_CLASS)
- gfc_build_class_symbol (&c->ts, &c->attr, &c->as, true);
+ gfc_build_class_symbol (&c->ts, &c->attr, &c->as);
return t;
}
gfc_match_null (gfc_expr **result)
{
gfc_symbol *sym;
+ gfc_expr *e;
match m;
m = gfc_match (" null ( )");
|| gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
return MATCH_ERROR;
- *result = gfc_get_null_expr (&gfc_current_locus);
+ e = gfc_get_expr ();
+ e->where = gfc_current_locus;
+ e->expr_type = EXPR_NULL;
+ e->ts.type = BT_UNKNOWN;
+
+ *result = e;
return MATCH_YES;
}
if (m == MATCH_NO)
as = gfc_copy_array_spec (current_as);
- else if (current_as)
- merge_array_spec (current_as, as, true);
char_len = NULL;
cl = NULL;
cl = gfc_new_charlen (gfc_current_ns, NULL);
if (seen_length == 0)
- cl->length = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
+ cl->length = gfc_int_expr (1);
else
cl->length = len;
{
ts.kind = gfc_default_character_kind;
ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ ts.u.cl->length = gfc_int_expr (1);
}
/* Record the Successful match. */
seen[d]++;
seen_at[d] = gfc_current_locus;
- if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
+ if (d == DECL_DIMENSION)
{
- gfc_array_spec *as = NULL;
-
- m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
- d == DECL_CODIMENSION);
+ m = gfc_match_array_spec (¤t_as, true, false);
- if (current_as == NULL)
- current_as = as;
- else if (m == MATCH_YES)
+ if (m == MATCH_NO)
{
- merge_array_spec (as, current_as, false);
- gfc_free (as);
+ gfc_error ("Missing dimension specification at %C");
+ m = MATCH_ERROR;
}
+ if (m == MATCH_ERROR)
+ goto cleanup;
+ }
+
+ if (d == DECL_CODIMENSION)
+ {
+ m = gfc_match_array_spec (¤t_as, false, true);
+
if (m == MATCH_NO)
{
- if (d == DECL_CODIMENSION)
- gfc_error ("Missing codimension specification at %C");
- else
- gfc_error ("Missing dimension specification at %C");
+ gfc_error ("Missing codimension specification at %C");
m = MATCH_ERROR;
}
enum_initializer (gfc_expr *last_initializer, locus where)
{
gfc_expr *result;
- result = gfc_get_constant_expr (BT_INTEGER, gfc_c_int_kind, &where);
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_CONSTANT;
+ result->ts.type = BT_INTEGER;
+ result->ts.kind = gfc_c_int_kind;
+ result->where = where;
mpz_init (result->value.integer);
GFC_ISYM_IDATE,
GFC_ISYM_IEOR,
GFC_ISYM_IERRNO,
- GFC_ISYM_IMAGE_INDEX,
GFC_ISYM_INDEX,
GFC_ISYM_INT,
GFC_ISYM_INT2,
GFC_ISYM_KILL,
GFC_ISYM_KIND,
GFC_ISYM_LBOUND,
- GFC_ISYM_LCOBOUND,
GFC_ISYM_LEADZ,
GFC_ISYM_LEN,
GFC_ISYM_LEN_TRIM,
GFC_ISYM_SYSTEM_CLOCK,
GFC_ISYM_TAN,
GFC_ISYM_TANH,
- GFC_ISYM_THIS_IMAGE,
GFC_ISYM_TIME,
GFC_ISYM_TIME8,
GFC_ISYM_TINY,
GFC_ISYM_TRIM,
GFC_ISYM_TTYNAM,
GFC_ISYM_UBOUND,
- GFC_ISYM_UCOBOUND,
GFC_ISYM_UMASK,
GFC_ISYM_UNLINK,
GFC_ISYM_UNPACK,
}
init_local_integer;
-typedef enum
-{
- GFC_FCOARRAY_NONE = 0,
- GFC_FCOARRAY_SINGLE
-}
-gfc_fcoarray;
-
/************************* Structures *****************************/
/* Used for keeping things in balanced binary trees. */
unsigned extension:8; /* extension level of a derived type. */
unsigned is_class:1; /* is a CLASS container. */
unsigned class_ok:1; /* is a CLASS object with correct attributes. */
- unsigned vtab:1; /* is a derived type vtab, pointed to by CLASS objects. */
- unsigned vtype:1; /* is a derived type of a vtab. */
+ unsigned vtab:1; /* is a derived type vtab. */
/* These flags are both in the typespec and attribute. The attribute
list is what gets read from/written to a module file. The typespec
{
int rank; /* A rank of zero means that a variable is a scalar. */
int corank;
- array_type type, cotype;
+ array_type type;
struct gfc_expr *lower[GFC_MAX_DIMENSIONS], *upper[GFC_MAX_DIMENSIONS];
/* These two fields are used with the Cray Pointer extension. */
enum gfc_array_ref_dimen_type
{
- DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, DIMEN_STAR, DIMEN_UNKNOWN
+ DIMEN_ELEMENT = 1, DIMEN_RANGE, DIMEN_VECTOR, 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;
gfc_intrinsic_sym;
+typedef struct gfc_class_esym_list
+{
+ gfc_symbol *derived;
+ gfc_symbol *esym;
+ struct gfc_expr *hash_value;
+ struct gfc_class_esym_list *next;
+}
+gfc_class_esym_list;
+
+#define gfc_get_class_esym_list() XCNEW (gfc_class_esym_list)
+
/* Expression nodes. The expression node types deserve explanations,
since the last couple can be easily misconstrued:
#define GFC_RND_MODE GMP_RNDN
#define GFC_MPC_RND_MODE MPC_RNDNN
-typedef splay_tree gfc_constructor_base;
-
typedef struct gfc_expr
{
expr_t expr_type;
a function call in interface.c(gfc_extend_expr). */
unsigned int user_operator : 1;
+ /* Used to quickly find a given constructor by its offset. */
+ splay_tree con_by_offset;
+
/* If an expression comes from a Hollerith constant or compile-time
evaluation of a transfer statement, it may have a prescribed target-
memory representation, and these cannot always be backformed from
const char *name; /* Points to the ultimate name of the function */
gfc_intrinsic_sym *isym;
gfc_symbol *esym;
+ gfc_class_esym_list *class_esym;
}
function;
}
character;
- gfc_constructor_base constructor;
+ struct gfc_constructor *constructor;
}
value;
int warn_aliasing;
int warn_ampersand;
int warn_conversion;
- int warn_conversion_extra;
int warn_implicit_interface;
int warn_implicit_procedure;
int warn_line_truncation;
int warn_character_truncation;
int warn_array_temp;
int warn_align_commons;
- int warn_unused_dummy_argument;
int max_errors;
int flag_all_intrinsics;
int fpe;
int rtcheck;
- gfc_fcoarray coarray;
int warn_std;
int allow_std;
/* Constructor nodes for array and structure constructors. */
typedef struct gfc_constructor
{
- gfc_constructor_base base;
- mpz_t offset; /* Offset within a constructor, used as
- key within base. */
-
gfc_expr *expr;
gfc_iterator *iterator;
locus where;
-
- union
+ struct gfc_constructor *next;
+ struct
{
- gfc_component *component; /* Record the component being initialized. */
+ mpz_t offset; /* Record the offset of array element which appears in
+ data statement like "data a(5)/4/". */
+ gfc_component *component; /* Record the component being initialized. */
}
n;
+ mpz_t repeat; /* Record the repeat number of initial values in data
+ statement like "data a/5*10/". */
}
gfc_constructor;
/* options.c */
unsigned int gfc_init_options (unsigned int, const char **);
-int gfc_handle_option (size_t, const char *, int, int);
+int gfc_handle_option (size_t, const char *, int);
bool gfc_post_options (const char **);
/* f95-lang.c */
gfc_gsymbol *gfc_get_gsymbol (const char *);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);
+gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
+ gfc_array_spec **);
+gfc_symbol *gfc_find_derived_vtab (gfc_symbol *);
gfc_typebound_proc* gfc_get_typebound_proc (void);
gfc_symbol* gfc_get_derived_super_type (gfc_symbol*);
gfc_symbol* gfc_get_ultimate_derived_super_type (gfc_symbol*);
bool gfc_type_is_extension_of (gfc_symbol *, gfc_symbol *);
bool gfc_type_compatible (gfc_typespec *, gfc_typespec *);
+gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
+ const char*, bool, locus*);
+gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
+ const char*, bool, locus*);
+gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
+ gfc_intrinsic_op, bool,
+ locus*);
+gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
void gfc_copy_formal_args (gfc_symbol *, gfc_symbol *);
void gfc_copy_formal_args_intr (gfc_symbol *, gfc_intrinsic_sym *);
gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
-/* intrinsic.c -- true if working in an init-expr, false otherwise. */
-extern bool gfc_init_expr_flag;
+/* intrinsic.c */
+extern int gfc_init_expr;
/* Given a symbol that we have decided is intrinsic, mark it as such
by placing it into a special module that is otherwise impossible to
const char *gfc_extract_int (gfc_expr *, int *);
bool is_subref_array (gfc_expr *);
+void gfc_add_component_ref (gfc_expr *, const char *);
gfc_expr *gfc_build_conversion (gfc_expr *);
void gfc_free_ref_list (gfc_ref *);
void gfc_type_convert_binary (gfc_expr *, int);
int gfc_has_vector_index (gfc_expr *);
gfc_expr *gfc_get_expr (void);
-gfc_expr *gfc_get_array_expr (bt type, int kind, locus *);
-gfc_expr *gfc_get_null_expr (locus *);
-gfc_expr *gfc_get_operator_expr (locus *, gfc_intrinsic_op,gfc_expr *, gfc_expr *);
-gfc_expr *gfc_get_structure_constructor_expr (bt, int, locus *);
-gfc_expr *gfc_get_constant_expr (bt, int, locus *);
-gfc_expr *gfc_get_character_expr (int, locus *, const char *, int len);
-gfc_expr *gfc_get_int_expr (int, locus *, int);
-gfc_expr *gfc_get_logical_expr (int, locus *, bool);
-gfc_expr *gfc_get_iokind_expr (locus *, io_kind);
-
void gfc_free_expr (gfc_expr *);
void gfc_replace_expr (gfc_expr *, gfc_expr *);
+gfc_expr *gfc_int_expr (int);
+gfc_expr *gfc_logical_expr (int, locus *);
mpz_t *gfc_copy_shape (mpz_t *, int);
mpz_t *gfc_copy_shape_excluding (mpz_t *, int, gfc_expr *);
gfc_expr *gfc_copy_expr (gfc_expr *);
gfc_try gfc_check_pointer_assign (gfc_expr *, gfc_expr *);
gfc_try gfc_check_assign_symbol (gfc_symbol *, gfc_expr *);
-bool gfc_has_default_initializer (gfc_symbol *);
gfc_expr *gfc_default_initializer (gfc_typespec *);
gfc_expr *gfc_get_variable_expr (gfc_symtree *);
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;
/* array.c */
-gfc_iterator *gfc_copy_iterator (gfc_iterator *);
-
void gfc_free_array_spec (gfc_array_spec *);
gfc_array_ref *gfc_copy_array_ref (gfc_array_ref *);
int gfc_compare_array_spec (gfc_array_spec *, gfc_array_spec *);
+gfc_expr *gfc_start_constructor (bt, int, locus *);
+void gfc_append_constructor (gfc_expr *, gfc_expr *);
+void gfc_free_constructor (gfc_constructor *);
void gfc_simplify_iterator_var (gfc_expr *);
gfc_try gfc_expand_constructor (gfc_expr *);
int gfc_constant_ac (gfc_expr *);
gfc_try gfc_check_constructor_type (gfc_expr *);
gfc_try gfc_check_iter_variable (gfc_expr *);
gfc_try gfc_check_constructor (gfc_expr *, gfc_try (*)(gfc_expr *));
+gfc_constructor *gfc_copy_constructor (gfc_constructor *);
+gfc_expr *gfc_get_array_element (gfc_expr *, int);
gfc_try gfc_array_size (gfc_expr *, mpz_t *);
gfc_try gfc_array_dimen_size (gfc_expr *, int, mpz_t *);
gfc_try gfc_array_ref_shape (gfc_array_ref *, mpz_t *);
gfc_array_ref *gfc_find_array_ref (gfc_expr *);
+void gfc_insert_constructor (gfc_expr *, gfc_constructor *);
+gfc_constructor *gfc_get_constructor (void);
tree gfc_conv_array_initializer (tree type, gfc_expr *);
gfc_try spec_size (gfc_array_spec *, mpz_t *);
gfc_try spec_dimen_size (gfc_array_spec *, int, mpz_t *);
/* check.c */
gfc_try gfc_check_same_strlen (const gfc_expr*, const gfc_expr*, const char*);
-/* class.c */
-void gfc_add_component_ref (gfc_expr *, const char *);
-gfc_expr *gfc_class_null_initializer (gfc_typespec *);
-gfc_try gfc_build_class_symbol (gfc_typespec *, symbol_attribute *,
- gfc_array_spec **, bool);
-gfc_symbol *gfc_find_derived_vtab (gfc_symbol *, bool);
-gfc_symtree* gfc_find_typebound_proc (gfc_symbol*, gfc_try*,
- const char*, bool, locus*);
-gfc_symtree* gfc_find_typebound_user_op (gfc_symbol*, gfc_try*,
- const char*, bool, locus*);
-gfc_typebound_proc* gfc_find_typebound_intrinsic_op (gfc_symbol*, gfc_try*,
- gfc_intrinsic_op, bool,
- locus*);
-gfc_symtree* gfc_get_tbp_symtree (gfc_symtree**, const char*);
-
#endif /* GCC_GFORTRAN_H */
/* 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;
/* array.c. */
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_ref (gfc_array_ref *, gfc_array_spec *, int);
match gfc_match_array_constructor (gfc_expr **);
/* interface.c. */
/* 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. */
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;
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),
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),
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)
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)
case AB_DIMENSION:
attr->dimension = 1;
break;
+ case AB_CODIMENSION:
+ attr->codimension = 1;
+ break;
case AB_EXTERNAL:
attr->external = 1;
break;
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;
}
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]);
static void
parse_derived (void)
{
- int compiling_type, seen_private, seen_sequence, seen_component;
+ int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
gfc_statement st;
gfc_state_data s;
gfc_symbol *sym;
gfc_component *c;
+ error_flag = 0;
+
accept_statement (ST_DERIVED_DECL);
push_state (&s, COMP_DERIVED, gfc_new_block);
case ST_FINAL:
gfc_error ("FINAL declaration at %C must be inside CONTAINS");
+ error_flag = 1;
break;
case ST_END_TYPE:
endType:
compiling_type = 0;
- if (!seen_component)
- gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
- "definition at %C without components");
+ if (!seen_component
+ && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
+ "definition at %C without components")
+ == FAILURE))
+ error_flag = 1;
accept_statement (ST_END_TYPE);
break;
{
gfc_error ("PRIVATE statement in TYPE at %C must be inside "
"a MODULE");
+ error_flag = 1;
break;
}
{
gfc_error ("PRIVATE statement at %C must precede "
"structure components");
+ error_flag = 1;
break;
}
if (seen_private)
- gfc_error ("Duplicate PRIVATE statement at %C");
+ {
+ gfc_error ("Duplicate PRIVATE statement at %C");
+ error_flag = 1;
+ }
s.sym->component_access = ACCESS_PRIVATE;
{
gfc_error ("SEQUENCE statement at %C must precede "
"structure components");
+ error_flag = 1;
break;
}
if (seen_sequence)
{
gfc_error ("Duplicate SEQUENCE statement at %C");
+ error_flag = 1;
}
seen_sequence = 1;
break;
case ST_CONTAINS:
- gfc_notify_std (GFC_STD_F2003,
- "Fortran 2003: CONTAINS block in derived type"
- " definition at %C");
+ if (gfc_notify_std (GFC_STD_F2003,
+ "Fortran 2003: CONTAINS block in derived type"
+ " definition at %C") == FAILURE)
+ error_flag = 1;
accept_statement (ST_CONTAINS);
- parse_derived_contains ();
+ if (parse_derived_contains ())
+ error_flag = 1;
goto endType;
default:
sym->attr.proc_pointer_comp = 1;
/* Looking for coarray components. */
- if (c->attr.codimension
- || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
+ if (c->attr.codimension || c->attr.coarray_comp)
sym->attr.coarray_comp = 1;
/* Look for private components. */
static void
parse_enum (void)
{
+ int error_flag;
gfc_statement st;
int compiling_enum;
gfc_state_data s;
int seen_enumerator = 0;
+ error_flag = 0;
+
push_state (&s, COMP_ENUM, gfc_new_block);
compiling_enum = 1;
case ST_END_ENUM:
compiling_enum = 0;
if (!seen_enumerator)
- gfc_error ("ENUM declaration at %C has no ENUMERATORS");
+ {
+ gfc_error ("ENUM declaration at %C has no ENUMERATORS");
+ error_flag = 1;
+ }
accept_statement (st);
break;
{
if (current_state == COMP_NONE)
{
- if (new_state == COMP_FUNCTION && sym)
+ if (new_state == COMP_FUNCTION)
gfc_add_function (&sym->attr, sym->name, NULL);
- else if (new_state == COMP_SUBROUTINE && sym)
+ else if (new_state == COMP_SUBROUTINE)
gfc_add_subroutine (&sym->attr, sym->name, NULL);
current_state = new_state;
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 "
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;
/* 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)))
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;
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;
for (c = sym->components; c != NULL; c = c->next)
{
+ /* F2008, C442. */
+ if (c->attr.codimension
+ && (!c->attr.allocatable || 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))
+ {
+ 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)
}
}
+ if (sym->attr.codimension && sym->attr.allocatable
+ && sym->as->type != AS_DEFERRED)
+ gfc_error ("Allocatable coarray variable '%s' at %L must have "
+ "deferred shape", sym->name, &sym->declared_at);
+
+ /* 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, 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:
#include "gfortran.h"
#include "parse.h"
#include "match.h"
-#include "constructor.h"
/* Strings for all symbol attributes. We use these for dumping the
{
gfc_symtree *tmp_symtree;
gfc_symbol *tmp_sym;
- gfc_constructor *c;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, ptr_name);
tmp_sym->value->expr_type = EXPR_STRUCTURE;
tmp_sym->value->ts.type = BT_DERIVED;
tmp_sym->value->ts.u.derived = tmp_sym->ts.u.derived;
- gfc_constructor_append_expr (&tmp_sym->value->value.constructor, NULL, NULL);
- c = gfc_constructor_first (tmp_sym->value->value.constructor);
- c->expr = gfc_get_expr ();
- c->expr->expr_type = EXPR_NULL;
- c->expr->ts.is_iso_c = 1;
+ tmp_sym->value->value.constructor = gfc_get_constructor ();
+ tmp_sym->value->value.constructor->expr = gfc_get_expr ();
+ tmp_sym->value->value.constructor->expr->expr_type = EXPR_NULL;
+ tmp_sym->value->value.constructor->expr->ts.is_iso_c = 1;
/* Must declare c_null_ptr and c_null_funptr as having the
PARAMETER attribute so they can be used in init expressions. */
tmp_sym->attr.flavor = FL_PARAMETER;
param_sym->as->upper[i] = NULL;
}
param_sym->as->rank = 1;
- param_sym->as->lower[0] = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ param_sym->as->lower[0] = gfc_int_expr (1);
/* The extent is unknown until we get it. The length give us
the rank the incoming pointer. */
#define NAMED_CHARKNDCST(a,b,c) case a :
#include "iso-c-binding.def"
- tmp_sym->value = gfc_get_int_expr (gfc_default_integer_kind, NULL,
- c_interop_kinds_table[s].value);
+ tmp_sym->value = gfc_int_expr (c_interop_kinds_table[s].value);
/* Initialize an integer constant expression node. */
tmp_sym->attr.flavor = FL_PARAMETER;
/* Initialize an integer constant expression node for the
length of the character. */
- tmp_sym->value = gfc_get_character_expr (gfc_default_character_kind,
- &gfc_current_locus, NULL, 1);
+ tmp_sym->value = gfc_get_expr ();
+ tmp_sym->value->expr_type = EXPR_CONSTANT;
+ tmp_sym->value->ts.type = BT_CHARACTER;
+ tmp_sym->value->ts.kind = gfc_default_character_kind;
+ tmp_sym->value->where = gfc_current_locus;
tmp_sym->value->ts.is_c_interop = 1;
tmp_sym->value->ts.is_iso_c = 1;
tmp_sym->value->value.character.length = 1;
+ tmp_sym->value->value.character.string = gfc_get_wide_string (2);
tmp_sym->value->value.character.string[0]
= (gfc_char_t) c_interop_kinds_table[s].value;
+ tmp_sym->value->value.character.string[1] = '\0';
tmp_sym->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- tmp_sym->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
- NULL, 1);
+ tmp_sym->ts.u.cl->length = gfc_int_expr (1);
/* May not need this in both attr and ts, but do need in
attr for writing module file. */
else
return 0;
}
+
+
+/* Build a polymorphic CLASS entity, using the symbol that comes from
+ build_sym. A CLASS entity is represented by an encapsulating type,
+ which contains the declared type as '$data' component, plus a pointer
+ component '$vptr' which determines the dynamic type. */
+
+gfc_try
+gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
+ gfc_array_spec **as)
+{
+ char name[GFC_MAX_SYMBOL_LEN + 5];
+ gfc_symbol *fclass;
+ gfc_symbol *vtab;
+ gfc_component *c;
+
+ /* Determine the name of the encapsulating type. */
+ if ((*as) && (*as)->rank && attr->allocatable)
+ sprintf (name, ".class.%s.%d.a", ts->u.derived->name, (*as)->rank);
+ else if ((*as) && (*as)->rank)
+ sprintf (name, ".class.%s.%d", ts->u.derived->name, (*as)->rank);
+ else if (attr->allocatable)
+ sprintf (name, ".class.%s.a", ts->u.derived->name);
+ else
+ sprintf (name, ".class.%s", ts->u.derived->name);
+
+ gfc_find_symbol (name, ts->u.derived->ns, 0, &fclass);
+ if (fclass == NULL)
+ {
+ gfc_symtree *st;
+ /* If not there, create a new symbol. */
+ fclass = gfc_new_symbol (name, ts->u.derived->ns);
+ st = gfc_new_symtree (&ts->u.derived->ns->sym_root, name);
+ st->n.sym = fclass;
+ gfc_set_sym_referenced (fclass);
+ fclass->refs++;
+ fclass->ts.type = BT_UNKNOWN;
+ fclass->attr.abstract = ts->u.derived->attr.abstract;
+ if (ts->u.derived->f2k_derived)
+ fclass->f2k_derived = gfc_get_namespace (NULL, 0);
+ if (gfc_add_flavor (&fclass->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
+ return FAILURE;
+
+ /* Add component '$data'. */
+ if (gfc_add_component (fclass, "$data", &c) == FAILURE)
+ return FAILURE;
+ c->ts = *ts;
+ c->ts.type = BT_DERIVED;
+ c->attr.access = ACCESS_PRIVATE;
+ c->ts.u.derived = ts->u.derived;
+ c->attr.class_pointer = attr->pointer;
+ 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 ();
+ c->initializer->expr_type = EXPR_NULL;
+
+ /* Add component '$vptr'. */
+ if (gfc_add_component (fclass, "$vptr", &c) == FAILURE)
+ return FAILURE;
+ c->ts.type = BT_DERIVED;
+ vtab = gfc_find_derived_vtab (ts->u.derived);
+ gcc_assert (vtab);
+ c->ts.u.derived = vtab->ts.u.derived;
+ c->attr.pointer = 1;
+ c->initializer = gfc_get_expr ();
+ c->initializer->expr_type = EXPR_NULL;
+ }
+
+ /* Since the extension field is 8 bit wide, we can only have
+ up to 255 extension levels. */
+ if (ts->u.derived->attr.extension == 255)
+ {
+ gfc_error ("Maximum extension level reached with type '%s' at %L",
+ ts->u.derived->name, &ts->u.derived->declared_at);
+ return FAILURE;
+ }
+
+ fclass->attr.extension = ts->u.derived->attr.extension + 1;
+ fclass->attr.is_class = 1;
+ ts->u.derived = fclass;
+ attr->allocatable = attr->pointer = attr->dimension = 0;
+ (*as) = NULL; /* XXX */
+ return SUCCESS;
+}
+
+
+/* Find the symbol for a derived type's vtab. */
+
+gfc_symbol *
+gfc_find_derived_vtab (gfc_symbol *derived)
+{
+ gfc_namespace *ns;
+ gfc_symbol *vtab = NULL, *vtype = NULL;
+ char name[2 * GFC_MAX_SYMBOL_LEN + 8];
+
+ ns = gfc_current_ns;
+
+ for (; ns; ns = ns->parent)
+ if (!ns->parent)
+ break;
+
+ if (ns)
+ {
+ sprintf (name, "vtab$%s", derived->name);
+ gfc_find_symbol (name, ns, 0, &vtab);
+
+ if (vtab == NULL)
+ {
+ gfc_get_symbol (name, ns, &vtab);
+ vtab->ts.type = BT_DERIVED;
+ vtab->attr.flavor = FL_VARIABLE;
+ vtab->attr.target = 1;
+ vtab->attr.save = SAVE_EXPLICIT;
+ vtab->attr.vtab = 1;
+ vtab->attr.access = ACCESS_PRIVATE;
+ vtab->refs++;
+ gfc_set_sym_referenced (vtab);
+ sprintf (name, "vtype$%s", derived->name);
+
+ gfc_find_symbol (name, ns, 0, &vtype);
+ if (vtype == NULL)
+ {
+ gfc_component *c;
+ gfc_symbol *parent = NULL, *parent_vtab = NULL;
+
+ gfc_get_symbol (name, ns, &vtype);
+ if (gfc_add_flavor (&vtype->attr, FL_DERIVED,
+ NULL, &gfc_current_locus) == FAILURE)
+ return NULL;
+ vtype->refs++;
+ gfc_set_sym_referenced (vtype);
+ vtype->attr.access = ACCESS_PRIVATE;
+
+ /* Add component '$hash'. */
+ if (gfc_add_component (vtype, "$hash", &c) == FAILURE)
+ return NULL;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ c->initializer = gfc_int_expr (derived->hash_value);
+
+ /* Add component '$size'. */
+ if (gfc_add_component (vtype, "$size", &c) == FAILURE)
+ return NULL;
+ c->ts.type = BT_INTEGER;
+ c->ts.kind = 4;
+ c->attr.access = ACCESS_PRIVATE;
+ /* Remember the derived type in ts.u.derived,
+ so that the correct initializer can be set later on
+ (in gfc_conv_structure). */
+ c->ts.u.derived = derived;
+ c->initializer = gfc_int_expr (0);
+
+ /* Add component $extends. */
+ if (gfc_add_component (vtype, "$extends", &c) == FAILURE)
+ return NULL;
+ c->attr.pointer = 1;
+ c->attr.access = ACCESS_PRIVATE;
+ c->initializer = gfc_get_expr ();
+ parent = gfc_get_derived_super_type (derived);
+ if (parent)
+ {
+ parent_vtab = gfc_find_derived_vtab (parent);
+ c->ts.type = BT_DERIVED;
+ c->ts.u.derived = parent_vtab->ts.u.derived;
+ c->initializer->expr_type = EXPR_VARIABLE;
+ gfc_find_sym_tree (parent_vtab->name, parent_vtab->ns, 0,
+ &c->initializer->symtree);
+ }
+ else
+ {
+ c->ts.type = BT_DERIVED;
+ c->ts.u.derived = vtype;
+ c->initializer->expr_type = EXPR_NULL;
+ }
+ }
+ vtab->ts.u.derived = vtype;
+
+ vtab->value = gfc_default_initializer (&vtab->ts);
+ }
+ }
+
+ return vtab;
+}
+
+
+/* General worker function to find either a type-bound procedure or a
+ type-bound user operator. */
+
+static gfc_symtree*
+find_typebound_proc_uop (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, bool uop,
+ locus* where)
+{
+ gfc_symtree* res;
+ gfc_symtree* root;
+
+ /* Set correct symbol-root. */
+ gcc_assert (derived->f2k_derived);
+ root = (uop ? derived->f2k_derived->tb_uop_root
+ : derived->f2k_derived->tb_sym_root);
+
+ /* Set default to failure. */
+ if (t)
+ *t = FAILURE;
+
+ /* Try to find it in the current type's namespace. */
+ res = gfc_find_symtree (root, name);
+ if (res && res->n.tb && !res->n.tb->error)
+ {
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->n.tb->access == ACCESS_PRIVATE)
+ {
+ if (where)
+ gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ name, derived->name, where);
+ if (t)
+ *t = FAILURE;
+ }
+
+ return res;
+ }
+
+ /* Otherwise, recurse on parent type if derived is an extension. */
+ if (derived->attr.extension)
+ {
+ gfc_symbol* super_type;
+ super_type = gfc_get_derived_super_type (derived);
+ gcc_assert (super_type);
+
+ return find_typebound_proc_uop (super_type, t, name,
+ noaccess, uop, where);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+
+
+/* Find a type-bound procedure or user operator by name for a derived-type
+ (looking recursively through the super-types). */
+
+gfc_symtree*
+gfc_find_typebound_proc (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, locus* where)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, false, where);
+}
+
+gfc_symtree*
+gfc_find_typebound_user_op (gfc_symbol* derived, gfc_try* t,
+ const char* name, bool noaccess, locus* where)
+{
+ return find_typebound_proc_uop (derived, t, name, noaccess, true, where);
+}
+
+
+/* Find a type-bound intrinsic operator looking recursively through the
+ super-type hierarchy. */
+
+gfc_typebound_proc*
+gfc_find_typebound_intrinsic_op (gfc_symbol* derived, gfc_try* t,
+ gfc_intrinsic_op op, bool noaccess,
+ locus* where)
+{
+ gfc_typebound_proc* res;
+
+ /* Set default to failure. */
+ if (t)
+ *t = FAILURE;
+
+ /* Try to find it in the current type's namespace. */
+ if (derived->f2k_derived)
+ res = derived->f2k_derived->tb_op[op];
+ else
+ res = NULL;
+
+ /* Check access. */
+ if (res && !res->error)
+ {
+ /* We found one. */
+ if (t)
+ *t = SUCCESS;
+
+ if (!noaccess && derived->attr.use_assoc
+ && res->access == ACCESS_PRIVATE)
+ {
+ if (where)
+ gfc_error ("'%s' of '%s' is PRIVATE at %L",
+ gfc_op2string (op), derived->name, where);
+ if (t)
+ *t = FAILURE;
+ }
+
+ return res;
+ }
+
+ /* Otherwise, recurse on parent type if derived is an extension. */
+ if (derived->attr.extension)
+ {
+ gfc_symbol* super_type;
+ super_type = gfc_get_derived_super_type (derived);
+ gcc_assert (super_type);
+
+ return gfc_find_typebound_intrinsic_op (super_type, t, op,
+ noaccess, where);
+ }
+
+ /* Nothing found. */
+ return NULL;
+}
+
+
+/* Get a typebound-procedure symtree or create and insert it if not yet
+ present. This is like a very simplified version of gfc_get_sym_tree for
+ tbp-symtrees rather than regular ones. */
+
+gfc_symtree*
+gfc_get_tbp_symtree (gfc_symtree **root, const char *name)
+{
+ gfc_symtree *result;
+
+ result = gfc_find_symtree (*root, name);
+ if (!result)
+ {
+ result = gfc_new_symtree (root, name);
+ gcc_assert (result);
+ result->n.tb = NULL;
+ }
+
+ return result;
+}
2010-04-06 Tobias Burnus <burnus@net-b.de>
PR fortran/18918
+ * gfortran.dg/coarray_4.f90: New test.
+ * gfortran.dg/coarray_5.f90: New test.
+ * gfortran.dg/coarray_6.f90: New test.
+
+2010-04-06 Tobias Burnus <burnus@net-b.de>
+
+ PR fortran/18918
* gfortran.dg/iso_fortran_env_5.f90: New test.
* gfortran.dg/iso_fortran_env_6.f90: New test.
! { dg-do compile }
-! { dg-options "-fcoarray=single" }
!
! Coarray support -- corank declarations
! PR fortran/18918
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 :: a3(:)[*] ! { dg-error "deferred shape and non-deferred coshape" }
integer, allocatable :: a4[*] ! { dg-error "must have deferred shape" }
end subroutine invalid
! { dg-do compile }
-! { dg-options "-fcoarray=single" }
!
! Coarray support -- corank declarations
! PR fortran/18918
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