/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "arith.h"
#include "match.h"
#include "target-memory.h" /* for gfc_convert_boz */
+#include "constructor.h"
-/* Get a new expr node. */
+
+/* The following set of functions provide access to gfc_expr* of
+ various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
+
+ There are two functions available elsewhere that provide
+ slightly different flavours of variables. Namely:
+ expr.c (gfc_get_variable_expr)
+ symbol.c (gfc_lval_expr_from_sym)
+ TODO: Merge these functions, if possible. */
+
+/* Get a new expression node. */
gfc_expr *
gfc_get_expr (void)
e->shape = NULL;
e->ref = NULL;
e->symtree = NULL;
- e->con_by_offset = NULL;
return e;
}
-/* Free an argument list and everything below it. */
+/* Get a new expression node that is an array constructor
+ of given type and kind. */
-void
-gfc_free_actual_arglist (gfc_actual_arglist *a1)
+gfc_expr *
+gfc_get_array_expr (bt type, int kind, locus *where)
{
- gfc_actual_arglist *a2;
+ gfc_expr *e;
- while (a1)
- {
- a2 = a1->next;
- gfc_free_expr (a1->expr);
- gfc_free (a1);
- a1 = a2;
- }
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_ARRAY;
+ e->value.constructor = NULL;
+ e->rank = 1;
+ e->shape = NULL;
+
+ e->ts.type = type;
+ e->ts.kind = kind;
+ if (where)
+ e->where = *where;
+
+ return e;
}
-/* Copy an arglist structure and all of the arguments. */
+/* Get a new expression node that is the NULL expression. */
-gfc_actual_arglist *
-gfc_copy_actual_arglist (gfc_actual_arglist *p)
+gfc_expr *
+gfc_get_null_expr (locus *where)
{
- gfc_actual_arglist *head, *tail, *new_arg;
+ gfc_expr *e;
- head = tail = NULL;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_NULL;
+ e->ts.type = BT_UNKNOWN;
- for (; p; p = p->next)
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an operator expression node. */
+
+gfc_expr *
+gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
+ gfc_expr *op1, gfc_expr *op2)
+{
+ gfc_expr *e;
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_OP;
+ e->value.op.op = op;
+ e->value.op.op1 = op1;
+ e->value.op.op2 = op2;
+
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an structure constructor
+ of given type and kind. */
+
+gfc_expr *
+gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
+{
+ gfc_expr *e;
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_STRUCTURE;
+ e->value.constructor = NULL;
+
+ e->ts.type = type;
+ e->ts.kind = kind;
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an constant of given type and kind. */
+
+gfc_expr *
+gfc_get_constant_expr (bt type, int kind, locus *where)
+{
+ gfc_expr *e;
+
+ if (!where)
+ gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
+
+ e = gfc_get_expr ();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->ts.type = type;
+ e->ts.kind = kind;
+ e->where = *where;
+
+ switch (type)
{
- new_arg = gfc_get_actual_arglist ();
- *new_arg = *p;
+ case BT_INTEGER:
+ mpz_init (e->value.integer);
+ break;
- new_arg->expr = gfc_copy_expr (p->expr);
- new_arg->next = NULL;
+ case BT_REAL:
+ gfc_set_model_kind (kind);
+ mpfr_init (e->value.real);
+ break;
- if (head == NULL)
- head = new_arg;
- else
- tail->next = new_arg;
+ case BT_COMPLEX:
+ gfc_set_model_kind (kind);
+ mpc_init2 (e->value.complex, mpfr_get_default_prec());
+ break;
- tail = new_arg;
+ default:
+ break;
}
- return head;
+ return e;
}
-/* Free a list of reference structures. */
+/* Get a new expression node that is an string constant.
+ If no string is passed, a string of len is allocated,
+ blanked and null-terminated. */
-void
-gfc_free_ref_list (gfc_ref *p)
+gfc_expr *
+gfc_get_character_expr (int kind, locus *where, const char *src, int len)
{
- gfc_ref *q;
- int i;
+ gfc_expr *e;
+ gfc_char_t *dest;
- for (; p; p = q)
+ if (!src)
{
- q = p->next;
+ dest = gfc_get_wide_string (len + 1);
+ gfc_wide_memset (dest, ' ', len);
+ dest[len] = '\0';
+ }
+ else
+ dest = gfc_char_to_widechar (src);
- switch (p->type)
+ e = gfc_get_constant_expr (BT_CHARACTER, kind,
+ where ? where : &gfc_current_locus);
+ e->value.character.string = dest;
+ e->value.character.length = len;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an integer constant. */
+
+gfc_expr *
+gfc_get_int_expr (int kind, locus *where, int value)
+{
+ gfc_expr *p;
+ p = gfc_get_constant_expr (BT_INTEGER, kind,
+ where ? where : &gfc_current_locus);
+
+ mpz_init_set_si (p->value.integer, value);
+
+ return p;
+}
+
+
+/* Get a new expression node that is a logical constant. */
+
+gfc_expr *
+gfc_get_logical_expr (int kind, locus *where, bool value)
+{
+ gfc_expr *p;
+ p = gfc_get_constant_expr (BT_LOGICAL, kind,
+ where ? where : &gfc_current_locus);
+
+ p->value.logical = value;
+
+ return p;
+}
+
+
+gfc_expr *
+gfc_get_iokind_expr (locus *where, io_kind k)
+{
+ gfc_expr *e;
+
+ /* Set the types to something compatible with iokind. This is needed to
+ get through gfc_free_expr later since iokind really has no Basic Type,
+ BT, of its own. */
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_CONSTANT;
+ e->ts.type = BT_LOGICAL;
+ e->value.iokind = k;
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Given an expression pointer, return a copy of the expression. This
+ subroutine is recursive. */
+
+gfc_expr *
+gfc_copy_expr (gfc_expr *p)
+{
+ gfc_expr *q;
+ gfc_char_t *s;
+ char *c;
+
+ if (p == NULL)
+ return NULL;
+
+ q = gfc_get_expr ();
+ *q = *p;
+
+ switch (q->expr_type)
+ {
+ case EXPR_SUBSTRING:
+ s = gfc_get_wide_string (p->value.character.length + 1);
+ q->value.character.string = s;
+ memcpy (s, p->value.character.string,
+ (p->value.character.length + 1) * sizeof (gfc_char_t));
+ break;
+
+ case EXPR_CONSTANT:
+ /* Copy target representation, if it exists. */
+ if (p->representation.string)
{
- case REF_ARRAY:
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ c = XCNEWVEC (char, p->representation.length + 1);
+ q->representation.string = c;
+ memcpy (c, p->representation.string, (p->representation.length + 1));
+ }
+
+ /* Copy the values of any pointer components of p->value. */
+ switch (q->ts.type)
+ {
+ case BT_INTEGER:
+ mpz_init_set (q->value.integer, p->value.integer);
+ break;
+
+ case BT_REAL:
+ gfc_set_model_kind (q->ts.kind);
+ mpfr_init (q->value.real);
+ mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ gfc_set_model_kind (q->ts.kind);
+ mpc_init2 (q->value.complex, mpfr_get_default_prec());
+ mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ case BT_CHARACTER:
+ if (p->representation.string)
+ q->value.character.string
+ = gfc_char_to_widechar (q->representation.string);
+ else
{
- gfc_free_expr (p->u.ar.start[i]);
- gfc_free_expr (p->u.ar.end[i]);
- gfc_free_expr (p->u.ar.stride[i]);
- }
+ s = gfc_get_wide_string (p->value.character.length + 1);
+ q->value.character.string = s;
+ /* This is the case for the C_NULL_CHAR named constant. */
+ if (p->value.character.length == 0
+ && (p->ts.is_c_interop || p->ts.is_iso_c))
+ {
+ *s = '\0';
+ /* Need to set the length to 1 to make sure the NUL
+ terminator is copied. */
+ q->value.character.length = 1;
+ }
+ else
+ memcpy (s, p->value.character.string,
+ (p->value.character.length + 1) * sizeof (gfc_char_t));
+ }
break;
- case REF_SUBSTRING:
- gfc_free_expr (p->u.ss.start);
- gfc_free_expr (p->u.ss.end);
+ case BT_HOLLERITH:
+ case BT_LOGICAL:
+ case BT_DERIVED:
+ case BT_CLASS:
+ break; /* Already done. */
+
+ case BT_PROCEDURE:
+ case BT_VOID:
+ /* Should never be reached. */
+ case BT_UNKNOWN:
+ gfc_internal_error ("gfc_copy_expr(): Bad expr node");
+ /* Not reached. */
+ }
+
+ break;
+
+ case EXPR_OP:
+ switch (q->value.op.op)
+ {
+ case INTRINSIC_NOT:
+ case INTRINSIC_PARENTHESES:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
break;
- case REF_COMPONENT:
+ default: /* Binary operators. */
+ q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
+ q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
break;
}
- gfc_free (p);
+ break;
+
+ case EXPR_FUNCTION:
+ q->value.function.actual =
+ gfc_copy_actual_arglist (p->value.function.actual);
+ break;
+
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ q->value.compcall.actual =
+ gfc_copy_actual_arglist (p->value.compcall.actual);
+ q->value.compcall.tbp = p->value.compcall.tbp;
+ break;
+
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ q->value.constructor = gfc_constructor_copy (p->value.constructor);
+ break;
+
+ case EXPR_VARIABLE:
+ case EXPR_NULL:
+ break;
}
+
+ q->shape = gfc_copy_shape (p->shape, p->rank);
+
+ q->ref = gfc_copy_ref (p->ref);
+
+ return q;
}
break;
case BT_COMPLEX:
- mpfr_clear (e->value.complex.r);
- mpfr_clear (e->value.complex.i);
+ mpc_clear (e->value.complex);
break;
default:
gfc_free_actual_arglist (e->value.function.actual);
break;
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ gfc_free_actual_arglist (e->value.compcall.actual);
+ break;
+
case EXPR_VARIABLE:
break;
case EXPR_ARRAY:
case EXPR_STRUCTURE:
- gfc_free_constructor (e->value.constructor);
+ gfc_constructor_free (e->value.constructor);
break;
case EXPR_SUBSTRING:
{
if (e == NULL)
return;
- if (e->con_by_offset)
- splay_tree_delete (e->con_by_offset);
free_expr0 (e);
gfc_free (e);
}
+/* Free an argument list and everything below it. */
+
+void
+gfc_free_actual_arglist (gfc_actual_arglist *a1)
+{
+ gfc_actual_arglist *a2;
+
+ while (a1)
+ {
+ a2 = a1->next;
+ gfc_free_expr (a1->expr);
+ gfc_free (a1);
+ a1 = a2;
+ }
+}
+
+
+/* Copy an arglist structure and all of the arguments. */
+
+gfc_actual_arglist *
+gfc_copy_actual_arglist (gfc_actual_arglist *p)
+{
+ gfc_actual_arglist *head, *tail, *new_arg;
+
+ head = tail = NULL;
+
+ for (; p; p = p->next)
+ {
+ new_arg = gfc_get_actual_arglist ();
+ *new_arg = *p;
+
+ new_arg->expr = gfc_copy_expr (p->expr);
+ new_arg->next = NULL;
+
+ if (head == NULL)
+ head = new_arg;
+ else
+ tail->next = new_arg;
+
+ tail = new_arg;
+ }
+
+ return head;
+}
+
+
+/* Free a list of reference structures. */
+
+void
+gfc_free_ref_list (gfc_ref *p)
+{
+ gfc_ref *q;
+ int i;
+
+ for (; p; p = q)
+ {
+ q = p->next;
+
+ switch (p->type)
+ {
+ case REF_ARRAY:
+ for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ {
+ gfc_free_expr (p->u.ar.start[i]);
+ gfc_free_expr (p->u.ar.end[i]);
+ gfc_free_expr (p->u.ar.stride[i]);
+ }
+
+ break;
+
+ case REF_SUBSTRING:
+ gfc_free_expr (p->u.ss.start);
+ gfc_free_expr (p->u.ss.end);
+ break;
+
+ case REF_COMPONENT:
+ break;
+ }
+
+ gfc_free (p);
+ }
+}
+
+
/* Graft the *src expression onto the *dest subexpression. */
void
/* Recursively copy a list of reference structures. */
-static gfc_ref *
-copy_ref (gfc_ref *src)
+gfc_ref *
+gfc_copy_ref (gfc_ref *src)
{
gfc_array_ref *ar;
gfc_ref *dest;
break;
}
- dest->next = copy_ref (src->next);
+ dest->next = gfc_copy_ref (src->next);
return dest;
}
}
+/* Insert a reference to the component of the given name.
+ Only to be used with CLASS containers. */
+
+void
+gfc_add_component_ref (gfc_expr *e, const char *name)
+{
+ gfc_ref **tail = &(e->ref);
+ gfc_ref *next = NULL;
+ gfc_symbol *derived = e->symtree->n.sym->ts.u.derived;
+ while (*tail != NULL)
+ {
+ if ((*tail)->type == REF_COMPONENT)
+ derived = (*tail)->u.c.component->ts.u.derived;
+ if ((*tail)->type == REF_ARRAY && (*tail)->next == NULL)
+ break;
+ tail = &((*tail)->next);
+ }
+ if (*tail != NULL && strcmp (name, "$data") == 0)
+ next = *tail;
+ (*tail) = gfc_get_ref();
+ (*tail)->next = next;
+ (*tail)->type = REF_COMPONENT;
+ (*tail)->u.c.sym = derived;
+ (*tail)->u.c.component = gfc_find_component (derived, name, true, true);
+ gcc_assert((*tail)->u.c.component);
+ if (!next)
+ e->ts = (*tail)->u.c.component->ts;
+}
+
+
/* Copy a shape array. */
mpz_t *
for (n = 0; n < rank; n++)
mpz_init_set (new_shape[n], shape[n]);
- return new_shape;
-}
-
-
-/* Copy a shape array excluding dimension N, where N is an integer
- constant expression. Dimensions are numbered in fortran style --
- starting with ONE.
-
- So, if the original shape array contains R elements
- { s1 ... sN-1 sN sN+1 ... sR-1 sR}
- the result contains R-1 elements:
- { s1 ... sN-1 sN+1 ... sR-1}
-
- If anything goes wrong -- N is not a constant, its value is out
- of range -- or anything else, just returns NULL. */
-
-mpz_t *
-gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
-{
- mpz_t *new_shape, *s;
- int i, n;
-
- if (shape == NULL
- || rank <= 1
- || dim == NULL
- || dim->expr_type != EXPR_CONSTANT
- || dim->ts.type != BT_INTEGER)
- return NULL;
-
- n = mpz_get_si (dim->value.integer);
- n--; /* Convert to zero based index. */
- if (n < 0 || n >= rank)
- return NULL;
-
- s = new_shape = gfc_get_shape (rank - 1);
-
- for (i = 0; i < rank; i++)
- {
- if (i == n)
- continue;
- mpz_init_set (*s, shape[i]);
- s++;
- }
-
- return new_shape;
-}
-
-
-/* Given an expression pointer, return a copy of the expression. This
- subroutine is recursive. */
-
-gfc_expr *
-gfc_copy_expr (gfc_expr *p)
-{
- gfc_expr *q;
- gfc_char_t *s;
- char *c;
-
- if (p == NULL)
- return NULL;
-
- q = gfc_get_expr ();
- *q = *p;
-
- switch (q->expr_type)
- {
- case EXPR_SUBSTRING:
- s = gfc_get_wide_string (p->value.character.length + 1);
- q->value.character.string = s;
- memcpy (s, p->value.character.string,
- (p->value.character.length + 1) * sizeof (gfc_char_t));
- break;
-
- case EXPR_CONSTANT:
- /* Copy target representation, if it exists. */
- if (p->representation.string)
- {
- c = XCNEWVEC (char, p->representation.length + 1);
- q->representation.string = c;
- memcpy (c, p->representation.string, (p->representation.length + 1));
- }
-
- /* Copy the values of any pointer components of p->value. */
- switch (q->ts.type)
- {
- case BT_INTEGER:
- mpz_init_set (q->value.integer, p->value.integer);
- break;
-
- case BT_REAL:
- gfc_set_model_kind (q->ts.kind);
- mpfr_init (q->value.real);
- mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
- break;
-
- case BT_COMPLEX:
- gfc_set_model_kind (q->ts.kind);
- mpfr_init (q->value.complex.r);
- mpfr_init (q->value.complex.i);
- mpfr_set (q->value.complex.r, p->value.complex.r, GFC_RND_MODE);
- mpfr_set (q->value.complex.i, p->value.complex.i, GFC_RND_MODE);
- break;
-
- case BT_CHARACTER:
- if (p->representation.string)
- q->value.character.string
- = gfc_char_to_widechar (q->representation.string);
- else
- {
- s = gfc_get_wide_string (p->value.character.length + 1);
- q->value.character.string = s;
-
- /* This is the case for the C_NULL_CHAR named constant. */
- if (p->value.character.length == 0
- && (p->ts.is_c_interop || p->ts.is_iso_c))
- {
- *s = '\0';
- /* Need to set the length to 1 to make sure the NUL
- terminator is copied. */
- q->value.character.length = 1;
- }
- else
- memcpy (s, p->value.character.string,
- (p->value.character.length + 1) * sizeof (gfc_char_t));
- }
- break;
-
- case BT_HOLLERITH:
- case BT_LOGICAL:
- case BT_DERIVED:
- break; /* Already done. */
-
- case BT_PROCEDURE:
- case BT_VOID:
- /* Should never be reached. */
- case BT_UNKNOWN:
- gfc_internal_error ("gfc_copy_expr(): Bad expr node");
- /* Not reached. */
- }
-
- break;
-
- case EXPR_OP:
- switch (q->value.op.op)
- {
- case INTRINSIC_NOT:
- case INTRINSIC_PARENTHESES:
- case INTRINSIC_UPLUS:
- case INTRINSIC_UMINUS:
- q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
- break;
-
- default: /* Binary operators. */
- q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
- q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
- break;
- }
+ return new_shape;
+}
- break;
- case EXPR_FUNCTION:
- q->value.function.actual =
- gfc_copy_actual_arglist (p->value.function.actual);
- break;
+/* Copy a shape array excluding dimension N, where N is an integer
+ constant expression. Dimensions are numbered in fortran style --
+ starting with ONE.
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- q->value.constructor = gfc_copy_constructor (p->value.constructor);
- break;
+ So, if the original shape array contains R elements
+ { s1 ... sN-1 sN sN+1 ... sR-1 sR}
+ the result contains R-1 elements:
+ { s1 ... sN-1 sN+1 ... sR-1}
- case EXPR_VARIABLE:
- case EXPR_NULL:
- break;
- }
+ If anything goes wrong -- N is not a constant, its value is out
+ of range -- or anything else, just returns NULL. */
- q->shape = gfc_copy_shape (p->shape, p->rank);
+mpz_t *
+gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
+{
+ mpz_t *new_shape, *s;
+ int i, n;
+
+ if (shape == NULL
+ || rank <= 1
+ || dim == NULL
+ || dim->expr_type != EXPR_CONSTANT
+ || dim->ts.type != BT_INTEGER)
+ return NULL;
+
+ n = mpz_get_si (dim->value.integer);
+ n--; /* Convert to zero based index. */
+ if (n < 0 || n >= rank)
+ return NULL;
- q->ref = copy_ref (p->ref);
+ s = new_shape = gfc_get_shape (rank - 1);
- return q;
+ for (i = 0; i < rank; i++)
+ {
+ if (i == n)
+ continue;
+ mpz_init_set (*s, shape[i]);
+ s++;
+ }
+
+ return new_shape;
}
}
-/* Returns an expression node that is an integer constant. */
-
-gfc_expr *
-gfc_int_expr (int i)
-{
- gfc_expr *p;
-
- p = gfc_get_expr ();
-
- p->expr_type = EXPR_CONSTANT;
- p->ts.type = BT_INTEGER;
- p->ts.kind = gfc_default_integer_kind;
-
- p->where = gfc_current_locus;
- mpz_init_set_si (p->value.integer, i);
-
- return p;
-}
-
-
-/* Returns an expression node that is a logical constant. */
-
-gfc_expr *
-gfc_logical_expr (int i, locus *where)
-{
- gfc_expr *p;
-
- p = gfc_get_expr ();
-
- p->expr_type = EXPR_CONSTANT;
- p->ts.type = BT_LOGICAL;
- p->ts.kind = gfc_default_logical_kind;
-
- if (where == NULL)
- where = &gfc_current_locus;
- p->where = *where;
- p->value.logical = i;
-
- return p;
-}
-
-
/* Return an expression node with an optional argument list attached.
A variable number of gfc_expr pointers are strung together in an
argument list with a NULL pointer terminating the list. */
/* Given an expression node with some sort of numeric binary
expression, insert type conversions required to make the operands
- have the same type.
+ have the same type. Conversion warnings are disabled if wconversion
+ is set to 0.
The exception is that the operands of an exponential don't have to
have the same type. If possible, the base is promoted to the type
1.0**2 stays as it is. */
void
-gfc_type_convert_binary (gfc_expr *e)
+gfc_type_convert_binary (gfc_expr *e, int wconversion)
{
gfc_expr *op1, *op2;
}
if (op1->ts.kind > op2->ts.kind)
- gfc_convert_type (op2, &op1->ts, 2);
+ gfc_convert_type_warn (op2, &op1->ts, 2, wconversion);
else
- gfc_convert_type (op1, &op2->ts, 2);
+ gfc_convert_type_warn (op1, &op2->ts, 2, wconversion);
e->ts = op1->ts;
goto done;
if (e->value.op.op == INTRINSIC_POWER)
goto done;
- gfc_convert_type (e->value.op.op2, &e->ts, 2);
+ gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
goto done;
}
if (op1->ts.type == BT_INTEGER)
{
e->ts = op2->ts;
- gfc_convert_type (e->value.op.op1, &e->ts, 2);
+ gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
goto done;
}
else
e->ts.kind = op2->ts.kind;
if (op1->ts.type != BT_COMPLEX || op1->ts.kind != e->ts.kind)
- gfc_convert_type (e->value.op.op1, &e->ts, 2);
+ gfc_convert_type_warn (e->value.op.op1, &e->ts, 2, wconversion);
if (op2->ts.type != BT_COMPLEX || op2->ts.kind != e->ts.kind)
- gfc_convert_type (e->value.op.op2, &e->ts, 2);
+ gfc_convert_type_warn (e->value.op.op2, &e->ts, 2, wconversion);
done:
return;
{
gfc_constructor *c;
gfc_actual_arglist *arg;
- int rv;
if (e == NULL)
return 1;
switch (e->expr_type)
{
case EXPR_OP:
- rv = (gfc_is_constant_expr (e->value.op.op1)
- && (e->value.op.op2 == NULL
- || gfc_is_constant_expr (e->value.op.op2)));
- break;
+ return (gfc_is_constant_expr (e->value.op.op1)
+ && (e->value.op.op2 == NULL
+ || gfc_is_constant_expr (e->value.op.op2)));
case EXPR_VARIABLE:
- rv = 0;
- break;
+ return 0;
case EXPR_FUNCTION:
+ case EXPR_PPC:
+ case EXPR_COMPCALL:
/* Specification functions are constant. */
if (check_specification_function (e) == MATCH_YES)
- {
- rv = 1;
- break;
- }
+ return 1;
/* Call to intrinsic with at least one argument. */
- rv = 0;
if (e->value.function.isym && e->value.function.actual)
{
for (arg = e->value.function.actual; arg; arg = arg->next)
- {
- if (!gfc_is_constant_expr (arg->expr))
- break;
- }
- if (arg == NULL)
- rv = 1;
+ if (!gfc_is_constant_expr (arg->expr))
+ return 0;
+
+ return 1;
}
- break;
+ else
+ return 0;
case EXPR_CONSTANT:
case EXPR_NULL:
- rv = 1;
- break;
+ return 1;
case EXPR_SUBSTRING:
- rv = e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
- && gfc_is_constant_expr (e->ref->u.ss.end));
- break;
+ return e->ref == NULL || (gfc_is_constant_expr (e->ref->u.ss.start)
+ && gfc_is_constant_expr (e->ref->u.ss.end));
case EXPR_STRUCTURE:
- rv = 0;
- for (c = e->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (e->value.constructor);
+ c; c = gfc_constructor_next (c))
if (!gfc_is_constant_expr (c->expr))
- break;
+ return 0;
- if (c == NULL)
- rv = 1;
- break;
+ return 1;
case EXPR_ARRAY:
- rv = gfc_constant_ac (e);
- break;
+ return gfc_constant_ac (e);
default:
gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
+ return 0;
}
-
- return rv;
}
/* Try to collapse intrinsic expressions. */
-static try
+static gfc_try
simplify_intrinsic_op (gfc_expr *p, int type)
{
gfc_intrinsic_op op;
/* Subroutine to simplify constructor expressions. Mutually recursive
with gfc_simplify_expr(). */
-static try
-simplify_constructor (gfc_constructor *c, int type)
+static gfc_try
+simplify_constructor (gfc_constructor_base base, int type)
{
+ gfc_constructor *c;
gfc_expr *p;
- for (; c; c = c->next)
+ for (c = gfc_constructor_first (base); c; c = gfc_constructor_next (c))
{
if (c->iterator
&& (gfc_simplify_expr (c->iterator->start, type) == FAILURE
/* Pull a single array element out of an array constructor. */
-static try
-find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
+static gfc_try
+find_array_element (gfc_constructor_base base, gfc_array_ref *ar,
gfc_constructor **rval)
{
unsigned long nelemen;
mpz_t offset;
mpz_t span;
mpz_t tmp;
+ gfc_constructor *cons;
gfc_expr *e;
- try t;
+ gfc_try t;
t = SUCCESS;
e = NULL;
mpz_init_set_ui (span, 1);
for (i = 0; i < ar->dimen; i++)
{
+ if (gfc_reduce_init_expr (ar->as->lower[i]) == FAILURE
+ || gfc_reduce_init_expr (ar->as->upper[i]) == FAILURE)
+ {
+ t = FAILURE;
+ cons = NULL;
+ goto depart;
+ }
+
e = gfc_copy_expr (ar->start[i]);
if (e->expr_type != EXPR_CONSTANT)
{
cons = NULL;
goto depart;
}
- /* Check the bounds. */
+
+ gcc_assert (ar->as->upper[i]->expr_type == EXPR_CONSTANT
+ && ar->as->lower[i]->expr_type == EXPR_CONSTANT);
+
+ /* Check the bounds. */
if ((ar->as->upper[i]
- && ar->as->upper[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp (e->value.integer,
- ar->as->upper[i]->value.integer) > 0)
- ||
- (ar->as->lower[i]->expr_type == EXPR_CONSTANT
- && mpz_cmp (e->value.integer,
- ar->as->lower[i]->value.integer) < 0))
+ && mpz_cmp (e->value.integer,
+ ar->as->upper[i]->value.integer) > 0)
+ || (mpz_cmp (e->value.integer,
+ ar->as->lower[i]->value.integer) < 0))
{
gfc_error ("Index in dimension %d is out of bounds "
"at %L", i + 1, &ar->c_where[i]);
mpz_mul (span, span, tmp);
}
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
- {
- if (cons)
- {
- if (cons->iterator)
- {
- cons = NULL;
-
- goto depart;
- }
- cons = cons->next;
- }
- }
+ for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
+ cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
+ {
+ if (cons->iterator)
+ {
+ cons = NULL;
+ goto depart;
+ }
+ }
depart:
mpz_clear (delta);
/* Find a component of a structure constructor. */
static gfc_constructor *
-find_component_ref (gfc_constructor *cons, gfc_ref *ref)
+find_component_ref (gfc_constructor_base base, gfc_ref *ref)
{
gfc_component *comp;
gfc_component *pick;
+ gfc_constructor *c = gfc_constructor_first (base);
comp = ref->u.c.sym->components;
pick = ref->u.c.component;
while (comp != pick)
{
comp = comp->next;
- cons = cons->next;
+ c = gfc_constructor_next (c);
}
- return cons;
+ return c;
}
{
gfc_expr *e;
- e = cons->expr;
- cons->expr = NULL;
+ if (cons)
+ {
+ e = cons->expr;
+ cons->expr = NULL;
+ }
+ else
+ e = gfc_copy_expr (p);
e->ref = p->ref->next;
p->ref->next = NULL;
gfc_replace_expr (p, e);
/* Pull an array section out of an array constructor. */
-static try
+static gfc_try
find_array_section (gfc_expr *expr, gfc_ref *ref)
{
int idx;
mpz_t tmp_mpz;
mpz_t nelts;
mpz_t ptr;
- mpz_t index;
- gfc_constructor *cons;
- gfc_constructor *base;
+ gfc_constructor_base base;
+ gfc_constructor *cons, *vecsub[GFC_MAX_DIMENSIONS];
gfc_expr *begin;
gfc_expr *finish;
gfc_expr *step;
gfc_expr *upper;
gfc_expr *lower;
- gfc_constructor *vecsub[GFC_MAX_DIMENSIONS], *c;
- try t;
+ gfc_try t;
t = SUCCESS;
if (ref->u.ar.dimen_type[d] == DIMEN_VECTOR) /* Vector subscript. */
{
+ gfc_constructor *ci;
gcc_assert (begin);
if (begin->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (begin))
}
gcc_assert (begin->rank == 1);
- gcc_assert (begin->shape);
+ /* Zero-sized arrays have no shape and no elements, stop early. */
+ if (!begin->shape)
+ {
+ mpz_init_set_ui (nelts, 0);
+ break;
+ }
- vecsub[d] = begin->value.constructor;
+ vecsub[d] = gfc_constructor_first (begin->value.constructor);
mpz_set (ctr[d], vecsub[d]->expr->value.integer);
mpz_mul (nelts, nelts, begin->shape[0]);
mpz_set (expr->shape[shape_i++], begin->shape[0]);
/* Check bounds. */
- for (c = vecsub[d]; c; c = c->next)
+ for (ci = vecsub[d]; ci; ci = gfc_constructor_next (ci))
{
- if (mpz_cmp (c->expr->value.integer, upper->value.integer) > 0
- || mpz_cmp (c->expr->value.integer,
+ if (mpz_cmp (ci->expr->value.integer, upper->value.integer) > 0
+ || mpz_cmp (ci->expr->value.integer,
lower->value.integer) < 0)
{
gfc_error ("index in dimension %d is out of bounds "
mpz_mul (delta_mpz, delta_mpz, tmp_mpz);
}
- mpz_init (index);
mpz_init (ptr);
- cons = base;
+ cons = gfc_constructor_first (base);
/* Now clock through the array reference, calculating the index in
the source constructor and transferring the elements to the new
{
gcc_assert(vecsub[d]);
- if (!vecsub[d]->next)
- vecsub[d] = ref->u.ar.start[d]->value.constructor;
+ if (!gfc_constructor_next (vecsub[d]))
+ vecsub[d] = gfc_constructor_first (ref->u.ar.start[d]->value.constructor);
else
{
- vecsub[d] = vecsub[d]->next;
+ vecsub[d] = gfc_constructor_next (vecsub[d]);
incr_ctr = false;
}
mpz_set (ctr[d], vecsub[d]->expr->value.integer);
}
}
- /* There must be a better way of dealing with negative strides
- than resetting the index and the constructor pointer! */
- if (mpz_cmp (ptr, index) < 0)
- {
- mpz_set_ui (index, 0);
- cons = base;
- }
-
- while (cons && cons->next && mpz_cmp (ptr, index) > 0)
- {
- mpz_add_ui (index, index, one);
- cons = cons->next;
- }
-
- gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
+ cons = gfc_constructor_lookup (base, mpz_get_ui (ptr));
+ gcc_assert (cons);
+ gfc_constructor_append_expr (&expr->value.constructor,
+ gfc_copy_expr (cons->expr), NULL);
}
mpz_clear (ptr);
- mpz_clear (index);
cleanup:
mpz_clear (ctr[d]);
mpz_clear (stride[d]);
}
- gfc_free_constructor (base);
+ gfc_constructor_free (base);
return t;
}
/* Pull a substring out of an expression. */
-static try
+static gfc_try
find_substring_ref (gfc_expr *p, gfc_expr **newp)
{
int end;
/* Simplify a subobject reference of a constructor. This occurs when
parameter variable values are substituted. */
-static try
+static gfc_try
simplify_const_ref (gfc_expr *p)
{
- gfc_constructor *cons;
+ gfc_constructor *cons, *c;
gfc_expr *newp;
+ gfc_ref *last_ref;
while (p->ref)
{
switch (p->ref->u.ar.type)
{
case AR_ELEMENT:
+ /* <type/kind spec>, parameter :: x(<int>) = scalar_expr
+ will generate this. */
+ if (p->expr_type != EXPR_ARRAY)
+ {
+ remove_subobject_ref (p, NULL);
+ break;
+ }
if (find_array_element (p->value.constructor, &p->ref->u.ar,
&cons) == FAILURE)
return FAILURE;
if (p->ref->next != NULL
&& (p->ts.type == BT_CHARACTER || p->ts.type == BT_DERIVED))
{
- cons = p->value.constructor;
- for (; cons; cons = cons->next)
+ for (c = gfc_constructor_first (p->value.constructor);
+ c; c = gfc_constructor_next (c))
+ {
+ c->expr->ref = gfc_copy_ref (p->ref->next);
+ if (simplify_const_ref (c->expr) == FAILURE)
+ return FAILURE;
+ }
+
+ if (p->ts.type == BT_DERIVED
+ && p->ref->next
+ && (c = gfc_constructor_first (p->value.constructor)))
+ {
+ /* There may have been component references. */
+ p->ts = c->expr->ts;
+ }
+
+ last_ref = p->ref;
+ for (; last_ref->next; last_ref = last_ref->next) {};
+
+ if (p->ts.type == BT_CHARACTER
+ && last_ref->type == REF_SUBSTRING)
{
- cons->expr->ref = copy_ref (p->ref->next);
- simplify_const_ref (cons->expr);
+ /* If this is a CHARACTER array and we possibly took
+ a substring out of it, update the type-spec's
+ character length according to the first element
+ (as all should have the same length). */
+ int string_len;
+ if ((c = gfc_constructor_first (p->value.constructor)))
+ {
+ const gfc_expr* first = c->expr;
+ gcc_assert (first->expr_type == EXPR_CONSTANT);
+ gcc_assert (first->ts.type == BT_CHARACTER);
+ string_len = first->value.character.length;
+ }
+ else
+ string_len = 0;
+
+ if (!p->ts.u.cl)
+ p->ts.u.cl = gfc_new_charlen (p->symtree->n.sym->ns,
+ NULL);
+ else
+ gfc_free_expr (p->ts.u.cl->length);
+
+ p->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, string_len);
}
}
gfc_free_ref_list (p->ref);
/* Simplify a chain of references. */
-static try
+static gfc_try
simplify_ref_chain (gfc_ref *ref, int type)
{
int n;
/* Try to substitute the value of a parameter variable. */
-static try
+static gfc_try
simplify_parameter_variable (gfc_expr *p, int type)
{
gfc_expr *e;
- try t;
+ gfc_try t;
e = gfc_copy_expr (p->symtree->n.sym->value);
if (e == NULL)
/* Do not copy subobject refs for constant. */
if (e->expr_type != EXPR_CONSTANT && p->ref != NULL)
- e->ref = copy_ref (p->ref);
+ e->ref = gfc_copy_ref (p->ref);
t = gfc_simplify_expr (e, type);
/* Only use the simplification if it eliminated all subobject references. */
Returns FAILURE on error, SUCCESS otherwise.
NOTE: Will return SUCCESS even if the expression can not be simplified. */
-try
+gfc_try
gfc_simplify_expr (gfc_expr *p, int type)
{
gfc_actual_arglist *ap;
gfc_char_t *s;
int start, end;
+ start = 0;
if (p->ref && p->ref->u.ss.start)
{
gfc_extract_int (p->ref->u.ss.start, &start);
start--; /* Convert from one-based to zero-based. */
}
- else
- start = 0;
+ end = p->value.character.length;
if (p->ref && p->ref->u.ss.end)
gfc_extract_int (p->ref->u.ss.end, &end);
- else
- end = p->value.character.length;
s = gfc_get_wide_string (end - start + 2);
memcpy (s, p->value.character.string + start,
gfc_free (p->value.character.string);
p->value.character.string = s;
p->value.character.length = end - start;
- p->ts.cl = gfc_get_charlen ();
- p->ts.cl->next = gfc_current_ns->cl_list;
- gfc_current_ns->cl_list = p->ts.cl;
- p->ts.cl->length = gfc_int_expr (p->value.character.length);
+ p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
+ p->ts.u.cl->length = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL,
+ p->value.character.length);
gfc_free_ref_list (p->ref);
p->ref = NULL;
p->expr_type = EXPR_CONSTANT;
return FAILURE;
break;
+
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ gcc_unreachable ();
+ break;
}
return SUCCESS;
/* Check an intrinsic arithmetic operation to see if it is consistent
with some type of expression. */
-static try check_init_expr (gfc_expr *);
+static gfc_try check_init_expr (gfc_expr *);
/* Scalarize an expression for an elemental intrinsic call. */
-static try
+static gfc_try
scalarize_intrinsic_call (gfc_expr *e)
{
gfc_actual_arglist *a, *b;
- gfc_constructor *args[5], *ctor, *new_ctor;
+ gfc_constructor_base ctor;
+ gfc_constructor *args[5];
+ gfc_constructor *ci, *new_ctor;
gfc_expr *expr, *old;
int n, i, rank[5], array_arg;
-
+
/* Find which, if any, arguments are arrays. Assume that the old
expression carries the type information and that the first arg
that is an array expression carries all the shape information.*/
old = gfc_copy_expr (e);
- gfc_free_constructor (expr->value.constructor);
+ gfc_constructor_free (expr->value.constructor);
expr->value.constructor = NULL;
-
expr->ts = old->ts;
expr->where = old->where;
expr->expr_type = EXPR_ARRAY;
{
rank[n] = a->expr->rank;
ctor = a->expr->symtree->n.sym->value->value.constructor;
- args[n] = gfc_copy_constructor (ctor);
+ args[n] = gfc_constructor_first (ctor);
}
else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
{
rank[n] = a->expr->rank;
else
rank[n] = 1;
- args[n] = gfc_copy_constructor (a->expr->value.constructor);
+ ctor = gfc_constructor_copy (a->expr->value.constructor);
+ args[n] = gfc_constructor_first (ctor);
}
else
args[n] = NULL;
+
n++;
}
/* Using the array argument as the master, step through the array
calling the function for each element and advancing the array
constructors together. */
- ctor = args[array_arg - 1];
- new_ctor = NULL;
- for (; ctor; ctor = ctor->next)
+ for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
{
- if (expr->value.constructor == NULL)
- expr->value.constructor
- = new_ctor = gfc_get_constructor ();
+ new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
+ gfc_copy_expr (old), NULL);
+
+ gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
+ a = NULL;
+ b = old->value.function.actual;
+ for (i = 0; i < n; i++)
+ {
+ if (a == NULL)
+ new_ctor->expr->value.function.actual
+ = a = gfc_get_actual_arglist ();
else
{
- new_ctor->next = gfc_get_constructor ();
- new_ctor = new_ctor->next;
+ a->next = gfc_get_actual_arglist ();
+ a = a->next;
}
- new_ctor->expr = gfc_copy_expr (old);
- gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
- a = NULL;
- b = old->value.function.actual;
- for (i = 0; i < n; i++)
- {
- if (a == NULL)
- new_ctor->expr->value.function.actual
- = a = gfc_get_actual_arglist ();
- else
- {
- a->next = gfc_get_actual_arglist ();
- a = a->next;
- }
- if (args[i])
- a->expr = gfc_copy_expr (args[i]->expr);
- else
- a->expr = gfc_copy_expr (b->expr);
- b = b->next;
- }
+ if (args[i])
+ a->expr = gfc_copy_expr (args[i]->expr);
+ else
+ a->expr = gfc_copy_expr (b->expr);
+
+ b = b->next;
+ }
- /* Simplify the function calls. If the simplification fails, the
- error will be flagged up down-stream or the library will deal
- with it. */
- gfc_simplify_expr (new_ctor->expr, 0);
+ /* Simplify the function calls. If the simplification fails, the
+ error will be flagged up down-stream or the library will deal
+ with it. */
+ gfc_simplify_expr (new_ctor->expr, 0);
- for (i = 0; i < n; i++)
- if (args[i])
- args[i] = args[i]->next;
+ for (i = 0; i < n; i++)
+ if (args[i])
+ args[i] = gfc_constructor_next (args[i]);
- for (i = 1; i < n; i++)
- if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
- || (args[i] == NULL && args[array_arg - 1] != NULL)))
- goto compliance;
+ for (i = 1; i < n; i++)
+ if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+ || (args[i] == NULL && args[array_arg - 1] != NULL)))
+ goto compliance;
}
free_expr0 (e);
}
-static try
-check_intrinsic_op (gfc_expr *e, try (*check_function) (gfc_expr *))
+static gfc_try
+check_intrinsic_op (gfc_expr *e, gfc_try (*check_function) (gfc_expr *))
{
gfc_expr *op1 = e->value.op.op1;
gfc_expr *op2 = e->value.op.op2;
if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
goto not_numeric;
- if (e->value.op.op == INTRINSIC_POWER
- && check_function == check_init_expr && et0 (op2) != BT_INTEGER)
- {
- if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Noninteger "
- "exponent in an initialization "
- "expression at %L", &op2->where)
- == FAILURE)
- return FAILURE;
- }
-
break;
case INTRINSIC_CONCAT:
return FAILURE;
}
+/* F2003, 7.1.7 (3): In init expression, allocatable components
+ must not be data-initialized. */
+static gfc_try
+check_alloc_comp_init (gfc_expr *e)
+{
+ gfc_component *comp;
+ gfc_constructor *ctor;
+
+ gcc_assert (e->expr_type == EXPR_STRUCTURE);
+ gcc_assert (e->ts.type == BT_DERIVED);
+
+ for (comp = e->ts.u.derived->components,
+ ctor = gfc_constructor_first (e->value.constructor);
+ comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
+ {
+ if (comp->attr.allocatable
+ && ctor->expr->expr_type != EXPR_NULL)
+ {
+ gfc_error("Invalid initialization expression for ALLOCATABLE "
+ "component '%s' in structure constructor at %L",
+ comp->name, &ctor->expr->where);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
static match
check_init_expr_arguments (gfc_expr *e)
return MATCH_YES;
}
+static gfc_try check_restricted (gfc_expr *);
+
/* F95, 7.1.6.1, Initialization expressions, (7)
F2003, 7.1.7 Initialization expression, (8) */
with LEN, as required by the standard. */
if (i == 5 && not_restricted
&& ap->expr->symtree->n.sym->ts.type == BT_CHARACTER
- && ap->expr->symtree->n.sym->ts.cl->length == NULL)
+ && ap->expr->symtree->n.sym->ts.u.cl->length == NULL)
{
gfc_error ("Assumed character length variable '%s' in constant "
"expression at %L", e->symtree->n.sym->name, &e->where);
}
else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
return MATCH_ERROR;
+
+ if (not_restricted == 0
+ && ap->expr->expr_type != EXPR_VARIABLE
+ && check_restricted (ap->expr) == FAILURE)
+ return MATCH_ERROR;
}
return MATCH_YES;
"selected_real_kind", "transfer", "trim", NULL
};
+ static const char * const trans_func_f2003[] = {
+ "all", "any", "count", "dot_product", "matmul", "null", "pack",
+ "product", "repeat", "reshape", "selected_char_kind", "selected_int_kind",
+ "selected_real_kind", "spread", "sum", "transfer", "transpose",
+ "trim", "unpack", NULL
+ };
+
int i;
const char *name;
+ const char *const *functions;
if (!e->value.function.isym
|| !e->value.function.isym->transformational)
name = e->symtree->n.sym->name;
+ functions = (gfc_option.allow_std & GFC_STD_F2003)
+ ? trans_func_f2003 : trans_func_f95;
+
/* NULL() is dealt with below. */
if (strcmp ("null", name) == 0)
return MATCH_NO;
- for (i = 0; trans_func_f95[i]; i++)
- if (strcmp (trans_func_f95[i], name) == 0)
- break;
+ for (i = 0; functions[i]; i++)
+ if (strcmp (functions[i], name) == 0)
+ break;
- /* FIXME, F2003: implement translation of initialization
- expressions before enabling this check. For F95, error
- out if the transformational function is not in the list. */
-#if 0
- if (trans_func_f95[i] == NULL
- && gfc_notify_std (GFC_STD_F2003,
- "transformational intrinsic '%s' at %L is not permitted "
- "in an initialization expression", name, &e->where) == FAILURE)
- return MATCH_ERROR;
-#else
- if (trans_func_f95[i] == NULL)
+ if (functions[i] == NULL)
{
gfc_error("transformational intrinsic '%s' at %L is not permitted "
"in an initialization expression", name, &e->where);
return MATCH_ERROR;
}
-#endif
return check_init_expr_arguments (e);
}
intrinsics in the context of initialization expressions. If
FAILURE is returned an error message has been generated. */
-static try
+static gfc_try
check_init_expr (gfc_expr *e)
{
match m;
- try t;
+ gfc_try t;
if (e == NULL)
return SUCCESS;
case EXPR_FUNCTION:
t = FAILURE;
- if ((m = check_specification_function (e)) != MATCH_YES)
- {
- gfc_intrinsic_sym* isym;
- gfc_symbol* sym;
+ {
+ gfc_intrinsic_sym* isym;
+ gfc_symbol* sym;
- sym = e->symtree->n.sym;
- if (!gfc_is_intrinsic (sym, 0, e->where)
- || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
- {
- gfc_error ("Function '%s' in initialization expression at %L "
- "must be an intrinsic or a specification function",
- e->symtree->n.sym->name, &e->where);
- break;
- }
+ sym = e->symtree->n.sym;
+ if (!gfc_is_intrinsic (sym, 0, e->where)
+ || (m = gfc_intrinsic_func_interface (e, 0)) != MATCH_YES)
+ {
+ gfc_error ("Function '%s' in initialization expression at %L "
+ "must be an intrinsic function",
+ e->symtree->n.sym->name, &e->where);
+ break;
+ }
- if ((m = check_conversion (e)) == MATCH_NO
- && (m = check_inquiry (e, 1)) == MATCH_NO
- && (m = check_null (e)) == MATCH_NO
- && (m = check_transformational (e)) == MATCH_NO
- && (m = check_elemental (e)) == MATCH_NO)
- {
- gfc_error ("Intrinsic function '%s' at %L is not permitted "
- "in an initialization expression",
- e->symtree->n.sym->name, &e->where);
- m = MATCH_ERROR;
- }
+ if ((m = check_conversion (e)) == MATCH_NO
+ && (m = check_inquiry (e, 1)) == MATCH_NO
+ && (m = check_null (e)) == MATCH_NO
+ && (m = check_transformational (e)) == MATCH_NO
+ && (m = check_elemental (e)) == MATCH_NO)
+ {
+ gfc_error ("Intrinsic function '%s' at %L is not permitted "
+ "in an initialization expression",
+ e->symtree->n.sym->name, &e->where);
+ m = MATCH_ERROR;
+ }
- /* Try to scalarize an elemental intrinsic function that has an
- array argument. */
- isym = gfc_find_function (e->symtree->n.sym->name);
- if (isym && isym->elemental
- && (t = scalarize_intrinsic_call (e)) == SUCCESS)
- break;
- }
+ /* Try to scalarize an elemental intrinsic function that has an
+ array argument. */
+ isym = gfc_find_function (e->symtree->n.sym->name);
+ if (isym && isym->elemental
+ && (t = scalarize_intrinsic_call (e)) == SUCCESS)
+ break;
+ }
if (m == MATCH_YES)
t = gfc_simplify_expr (e, 0);
break;
case EXPR_STRUCTURE:
- if (e->ts.is_iso_c)
- t = SUCCESS;
- else
- t = gfc_check_constructor (e, check_init_expr);
+ t = e->ts.is_iso_c ? SUCCESS : FAILURE;
+ if (t == SUCCESS)
+ break;
+
+ t = check_alloc_comp_init (e);
+ if (t == FAILURE)
+ break;
+
+ t = gfc_check_constructor (e, check_init_expr);
+ if (t == FAILURE)
+ break;
+
break;
case EXPR_ARRAY:
return t;
}
+/* Reduces a general expression to an initialization expression (a constant).
+ This used to be part of gfc_match_init_expr.
+ Note that this function doesn't free the given expression on FAILURE. */
-/* Match an initialization expression. We work by first matching an
- expression, then reducing it to a constant. */
-
-match
-gfc_match_init_expr (gfc_expr **result)
+gfc_try
+gfc_reduce_init_expr (gfc_expr *expr)
{
- gfc_expr *expr;
- match m;
- try t;
-
- m = gfc_match_expr (&expr);
- if (m != MATCH_YES)
- return m;
+ gfc_try t;
gfc_init_expr = 1;
t = gfc_resolve_expr (expr);
gfc_init_expr = 0;
if (t == FAILURE)
+ return FAILURE;
+
+ if (expr->expr_type == EXPR_ARRAY)
{
- gfc_free_expr (expr);
- return MATCH_ERROR;
+ if (gfc_check_constructor_type (expr) == FAILURE)
+ return FAILURE;
+ if (gfc_expand_constructor (expr) == FAILURE)
+ return FAILURE;
}
- if (expr->expr_type == EXPR_ARRAY
- && (gfc_check_constructor_type (expr) == FAILURE
- || gfc_expand_constructor (expr) == FAILURE))
+ return SUCCESS;
+}
+
+
+/* Match an initialization expression. We work by first matching an
+ expression, then reducing it to a constant. The reducing it to
+ constant part requires a global variable to flag the prohibition
+ of a non-integer exponent in -std=f95 mode. */
+
+bool init_flag = false;
+
+match
+gfc_match_init_expr (gfc_expr **result)
+{
+ gfc_expr *expr;
+ match m;
+ gfc_try t;
+
+ expr = NULL;
+
+ init_flag = true;
+
+ m = gfc_match_expr (&expr);
+ if (m != MATCH_YES)
{
- gfc_free_expr (expr);
- return MATCH_ERROR;
+ init_flag = false;
+ return m;
}
- /* Not all inquiry functions are simplified to constant expressions
- so it is necessary to call check_inquiry again. */
- if (!gfc_is_constant_expr (expr) && check_inquiry (expr, 1) != MATCH_YES
- && !gfc_in_match_data ())
+ t = gfc_reduce_init_expr (expr);
+ if (t != SUCCESS)
{
- gfc_error ("Initialization expression didn't reduce %C");
+ gfc_free_expr (expr);
+ init_flag = false;
return MATCH_ERROR;
}
*result = expr;
+ init_flag = false;
return MATCH_YES;
}
-static try check_restricted (gfc_expr *);
-
/* Given an actual argument list, test to see that each argument is a
restricted expression and optionally if the expression type is
integer or character. */
-static try
+static gfc_try
restricted_args (gfc_actual_arglist *a)
{
for (; a; a = a->next)
/* Make sure a non-intrinsic function is a specification function. */
-static try
+static gfc_try
external_spec_function (gfc_expr *e)
{
gfc_symbol *f;
/* Check to see that a function reference to an intrinsic is a
restricted expression. */
-static try
+static gfc_try
restricted_intrinsic (gfc_expr *e)
{
/* TODO: Check constraints on inquiry functions. 7.1.6.2 (7). */
}
+/* Check the expressions of an actual arglist. Used by check_restricted. */
+
+static gfc_try
+check_arglist (gfc_actual_arglist* arg, gfc_try (*checker) (gfc_expr*))
+{
+ for (; arg; arg = arg->next)
+ if (checker (arg->expr) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
+/* Check the subscription expressions of a reference chain with a checking
+ function; used by check_restricted. */
+
+static gfc_try
+check_references (gfc_ref* ref, gfc_try (*checker) (gfc_expr*))
+{
+ int dim;
+
+ if (!ref)
+ return SUCCESS;
+
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ for (dim = 0; dim != ref->u.ar.dimen; ++dim)
+ {
+ if (checker (ref->u.ar.start[dim]) == FAILURE)
+ return FAILURE;
+ if (checker (ref->u.ar.end[dim]) == FAILURE)
+ return FAILURE;
+ if (checker (ref->u.ar.stride[dim]) == FAILURE)
+ return FAILURE;
+ }
+ break;
+
+ case REF_COMPONENT:
+ /* Nothing needed, just proceed to next reference. */
+ break;
+
+ case REF_SUBSTRING:
+ if (checker (ref->u.ss.start) == FAILURE)
+ return FAILURE;
+ if (checker (ref->u.ss.end) == FAILURE)
+ return FAILURE;
+ break;
+
+ default:
+ gcc_unreachable ();
+ break;
+ }
+
+ return check_references (ref->next, checker);
+}
+
+
/* Verify that an expression is a restricted expression. Like its
cousin check_init_expr(), an error message is generated if we
return FAILURE. */
-static try
+static gfc_try
check_restricted (gfc_expr *e)
{
- gfc_symbol *sym;
- try t;
+ gfc_symbol* sym;
+ gfc_try t;
if (e == NULL)
return SUCCESS;
break;
case EXPR_FUNCTION:
- t = e->value.function.esym ? external_spec_function (e)
- : restricted_intrinsic (e);
+ if (e->value.function.esym)
+ {
+ t = check_arglist (e->value.function.actual, &check_restricted);
+ if (t == SUCCESS)
+ t = external_spec_function (e);
+ }
+ else
+ {
+ if (e->value.function.isym && e->value.function.isym->inquiry)
+ t = SUCCESS;
+ else
+ t = check_arglist (e->value.function.actual, &check_restricted);
+
+ if (t == SUCCESS)
+ t = restricted_intrinsic (e);
+ }
break;
case EXPR_VARIABLE:
break;
}
+ /* Check reference chain if any. */
+ if (check_references (e->ref, &check_restricted) == FAILURE)
+ break;
+
/* gfc_is_formal_arg broadcasts that a formal argument list is being
processed in resolve.c(resolve_formal_arglist). This is done so
that host associated dummy array indices are accepted (PR23446).
This mechanism also does the same for the specification expressions
of array-valued functions. */
- if (sym->attr.in_common
- || sym->attr.use_assoc
- || sym->attr.dummy
- || sym->attr.implied_index
- || sym->ns != gfc_current_ns
- || (sym->ns->proc_name != NULL
- && sym->ns->proc_name->attr.flavor == FL_MODULE)
- || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
+ if (e->error
+ || sym->attr.in_common
+ || sym->attr.use_assoc
+ || sym->attr.dummy
+ || sym->attr.implied_index
+ || sym->attr.flavor == FL_PARAMETER
+ || (sym->ns && sym->ns == gfc_current_ns->parent)
+ || (sym->ns && gfc_current_ns->parent
+ && sym->ns == gfc_current_ns->parent->parent)
+ || (sym->ns->proc_name != NULL
+ && sym->ns->proc_name->attr.flavor == FL_MODULE)
+ || (gfc_is_formal_arg () && (sym->ns == gfc_current_ns)))
{
t = SUCCESS;
break;
gfc_error ("Variable '%s' cannot appear in the expression at %L",
sym->name, &e->where);
-
+ /* Prevent a repetition of the error. */
+ e->error = 1;
break;
case EXPR_NULL:
/* Check to see that an expression is a specification expression. If
we return FAILURE, an error has been generated. */
-try
+gfc_try
gfc_specification_expr (gfc_expr *e)
{
+ gfc_component *comp;
if (e == NULL)
return SUCCESS;
if (e->expr_type == EXPR_FUNCTION
&& !e->value.function.isym
&& !e->value.function.esym
- && !gfc_pure (e->symtree->n.sym))
+ && !gfc_pure (e->symtree->n.sym)
+ && (!gfc_is_proc_ptr_comp (e, &comp)
+ || !comp->attr.pure))
{
gfc_error ("Function '%s' at %L must be PURE",
e->symtree->n.sym->name, &e->where);
/* Given two expressions, make sure that the arrays are conformable. */
-try
-gfc_check_conformance (const char *optype_msgid, gfc_expr *op1, gfc_expr *op2)
+gfc_try
+gfc_check_conformance (gfc_expr *op1, gfc_expr *op2, const char *optype_msgid, ...)
{
int op1_flag, op2_flag, d;
mpz_t op1_size, op2_size;
- try t;
+ gfc_try t;
+
+ va_list argp;
+ char buffer[240];
if (op1->rank == 0 || op2->rank == 0)
return SUCCESS;
+ va_start (argp, optype_msgid);
+ vsnprintf (buffer, 240, optype_msgid, argp);
+ va_end (argp);
+
if (op1->rank != op2->rank)
{
- gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(optype_msgid),
+ gfc_error ("Incompatible ranks in %s (%d and %d) at %L", _(buffer),
op1->rank, op2->rank, &op1->where);
return FAILURE;
}
if (op1_flag && op2_flag && mpz_cmp (op1_size, op2_size) != 0)
{
gfc_error ("Different shape for %s at %L on dimension %d "
- "(%d and %d)", _(optype_msgid), &op1->where, d + 1,
+ "(%d and %d)", _(buffer), &op1->where, d + 1,
(int) mpz_get_si (op1_size),
(int) mpz_get_si (op2_size));
/* Given an assignable expression and an arbitrary expression, make
sure that the assignment can take place. */
-try
+gfc_try
gfc_check_assign (gfc_expr *lvalue, gfc_expr *rvalue, int conform)
{
gfc_symbol *sym;
has_pointer = sym->attr.pointer;
for (ref = lvalue->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
+ if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
{
has_pointer = 1;
break;
if (rvalue->expr_type == EXPR_NULL)
{
- if (lvalue->symtree->n.sym->attr.pointer
+ if (has_pointer && (ref == NULL || ref->next == NULL)
&& lvalue->symtree->n.sym->attr.data)
return SUCCESS;
else
}
}
- if (sym->attr.cray_pointee
- && lvalue->ref != NULL
- && lvalue->ref->u.ar.type == AR_FULL
- && lvalue->ref->u.ar.as->cp_was_assumed)
- {
- gfc_error ("Vector assignment to assumed-size Cray Pointee at %L "
- "is illegal", &lvalue->where);
- return FAILURE;
- }
-
/* This is possibly a typo: x = f() instead of x => f(). */
if (gfc_option.warn_surprising
&& rvalue->expr_type == EXPR_FUNCTION
/* Check size of array assignments. */
if (lvalue->rank != 0 && rvalue->rank != 0
- && gfc_check_conformance ("array assignment", lvalue, rvalue) != SUCCESS)
+ && gfc_check_conformance (lvalue, rvalue, "array assignment") != SUCCESS)
return FAILURE;
if (rvalue->is_boz && lvalue->ts.type != BT_INTEGER
we only check rvalue if it's not an assignment to NULL() or a
NULLIFY statement. */
-try
+gfc_try
gfc_check_pointer_assign (gfc_expr *lvalue, gfc_expr *rvalue)
{
symbol_attribute attr;
gfc_ref *ref;
int is_pure;
- int pointer, check_intent_in;
+ int pointer, check_intent_in, proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
&& !lvalue->symtree->n.sym->attr.proc_pointer)
}
if (lvalue->symtree->n.sym->attr.flavor == FL_PROCEDURE
- && lvalue->symtree->n.sym->attr.use_assoc)
+ && lvalue->symtree->n.sym->attr.use_assoc
+ && !lvalue->symtree->n.sym->attr.proc_pointer)
{
gfc_error ("'%s' in the pointer assignment at %L cannot be an "
"l-value since it is a procedure",
/* Check INTENT(IN), unless the object itself is the component or
sub-component of a pointer. */
check_intent_in = 1;
- pointer = lvalue->symtree->n.sym->attr.pointer
- | lvalue->symtree->n.sym->attr.proc_pointer;
+ pointer = lvalue->symtree->n.sym->attr.pointer;
+ proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
for (ref = lvalue->ref; ref; ref = ref->next)
{
if (pointer)
check_intent_in = 0;
- if (ref->type == REF_COMPONENT && ref->u.c.component->pointer)
- pointer = 1;
+ if (ref->type == REF_COMPONENT)
+ {
+ pointer = ref->u.c.component->attr.pointer;
+ proc_pointer = ref->u.c.component->attr.proc_pointer;
+ }
+
+ if (ref->type == REF_ARRAY && ref->next == NULL)
+ {
+ if (ref->u.ar.type == AR_FULL)
+ break;
+
+ if (ref->u.ar.type != AR_SECTION)
+ {
+ gfc_error ("Expected bounds specification for '%s' at %L",
+ lvalue->symtree->n.sym->name, &lvalue->where);
+ return FAILURE;
+ }
+
+ if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
+ "specification for '%s' in pointer assignment "
+ "at %L", lvalue->symtree->n.sym->name,
+ &lvalue->where) == FAILURE)
+ return FAILURE;
+
+ gfc_error ("Pointer bounds remapping at %L is not yet implemented "
+ "in gfortran", &lvalue->where);
+ /* TODO: See PR 29785. Add checks that all lbounds are specified and
+ either never or always the upper-bound; strides shall not be
+ present. */
+ return FAILURE;
+ }
}
if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
return FAILURE;
}
- if (!pointer)
+ if (!pointer && !proc_pointer
+ && !(lvalue->ts.type == BT_CLASS
+ && lvalue->ts.u.derived->components->attr.pointer))
{
gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
return FAILURE;
if (rvalue->expr_type == EXPR_NULL && rvalue->ts.type == BT_UNKNOWN)
return SUCCESS;
- /* TODO checks on rvalue for a procedure pointer assignment. */
- if (lvalue->symtree->n.sym->attr.proc_pointer)
- 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)
+ {
+ char err[200];
+ gfc_symbol *s1,*s2;
+ gfc_component *comp;
+ const char *name;
+
+ attr = gfc_expr_attr (rvalue);
+ if (!((rvalue->expr_type == EXPR_NULL)
+ || (rvalue->expr_type == EXPR_FUNCTION && attr.proc_pointer)
+ || (rvalue->expr_type == EXPR_VARIABLE && attr.proc_pointer)
+ || (rvalue->expr_type == EXPR_VARIABLE
+ && attr.flavor == FL_PROCEDURE)))
+ {
+ gfc_error ("Invalid procedure pointer assignment at %L",
+ &rvalue->where);
+ return FAILURE;
+ }
+ if (attr.abstract)
+ {
+ gfc_error ("Abstract interface '%s' is invalid "
+ "in procedure pointer assignment at %L",
+ rvalue->symtree->name, &rvalue->where);
+ return FAILURE;
+ }
+ /* Check for C727. */
+ if (attr.flavor == FL_PROCEDURE)
+ {
+ if (attr.proc == PROC_ST_FUNCTION)
+ {
+ gfc_error ("Statement function '%s' is invalid "
+ "in procedure pointer assignment at %L",
+ rvalue->symtree->name, &rvalue->where);
+ return FAILURE;
+ }
+ if (attr.proc == PROC_INTERNAL &&
+ gfc_notify_std (GFC_STD_F2008, "Internal procedure '%s' is "
+ "invalid in procedure pointer assignment at %L",
+ rvalue->symtree->name, &rvalue->where) == FAILURE)
+ return FAILURE;
+ }
+
+ /* Ensure that the calling convention is the same. As other attributes
+ such as DLLEXPORT may differ, one explicitly only tests for the
+ calling conventions. */
+ if (rvalue->expr_type == EXPR_VARIABLE
+ && lvalue->symtree->n.sym->attr.ext_attr
+ != rvalue->symtree->n.sym->attr.ext_attr)
+ {
+ symbol_attribute calls;
+
+ calls.ext_attr = 0;
+ gfc_add_ext_attribute (&calls, EXT_ATTR_CDECL, NULL);
+ gfc_add_ext_attribute (&calls, EXT_ATTR_STDCALL, NULL);
+ gfc_add_ext_attribute (&calls, EXT_ATTR_FASTCALL, NULL);
+
+ if ((calls.ext_attr & lvalue->symtree->n.sym->attr.ext_attr)
+ != (calls.ext_attr & rvalue->symtree->n.sym->attr.ext_attr))
+ {
+ gfc_error ("Mismatch in the procedure pointer assignment "
+ "at %L: mismatch in the calling convention",
+ &rvalue->where);
+ return FAILURE;
+ }
+ }
+
+ if (gfc_is_proc_ptr_comp (lvalue, &comp))
+ s1 = comp->ts.interface;
+ else
+ s1 = lvalue->symtree->n.sym;
+
+ if (gfc_is_proc_ptr_comp (rvalue, &comp))
+ {
+ s2 = comp->ts.interface;
+ name = comp->name;
+ }
+ else if (rvalue->expr_type == EXPR_FUNCTION)
+ {
+ s2 = rvalue->symtree->n.sym->result;
+ name = rvalue->symtree->n.sym->result->name;
+ }
+ else
+ {
+ s2 = rvalue->symtree->n.sym;
+ name = rvalue->symtree->n.sym->name;
+ }
+
+ if (s1 && s2 && !gfc_compare_interfaces (s1, s2, name, 0, 1,
+ err, sizeof(err)))
+ {
+ gfc_error ("Interface mismatch in procedure pointer assignment "
+ "at %L: %s", &rvalue->where, err);
+ return FAILURE;
+ }
+
+ return SUCCESS;
+ }
if (!gfc_compare_types (&lvalue->ts, &rvalue->ts))
{
return FAILURE;
}
- if (lvalue->ts.kind != rvalue->ts.kind)
+ if (lvalue->ts.type != BT_CLASS && lvalue->ts.kind != rvalue->ts.kind)
{
gfc_error ("Different kind type parameters in pointer "
"assignment at %L", &lvalue->where);
if (rvalue->expr_type == EXPR_NULL)
return SUCCESS;
- if (lvalue->ts.type == BT_CHARACTER
- && lvalue->ts.cl && rvalue->ts.cl
- && lvalue->ts.cl->length && rvalue->ts.cl->length
- && abs (gfc_dep_compare_expr (lvalue->ts.cl->length,
- rvalue->ts.cl->length)) == 1)
+ if (lvalue->ts.type == BT_CHARACTER)
{
- gfc_error ("Different character lengths in pointer "
- "assignment at %L", &lvalue->where);
- return FAILURE;
+ gfc_try t = gfc_check_same_strlen (lvalue, rvalue, "pointer assignment");
+ if (t == FAILURE)
+ return FAILURE;
}
if (rvalue->expr_type == EXPR_VARIABLE && is_subref_array (rvalue))
return FAILURE;
}
- if (attr.is_protected && attr.use_assoc)
+ if (attr.is_protected && attr.use_assoc
+ && !(attr.pointer || attr.proc_pointer))
{
gfc_error ("Pointer assignment target has PROTECTED "
"attribute at %L", &rvalue->where);
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;
}
/* Relative of gfc_check_assign() except that the lvalue is a single
symbol. Used for initialization assignments. */
-try
+gfc_try
gfc_check_assign_symbol (gfc_symbol *sym, gfc_expr *rvalue)
{
gfc_expr lvalue;
- try r;
+ gfc_try r;
memset (&lvalue, '\0', sizeof (gfc_expr));
lvalue.symtree->n.sym = sym;
lvalue.where = sym->declared_at;
- if (sym->attr.pointer || sym->attr.proc_pointer)
+ if (sym->attr.pointer || sym->attr.proc_pointer
+ || (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->components->attr.pointer
+ && rvalue->expr_type == EXPR_NULL))
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
r = gfc_check_assign (&lvalue, rvalue, 1);
gfc_expr *
gfc_default_initializer (gfc_typespec *ts)
{
- gfc_constructor *tail;
gfc_expr *init;
- gfc_component *c;
+ gfc_component *comp;
/* See if we have a default initializer. */
- for (c = ts->derived->components; c; c = c->next)
- if (c->initializer || c->allocatable)
+ for (comp = ts->u.derived->components; comp; comp = comp->next)
+ if (comp->initializer || comp->attr.allocatable)
break;
- if (!c)
+ if (!comp)
return NULL;
- /* Build the constructor. */
- init = gfc_get_expr ();
- init->expr_type = EXPR_STRUCTURE;
+ init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
+ &ts->u.derived->declared_at);
init->ts = *ts;
- init->where = ts->derived->declared_at;
- tail = NULL;
- for (c = ts->derived->components; c; c = c->next)
+ for (comp = ts->u.derived->components; comp; comp = comp->next)
{
- if (tail == NULL)
- init->value.constructor = tail = gfc_get_constructor ();
- else
- {
- tail->next = gfc_get_constructor ();
- tail = tail->next;
- }
+ gfc_constructor *ctor = gfc_constructor_get();
- if (c->initializer)
- tail->expr = gfc_copy_expr (c->initializer);
+ if (comp->initializer)
+ ctor->expr = gfc_copy_expr (comp->initializer);
- if (c->allocatable)
+ if (comp->attr.allocatable)
{
- tail->expr = gfc_get_expr ();
- tail->expr->expr_type = EXPR_NULL;
- tail->expr->ts = c->ts;
+ ctor->expr = gfc_get_expr ();
+ ctor->expr->expr_type = EXPR_NULL;
+ ctor->expr->ts = comp->ts;
}
+
+ gfc_constructor_append (&init->value.constructor, ctor);
}
+
return init;
}
}
+/* Returns the array_spec of a full array expression. A NULL is
+ returned otherwise. */
+gfc_array_spec *
+gfc_get_full_arrayspec_from_expr (gfc_expr *expr)
+{
+ gfc_array_spec *as;
+ gfc_ref *ref;
+
+ if (expr->rank == 0)
+ return NULL;
+
+ /* Follow any component references. */
+ if (expr->expr_type == EXPR_VARIABLE
+ || expr->expr_type == EXPR_CONSTANT)
+ {
+ as = expr->symtree->n.sym->as;
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ as = ref->u.c.component->as;
+ continue;
+
+ case REF_SUBSTRING:
+ continue;
+
+ case REF_ARRAY:
+ {
+ switch (ref->u.ar.type)
+ {
+ case AR_ELEMENT:
+ case AR_SECTION:
+ case AR_UNKNOWN:
+ as = NULL;
+ continue;
+
+ case AR_FULL:
+ break;
+ }
+ break;
+ }
+ }
+ }
+ }
+ else
+ as = NULL;
+
+ return as;
+}
+
+
/* General expression traversal function. */
bool
return true;
if (expr->ts.type == BT_CHARACTER
- && expr->ts.cl
- && expr->ts.cl->length
- && expr->ts.cl->length->expr_type != EXPR_CONSTANT
- && gfc_traverse_expr (expr->ts.cl->length, sym, func, f))
+ && expr->ts.u.cl
+ && expr->ts.u.cl->length
+ && expr->ts.u.cl->length->expr_type != EXPR_CONSTANT
+ && gfc_traverse_expr (expr->ts.u.cl->length, sym, func, f))
return true;
switch (expr->expr_type)
{
+ case EXPR_PPC:
+ case EXPR_COMPCALL:
case EXPR_FUNCTION:
for (args = expr->value.function.actual; args; args = args->next)
{
case EXPR_STRUCTURE:
case EXPR_ARRAY:
- for (c = expr->value.constructor; c; c = c->next)
+ for (c = gfc_constructor_first (expr->value.constructor);
+ c; c = gfc_constructor_next (c))
{
if (gfc_traverse_expr (c->expr, sym, func, f))
return true;
case REF_COMPONENT:
if (ref->u.c.component->ts.type == BT_CHARACTER
- && ref->u.c.component->ts.cl
- && ref->u.c.component->ts.cl->length
- && ref->u.c.component->ts.cl->length->expr_type
+ && ref->u.c.component->ts.u.cl
+ && ref->u.c.component->ts.u.cl->length
+ && ref->u.c.component->ts.u.cl->length->expr_type
!= EXPR_CONSTANT
- && gfc_traverse_expr (ref->u.c.component->ts.cl->length,
+ && gfc_traverse_expr (ref->u.c.component->ts.u.cl->length,
sym, func, f))
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))
{
gfc_traverse_expr (expr, NULL, expr_set_symbols_referenced, 0);
}
+
+
+/* Determine if an expression is a procedure pointer component. If yes, the
+ argument 'comp' will point to the component (provided that 'comp' was
+ provided). */
+
+bool
+gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+{
+ gfc_ref *ref;
+ bool ppc = false;
+
+ if (!expr || !expr->ref)
+ return false;
+
+ ref = expr->ref;
+ while (ref->next)
+ ref = ref->next;
+
+ if (ref->type == REF_COMPONENT)
+ {
+ ppc = ref->u.c.component->attr.proc_pointer;
+ if (ppc && comp)
+ *comp = ref->u.c.component;
+ }
+
+ return ppc;
+}
+
+
+/* Walk an expression tree and check each variable encountered for being typed.
+ If strict is not set, a top-level variable is tolerated untyped in -std=gnu
+ mode as is a basic arithmetic expression using those; this is for things in
+ legacy-code like:
+
+ INTEGER :: arr(n), n
+ INTEGER :: arr(n + 1), n
+
+ The namespace is needed for IMPLICIT typing. */
+
+static gfc_namespace* check_typed_ns;
+
+static bool
+expr_check_typed_help (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
+ int* f ATTRIBUTE_UNUSED)
+{
+ gfc_try t;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ gcc_assert (e->symtree);
+ t = gfc_check_symbol_typed (e->symtree->n.sym, check_typed_ns,
+ true, e->where);
+
+ return (t == FAILURE);
+}
+
+gfc_try
+gfc_expr_check_typed (gfc_expr* e, gfc_namespace* ns, bool strict)
+{
+ bool error_found;
+
+ /* If this is a top-level variable or EXPR_OP, do the check with strict given
+ to us. */
+ if (!strict)
+ {
+ if (e->expr_type == EXPR_VARIABLE && !e->ref)
+ return gfc_check_symbol_typed (e->symtree->n.sym, ns, strict, e->where);
+
+ if (e->expr_type == EXPR_OP)
+ {
+ gfc_try t = SUCCESS;
+
+ gcc_assert (e->value.op.op1);
+ t = gfc_expr_check_typed (e->value.op.op1, ns, strict);
+
+ if (t == SUCCESS && e->value.op.op2)
+ t = gfc_expr_check_typed (e->value.op.op2, ns, strict);
+
+ return t;
+ }
+ }
+
+ /* Otherwise, walk the expression and do it strictly. */
+ check_typed_ns = ns;
+ error_found = gfc_traverse_expr (e, NULL, &expr_check_typed_help, 0);
+
+ return error_found ? FAILURE : SUCCESS;
+}
+
+/* Walk an expression tree and replace all symbols with a corresponding symbol
+ in the formal_ns of "sym". Needed for copying interfaces in PROCEDURE
+ statements. The boolean return value is required by gfc_traverse_expr. */
+
+static bool
+replace_symbol (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+ if ((expr->expr_type == EXPR_VARIABLE
+ || (expr->expr_type == EXPR_FUNCTION
+ && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+ && expr->symtree->n.sym->ns == sym->ts.interface->formal_ns)
+ {
+ gfc_symtree *stree;
+ gfc_namespace *ns = sym->formal_ns;
+ /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+ the symtree rather than create a new one (and probably fail later). */
+ stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+ expr->symtree->n.sym->name);
+ gcc_assert (stree);
+ stree->n.sym->attr = expr->symtree->n.sym->attr;
+ expr->symtree = stree;
+ }
+ return false;
+}
+
+void
+gfc_expr_replace_symbols (gfc_expr *expr, gfc_symbol *dest)
+{
+ gfc_traverse_expr (expr, dest, &replace_symbol, 0);
+}
+
+/* The following is analogous to 'replace_symbol', and needed for copying
+ interfaces for procedure pointer components. The argument 'sym' must formally
+ be a gfc_symbol, so that the function can be passed to gfc_traverse_expr.
+ However, it gets actually passed a gfc_component (i.e. the procedure pointer
+ component in whose formal_ns the arguments have to be). */
+
+static bool
+replace_comp (gfc_expr *expr, gfc_symbol *sym, int *i ATTRIBUTE_UNUSED)
+{
+ gfc_component *comp;
+ comp = (gfc_component *)sym;
+ if ((expr->expr_type == EXPR_VARIABLE
+ || (expr->expr_type == EXPR_FUNCTION
+ && !gfc_is_intrinsic (expr->symtree->n.sym, 0, expr->where)))
+ && expr->symtree->n.sym->ns == comp->ts.interface->formal_ns)
+ {
+ gfc_symtree *stree;
+ gfc_namespace *ns = comp->formal_ns;
+ /* Don't use gfc_get_symtree as we prefer to fail badly if we don't find
+ the symtree rather than create a new one (and probably fail later). */
+ stree = gfc_find_symtree (ns ? ns->sym_root : gfc_current_ns->sym_root,
+ expr->symtree->n.sym->name);
+ gcc_assert (stree);
+ stree->n.sym->attr = expr->symtree->n.sym->attr;
+ expr->symtree = stree;
+ }
+ return false;
+}
+
+void
+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;
+}
OSDN Git Service
