/* 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)
{
gfc_expr *e;
- e = gfc_getmem (sizeof (gfc_expr));
+ e = XCNEW (gfc_expr);
gfc_clear_ts (&e->ts);
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;
+ 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 = gfc_get_actual_arglist ();
- *new = *p;
+ case BT_INTEGER:
+ mpz_init (e->value.integer);
+ break;
- new->expr = gfc_copy_expr (p->expr);
- new->next = NULL;
+ case BT_REAL:
+ gfc_set_model_kind (kind);
+ mpfr_init (e->value.real);
+ break;
- if (head == NULL)
- head = new;
- else
- tail->next = new;
+ case BT_COMPLEX:
+ gfc_set_model_kind (kind);
+ mpc_init2 (e->value.complex, mpfr_get_default_prec());
+ break;
- tail = new;
+ 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_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:
break;
}
- /* Free the representation, except in character constants where it
- is the same as value.character.string and thus already freed. */
- if (e->representation.string && e->ts.type != BT_CHARACTER)
+ /* Free the representation. */
+ if (e->representation.string)
gfc_free (e->representation.string);
break;
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;
}
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;
- char *s;
-
- if (p == NULL)
- return NULL;
-
- q = gfc_get_expr ();
- *q = *p;
-
- switch (q->expr_type)
- {
- case EXPR_SUBSTRING:
- s = gfc_getmem (p->value.character.length + 1);
- q->value.character.string = s;
-
- memcpy (s, p->value.character.string, p->value.character.length + 1);
- break;
-
- case EXPR_CONSTANT:
- /* Copy target representation, if it exists. */
- if (p->representation.string)
- {
- s = gfc_getmem (p->representation.length + 1);
- q->representation.string = s;
-
- memcpy (s, 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 = q->representation.string;
- else
- {
- s = gfc_getmem (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);
- }
- 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.operator)
- {
- 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;
- }
-
- break;
-
- case EXPR_FUNCTION:
- q->value.function.actual =
- gfc_copy_actual_arglist (p->value.function.actual);
- break;
-
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- q->value.constructor = gfc_copy_constructor (p->value.constructor);
- break;
-
- case EXPR_VARIABLE:
- case EXPR_NULL:
- break;
- }
-
- q->shape = gfc_copy_shape (p->shape, p->rank);
-
- q->ref = copy_ref (p->ref);
-
- return q;
-}
-
-
-/* Return the maximum kind of two expressions. In general, higher
- kind numbers mean more precision for numeric types. */
-
-int
-gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
-{
- return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
-}
-
-
-/* Returns nonzero if the type is numeric, zero otherwise. */
-
-static int
-numeric_type (bt type)
-{
- return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
-}
-
-
-/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
-
-int
-gfc_numeric_ts (gfc_typespec *ts)
-{
- return numeric_type (ts->type);
-}
-
-
-/* Returns an expression node that is an integer constant. */
-
-gfc_expr *
-gfc_int_expr (int i)
-{
- gfc_expr *p;
-
- p = gfc_get_expr ();
+ return new_shape;
+}
- 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 the maximum kind of two expressions. In general, higher
+ kind numbers mean more precision for numeric types. */
- return p;
+int
+gfc_kind_max (gfc_expr *e1, gfc_expr *e2)
+{
+ return (e1->ts.kind > e2->ts.kind) ? e1->ts.kind : e2->ts.kind;
}
-/* Returns an expression node that is a logical constant. */
+/* Returns nonzero if the type is numeric, zero otherwise. */
-gfc_expr *
-gfc_logical_expr (int i, locus *where)
+static int
+numeric_type (bt type)
{
- gfc_expr *p;
-
- p = gfc_get_expr ();
+ return type == BT_COMPLEX || type == BT_REAL || type == BT_INTEGER;
+}
- 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;
+/* Returns nonzero if the typespec is a numeric type, zero otherwise. */
- return p;
+int
+gfc_numeric_ts (gfc_typespec *ts)
+{
+ return numeric_type (ts->type);
}
/* 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;
e->ts = op1->ts;
/* Special case for ** operator. */
- if (e->value.op.operator == INTRINSIC_POWER)
+ 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;
gfc_expr *op1, *op2, *result;
- if (p->value.op.operator == INTRINSIC_USER)
+ if (p->value.op.op == INTRINSIC_USER)
return SUCCESS;
op1 = p->value.op.op1;
op2 = p->value.op.op2;
- op = p->value.op.operator;
+ op = p->value.op.op;
if (gfc_simplify_expr (op1, type) == FAILURE)
return FAILURE;
/* 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;
int rank;
int d;
int shape_i;
+ int limit;
long unsigned one = 1;
bool incr_ctr;
mpz_t start[GFC_MAX_DIMENSIONS];
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;
+ limit = mpz_get_ui (ptr);
+ if (limit >= gfc_option.flag_max_array_constructor)
+ {
+ gfc_error ("The number of elements in the array constructor "
+ "at %L requires an increase of the allowed %d "
+ "upper limit. See -fmax-array-constructor "
+ "option", &expr->where,
+ gfc_option.flag_max_array_constructor);
+ return FAILURE;
}
- gfc_append_constructor (expr, gfc_copy_expr (cons->expr));
+ cons = gfc_constructor_lookup (base, limit);
+ 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;
int start;
int length;
- char *chr;
+ gfc_char_t *chr;
if (p->ref->u.ss.start->expr_type != EXPR_CONSTANT
|| p->ref->u.ss.end->expr_type != EXPR_CONSTANT)
start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
length = end - start + 1;
- chr = (*newp)->value.character.string = gfc_getmem (length + 1);
+ chr = (*newp)->value.character.string = gfc_get_wide_string (length + 1);
(*newp)->value.character.length = length;
- memcpy (chr, &p->value.character.string[start - 1], length);
+ memcpy (chr, &p->value.character.string[start - 1],
+ length * sizeof (gfc_char_t));
chr[length] = '\0';
return SUCCESS;
}
/* 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))
{
- cons->expr->ref = copy_ref (p->ref->next);
- simplify_const_ref (cons->expr);
+ 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)
+ {
+ /* 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;
if (gfc_is_constant_expr (p))
{
- char *s;
+ 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_getmem (end - start + 2);
- memcpy (s, p->value.character.string + start, end - start);
+ s = gfc_get_wide_string (end - start + 2);
+ memcpy (s, p->value.character.string + start,
+ (end - start) * sizeof (gfc_char_t));
s[end - start + 1] = '\0'; /* TODO: C-style string. */
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;
/* Only substitute array parameter variables if we are in an
initialization expression, or we want a subsection. */
if (p->symtree->n.sym->attr.flavor == FL_PARAMETER
- && (gfc_init_expr || p->ref
+ && (gfc_init_expr_flag || p->ref
|| p->symtree->n.sym->value->expr_type != EXPR_ARRAY))
{
if (simplify_parameter_variable (p, type) == FAILURE)
if (p->expr_type == EXPR_ARRAY && p->ref && p->ref->type == REF_ARRAY
&& p->ref->u.ar.type == AR_FULL)
- gfc_expand_constructor (p);
+ gfc_expand_constructor (p, false);
if (simplify_const_ref (p) == FAILURE)
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];
+ 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.*/
+ n = array_arg = 0;
+ a = e->value.function.actual;
+ for (; a; a = a->next)
+ {
+ n++;
+ if (a->expr->expr_type != EXPR_ARRAY)
+ continue;
+ array_arg = n;
+ expr = gfc_copy_expr (a->expr);
+ break;
+ }
+
+ if (!array_arg)
+ return FAILURE;
old = gfc_copy_expr (e);
-/* Assume that the old expression carries the type information and
- that the first arg carries all the shape information. */
- expr = gfc_copy_expr (old->value.function.actual->expr);
- 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;
/* Copy the array argument constructors into an array, with nulls
{
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++;
}
- for (i = 1; i < n; i++)
- if (rank[i] && rank[i] != rank[0])
- goto compliance;
- /* Using the first argument as the master, step through the array
+ /* 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[0];
- 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 (gfc_simplify_expr (new_ctor->expr, 0) == FAILURE)
- goto cleanup;
+ /* 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[0] == NULL)
- || (args[i] == NULL && args[0] != 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 ((*check_function) (op1) == FAILURE)
return FAILURE;
- switch (e->value.op.operator)
+ switch (e->value.op.op)
{
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
if (!numeric_type (et0 (op1)) || !numeric_type (et0 (op2)))
goto not_numeric;
- if (e->value.op.operator == 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_intrinsic_sym *isym;
+ gfc_try t;
if (e == NULL)
return SUCCESS;
case EXPR_FUNCTION:
t = FAILURE;
- if ((m = check_specification_function (e)) != MATCH_YES)
- {
- if ((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;
- }
+ {
+ gfc_intrinsic_sym* isym;
+ gfc_symbol* sym;
- 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;
- }
+ 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;
+ }
- /* 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
- && e->value.function.actual->expr->expr_type == EXPR_ARRAY)
- {
- if ((t = scalarize_intrinsic_call (e)) == SUCCESS)
- 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;
+ }
+
+ /* 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:
if (t == FAILURE)
break;
- t = gfc_expand_constructor (e);
+ t = gfc_expand_constructor (e, true);
if (t == FAILURE)
break;
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. */
+
+gfc_try
+gfc_reduce_init_expr (gfc_expr *expr)
+{
+ gfc_try t;
+
+ gfc_init_expr_flag = true;
+ t = gfc_resolve_expr (expr);
+ if (t == SUCCESS)
+ t = check_init_expr (expr);
+ gfc_init_expr_flag = false;
+
+ if (t == FAILURE)
+ return FAILURE;
+
+ if (expr->expr_type == EXPR_ARRAY)
+ {
+ if (gfc_check_constructor_type (expr) == FAILURE)
+ return FAILURE;
+ if (gfc_expand_constructor (expr, true) == FAILURE)
+ return FAILURE;
+ }
+
+ return SUCCESS;
+}
+
/* Match an initialization expression. We work by first matching an
expression, then reducing it to a constant. */
{
gfc_expr *expr;
match m;
- try t;
+ gfc_try t;
- m = gfc_match_expr (&expr);
- if (m != MATCH_YES)
- return m;
+ expr = NULL;
- gfc_init_expr = 1;
- t = gfc_resolve_expr (expr);
- if (t == SUCCESS)
- t = check_init_expr (expr);
- gfc_init_expr = 0;
+ gfc_init_expr_flag = true;
- if (t == FAILURE)
+ m = gfc_match_expr (&expr);
+ if (m != MATCH_YES)
{
- gfc_free_expr (expr);
- return MATCH_ERROR;
+ gfc_init_expr_flag = false;
+ return m;
}
- if (expr->expr_type == EXPR_ARRAY
- && (gfc_check_constructor_type (expr) == FAILURE
- || gfc_expand_constructor (expr) == FAILURE))
+ t = gfc_reduce_init_expr (expr);
+ if (t != SUCCESS)
{
gfc_free_expr (expr);
- return MATCH_ERROR;
- }
-
- /* 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 ())
- {
- gfc_error ("Initialization expression didn't reduce %C");
+ gfc_init_expr_flag = false;
return MATCH_ERROR;
}
*result = expr;
+ gfc_init_expr_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->ts.type != BT_INTEGER)
{
- gfc_error ("Expression at %L must be of INTEGER type", &e->where);
+ gfc_error ("Expression at %L must be of INTEGER type, found %s",
+ &e->where, gfc_basic_typename (e->ts.type));
return FAILURE;
}
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
if (gfc_compare_types (&lvalue->ts, &rvalue->ts))
return SUCCESS;
+ /* Only DATA Statements come here. */
if (!conform)
{
/* Numeric can be converted to any other numeric. And Hollerith can be
if (lvalue->ts.type == BT_LOGICAL && rvalue->ts.type == BT_LOGICAL)
return SUCCESS;
- gfc_error ("Incompatible types in assignment at %L; attempted assignment "
- "of %s to %s", &rvalue->where, gfc_typename (&rvalue->ts),
- gfc_typename (&lvalue->ts));
+ gfc_error ("Incompatible types in DATA statement at %L; attempted "
+ "conversion of %s to %s", &lvalue->where,
+ gfc_typename (&rvalue->ts), gfc_typename (&lvalue->ts));
return FAILURE;
}
+ /* Assignment is the only case where character variables of different
+ kind values can be converted into one another. */
+ if (lvalue->ts.type == BT_CHARACTER && rvalue->ts.type == BT_CHARACTER)
+ {
+ if (lvalue->ts.kind != rvalue->ts.kind)
+ gfc_convert_chartype (rvalue, &lvalue->ts);
+
+ return SUCCESS;
+ }
+
return gfc_convert_type (rvalue, &lvalue->ts, 1);
}
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)
+ if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
+ && !lvalue->symtree->n.sym->attr.proc_pointer)
{
gfc_error ("Pointer assignment target is not a POINTER at %L",
&lvalue->where);
}
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",
sub-component of a pointer. */
check_intent_in = 1;
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
+ && CLASS_DATA (lvalue)->attr.class_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;
+ /* 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))
{
gfc_error ("Different types in pointer assignment at %L; attempted "
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.protected && attr.use_assoc)
+ if (attr.is_protected && attr.use_assoc
+ && !(attr.pointer || attr.proc_pointer))
{
- gfc_error ("Pointer assigment target has PROTECTED "
+ 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)
+ if (sym->attr.pointer || sym->attr.proc_pointer
+ || (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.class_pointer
+ && rvalue->expr_type == EXPR_NULL))
r = gfc_check_pointer_assign (&lvalue, rvalue);
else
r = gfc_check_assign (&lvalue, rvalue, 1);
}
+/* Check for default initializer; sym->value is not enough
+ as it is also set for EXPR_NULL of allocatables. */
+
+bool
+gfc_has_default_initializer (gfc_symbol *der)
+{
+ gfc_component *c;
+
+ gcc_assert (der->attr.flavor == FL_DERIVED);
+ for (c = der->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED)
+ {
+ if (!c->attr.pointer
+ && gfc_has_default_initializer (c->ts.u.derived))
+ return true;
+ }
+ else
+ {
+ if (c->initializer)
+ return true;
+ }
+
+ return false;
+}
+
/* Get an expression for a default initializer. */
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)
+ /* See if we have a default initializer in this, but not in nested
+ types (otherwise we could use gfc_has_default_initializer()). */
+ 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;
+}
+
+
+bool
+gfc_get_corank (gfc_expr *e)
+{
+ int corank;
+ gfc_ref *ref;
+ corank = e->symtree->n.sym->as ? e->symtree->n.sym->as->corank : 0;
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ if (ref->type == REF_ARRAY)
+ corank = ref->u.ar.as->corank;
+ gcc_assert (ref->type != REF_SUBSTRING);
+ }
+ return corank;
+}
+
+
+/* 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 CLASS_DATA (last->u.c.component)->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 CLASS_DATA (e)->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 CLASS_DATA (last->u.c.component)->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 CLASS_DATA (e)->attr.pointer_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.pointer_comp;
+ else
+ return false;
+}
+
+
+/* Check whether an expression is "simply contiguous", cf. F2008, 6.5.4.
+ Note: A scalar is not regarded as "simply contiguous" by the standard.
+ if bool is not strict, some futher checks are done - for instance,
+ a "(::1)" is accepted. */
+
+bool
+gfc_is_simply_contiguous (gfc_expr *expr, bool strict)
+{
+ bool colon;
+ int i;
+ gfc_array_ref *ar = NULL;
+ gfc_ref *ref, *part_ref = NULL;
+
+ if (expr->expr_type == EXPR_FUNCTION)
+ return expr->value.function.esym
+ ? expr->value.function.esym->result->attr.contiguous : false;
+ else if (expr->expr_type != EXPR_VARIABLE)
+ return false;
+
+ if (expr->rank == 0)
+ return false;
+
+ for (ref = expr->ref; ref; ref = ref->next)
+ {
+ if (ar)
+ return false; /* Array shall be last part-ref. */
+
+ if (ref->type == REF_COMPONENT)
+ part_ref = ref;
+ else if (ref->type == REF_SUBSTRING)
+ return false;
+ else if (ref->u.ar.type != AR_ELEMENT)
+ ar = &ref->u.ar;
+ }
+
+ if ((part_ref && !part_ref->u.c.component->attr.contiguous
+ && part_ref->u.c.component->attr.pointer)
+ || (!part_ref && !expr->symtree->n.sym->attr.contiguous
+ && (expr->symtree->n.sym->attr.pointer
+ || expr->symtree->n.sym->as->type == AS_ASSUMED_SHAPE)))
+ return false;
+
+ if (!ar || ar->type == AR_FULL)
+ return true;
+
+ gcc_assert (ar->type == AR_SECTION);
+
+ /* Check for simply contiguous array */
+ colon = true;
+ for (i = 0; i < ar->dimen; i++)
+ {
+ if (ar->dimen_type[i] == DIMEN_VECTOR)
+ return false;
+
+ if (ar->dimen_type[i] == DIMEN_ELEMENT)
+ {
+ colon = false;
+ continue;
+ }
+
+ gcc_assert (ar->dimen_type[i] == DIMEN_RANGE);
+
+
+ /* If the previous section was not contiguous, that's an error,
+ unless we have effective only one element and checking is not
+ strict. */
+ if (!colon && (strict || !ar->start[i] || !ar->end[i]
+ || ar->start[i]->expr_type != EXPR_CONSTANT
+ || ar->end[i]->expr_type != EXPR_CONSTANT
+ || mpz_cmp (ar->start[i]->value.integer,
+ ar->end[i]->value.integer) != 0))
+ return false;
+
+ /* Following the standard, "(::1)" or - if known at compile time -
+ "(lbound:ubound)" are not simply contigous; if strict
+ is false, they are regarded as simply contiguous. */
+ if (ar->stride[i] && (strict || ar->stride[i]->expr_type != EXPR_CONSTANT
+ || ar->stride[i]->ts.type != BT_INTEGER
+ || mpz_cmp_si (ar->stride[i]->value.integer, 1) != 0))
+ return false;
+
+ if (ar->start[i]
+ && (strict || ar->start[i]->expr_type != EXPR_CONSTANT
+ || !ar->as->lower[i]
+ || ar->as->lower[i]->expr_type != EXPR_CONSTANT
+ || mpz_cmp (ar->start[i]->value.integer,
+ ar->as->lower[i]->value.integer) != 0))
+ colon = false;
+
+ if (ar->end[i]
+ && (strict || ar->end[i]->expr_type != EXPR_CONSTANT
+ || !ar->as->upper[i]
+ || ar->as->upper[i]->expr_type != EXPR_CONSTANT
+ || mpz_cmp (ar->end[i]->value.integer,
+ ar->as->upper[i]->value.integer) != 0))
+ colon = false;
+ }
+
+ return true;
+}
OSDN Git Service
