/* Routines for manipulation of expression nodes.
- Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
+ Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
+ 2009, 2010, 2011
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_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_CHARACTER:
- gfc_free (e->value.character.string);
+ free (e->value.character.string);
break;
case BT_COMPLEX:
-#ifdef HAVE_mpc
mpc_clear (e->value.complex);
-#else
- mpfr_clear (e->value.complex.r);
- mpfr_clear (e->value.complex.i);
-#endif
break;
default:
}
/* Free the representation. */
- if (e->representation.string)
- gfc_free (e->representation.string);
+ free (e->representation.string);
break;
case EXPR_ARRAY:
case EXPR_STRUCTURE:
- gfc_free_constructor (e->value.constructor);
+ gfc_constructor_free (e->value.constructor);
break;
case EXPR_SUBSTRING:
- gfc_free (e->value.character.string);
+ free (e->value.character.string);
break;
case EXPR_NULL:
break;
- default:
- gfc_internal_error ("free_expr0(): Bad expr type");
- }
+ default:
+ gfc_internal_error ("free_expr0(): Bad expr type");
+ }
+
+ /* Free a shape array. */
+ if (e->shape != NULL)
+ {
+ for (n = 0; n < e->rank; n++)
+ mpz_clear (e->shape[n]);
+
+ free (e->shape);
+ }
+
+ gfc_free_ref_list (e->ref);
+
+ memset (e, '\0', sizeof (gfc_expr));
+}
+
+
+/* Free an expression node and everything beneath it. */
+
+void
+gfc_free_expr (gfc_expr *e)
+{
+ if (e == NULL)
+ return;
+ free_expr0 (e);
+ 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);
+ 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;
- /* Free a shape array. */
- if (e->shape != NULL)
+ for (; p; p = p->next)
{
- for (n = 0; n < e->rank; n++)
- mpz_clear (e->shape[n]);
+ new_arg = gfc_get_actual_arglist ();
+ *new_arg = *p;
- gfc_free (e->shape);
- }
+ new_arg->expr = gfc_copy_expr (p->expr);
+ new_arg->next = NULL;
- gfc_free_ref_list (e->ref);
+ if (head == NULL)
+ head = new_arg;
+ else
+ tail->next = new_arg;
- memset (e, '\0', sizeof (gfc_expr));
+ tail = new_arg;
+ }
+
+ return head;
}
-/* Free an expression node and everything beneath it. */
+/* Free a list of reference structures. */
void
-gfc_free_expr (gfc_expr *e)
+gfc_free_ref_list (gfc_ref *p)
{
- if (e == NULL)
- return;
- if (e->con_by_offset)
- splay_tree_delete (e->con_by_offset);
- free_expr0 (e);
- gfc_free (e);
+ 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;
+ }
+
+ free (p);
+ }
}
{
free_expr0 (dest);
*dest = *src;
- gfc_free (src);
+ free (src);
}
case REF_ARRAY:
ar = gfc_copy_array_ref (&src->u.ar);
dest->u.ar = *ar;
- gfc_free (ar);
+ free (ar);
break;
case REF_COMPONENT:
}
-/* 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);
-#ifdef HAVE_mpc
- mpc_init2 (q->value.complex, mpfr_get_default_prec());
- mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
-#else
- 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);
-#endif
- 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;
- }
-
- 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_copy_constructor (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;
-}
-
-
/* Return the maximum kind of two expressions. In general, higher
kind numbers mean more precision for numeric types. */
}
-/* 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;
}
-static match
-check_specification_function (gfc_expr *e)
-{
- gfc_symbol *sym;
-
- if (!e->symtree)
- return MATCH_NO;
-
- sym = e->symtree->n.sym;
-
- /* F95, 7.1.6.2; F2003, 7.1.7 */
- if (sym
- && sym->attr.function
- && sym->attr.pure
- && !sym->attr.intrinsic
- && !sym->attr.recursive
- && sym->attr.proc != PROC_INTERNAL
- && sym->attr.proc != PROC_ST_FUNCTION
- && sym->attr.proc != PROC_UNKNOWN
- && sym->formal == NULL)
- return MATCH_YES;
-
- return MATCH_NO;
-}
-
/* Function to determine if an expression is constant or not. This
function expects that the expression has already been simplified. */
{
gfc_constructor *c;
gfc_actual_arglist *arg;
- int rv;
+ gfc_symbol *sym;
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:
- /* Specification functions are constant. */
- if (check_specification_function (e) == MATCH_YES)
- {
- rv = 1;
- break;
- }
+ case EXPR_PPC:
+ case EXPR_COMPCALL:
+ gcc_assert (e->symtree || e->value.function.esym
+ || e->value.function.isym);
/* 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;
}
- break;
+
+ /* Specification functions are constant. */
+ /* F95, 7.1.6.2; F2003, 7.1.7 */
+ sym = NULL;
+ if (e->symtree)
+ sym = e->symtree->n.sym;
+ if (e->value.function.esym)
+ sym = e->value.function.esym;
+
+ if (sym
+ && sym->attr.function
+ && sym->attr.pure
+ && !sym->attr.intrinsic
+ && !sym->attr.recursive
+ && sym->attr.proc != PROC_INTERNAL
+ && sym->attr.proc != PROC_ST_FUNCTION
+ && sym->attr.proc != PROC_UNKNOWN
+ && sym->formal == NULL)
+ return 1;
+
+ if (e->value.function.isym
+ && (e->value.function.isym->elemental
+ || e->value.function.isym->pure
+ || e->value.function.isym->inquiry
+ || e->value.function.isym->transformational))
+ return 1;
+
+ 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_ARRAY:
case EXPR_STRUCTURE:
- rv = 0;
- for (c = e->value.constructor; c; c = c->next)
+ c = gfc_constructor_first (e->value.constructor);
+ if ((e->expr_type == EXPR_ARRAY) && c && c->iterator)
+ return gfc_constant_ac (e);
+
+ for (; 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;
default:
gfc_internal_error ("gfc_is_constant_expr(): Unknown expression type");
+ return 0;
}
-
- return rv;
}
with gfc_simplify_expr(). */
static gfc_try
-simplify_constructor (gfc_constructor *c, int type)
+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 gfc_try
-find_array_element (gfc_constructor *cons, gfc_array_ref *ar,
+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;
gfc_try t;
mpz_mul (span, span, tmp);
}
- for (nelemen = mpz_get_ui (offset); nelemen > 0; nelemen--)
+ for (cons = gfc_constructor_first (base), nelemen = mpz_get_ui (offset);
+ cons && nelemen > 0; cons = gfc_constructor_next (cons), nelemen--)
{
- if (cons)
+ if (cons->iterator)
{
- if (cons->iterator)
- {
- cons = NULL;
- goto depart;
- }
- cons = cons->next;
+ cons = NULL;
+ goto depart;
}
}
/* 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);
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;
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))
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;
}
return FAILURE;
*newp = gfc_copy_expr (p);
- gfc_free ((*newp)->value.character.string);
+ free ((*newp)->value.character.string);
end = (int) mpz_get_ui (p->ref->u.ss.end->value.integer);
start = (int) mpz_get_ui (p->ref->u.ss.start->value.integer);
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 = gfc_copy_ref (p->ref->next);
- if (simplify_const_ref (cons->expr) == FAILURE)
+ c->expr->ref = gfc_copy_ref (p->ref->next);
+ if (simplify_const_ref (c->expr) == FAILURE)
return FAILURE;
}
- /* 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). */
- if (p->ts.type == BT_CHARACTER)
+ if (p->ts.type == BT_DERIVED
+ && p->ref->next
+ && (c = gfc_constructor_first (p->value.constructor)))
{
- int string_len;
+ /* There may have been component references. */
+ p->ts = c->expr->ts;
+ }
- gcc_assert (p->ref->next);
- gcc_assert (!p->ref->next->next);
- gcc_assert (p->ref->next->type == REF_SUBSTRING);
+ last_ref = p->ref;
+ for (; last_ref->next; last_ref = last_ref->next) {};
- if (p->value.constructor)
+ 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 = p->value.constructor->expr;
+ 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.cl)
- {
- p->ts.cl = gfc_get_charlen ();
- p->ts.cl->next = NULL;
- p->ts.cl->length = NULL;
- }
- gfc_free_expr (p->ts.cl->length);
- p->ts.cl->length = gfc_int_expr (string_len);
+ 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);
if (p->ref && p->ref->u.ss.end)
gfc_extract_int (p->ref->u.ss.end, &end);
+ if (end < 0)
+ end = 0;
+
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);
+ 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;
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);
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)
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
+ || ap->expr->symtree->n.sym->ts.deferred))
{
- gfc_error ("Assumed character length variable '%s' in constant "
- "expression at %L", e->symtree->n.sym->name, &e->where);
+ gfc_error ("Assumed or deferred character length variable '%s' "
+ " in constant expression at %L",
+ ap->expr->symtree->n.sym->name,
+ &ap->expr->where);
return MATCH_ERROR;
}
else if (not_restricted && check_init_expr (ap->expr) == FAILURE)
&& ap->expr->expr_type != EXPR_VARIABLE
&& check_restricted (ap->expr) == FAILURE)
return MATCH_ERROR;
+
+ if (not_restricted == 0
+ && ap->expr->expr_type == EXPR_VARIABLE
+ && ap->expr->symtree->n.sym->attr.dummy
+ && ap->expr->symtree->n.sym->attr.optional)
+ return MATCH_NO;
}
return MATCH_YES;
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:
if (t == FAILURE)
break;
- t = gfc_expand_constructor (e);
+ t = gfc_expand_constructor (e, true);
if (t == FAILURE)
break;
{
gfc_try t;
- gfc_init_expr = 1;
+ gfc_init_expr_flag = true;
t = gfc_resolve_expr (expr);
if (t == SUCCESS)
t = check_init_expr (expr);
- gfc_init_expr = 0;
+ gfc_init_expr_flag = false;
if (t == FAILURE)
return FAILURE;
- if (expr->expr_type == EXPR_ARRAY
- && (gfc_check_constructor_type (expr) == FAILURE
- || gfc_expand_constructor (expr) == FAILURE))
- return FAILURE;
-
- /* 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 ())
+ if (expr->expr_type == EXPR_ARRAY)
{
- gfc_error ("Initialization expression didn't reduce %C");
- return FAILURE;
+ 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. 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;
+ expression, then reducing it to a constant. */
match
gfc_match_init_expr (gfc_expr **result)
expr = NULL;
- init_flag = true;
+ gfc_init_expr_flag = true;
m = gfc_match_expr (&expr);
if (m != MATCH_YES)
{
- init_flag = false;
+ gfc_init_expr_flag = false;
return m;
}
if (t != SUCCESS)
{
gfc_free_expr (expr);
- init_flag = false;
+ gfc_init_expr_flag = false;
return MATCH_ERROR;
}
*result = expr;
- init_flag = false;
+ gfc_init_expr_flag = false;
return MATCH_YES;
}
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);
sym = lvalue->symtree->n.sym;
- /* Check INTENT(IN), unless the object itself is the component or
- sub-component of a pointer. */
+ /* See if this is the component or subcomponent of a pointer. */
has_pointer = sym->attr.pointer;
-
for (ref = lvalue->ref; ref; ref = ref->next)
if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
{
break;
}
- if (!has_pointer && sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
- sym->name, &lvalue->where);
- return FAILURE;
- }
-
/* 12.5.2.2, Note 12.26: The result variable is very similar to any other
variable local to a function subprogram. Its existence begins when
execution of the function is initiated and ends when execution of the
}
}
- 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
{
symbol_attribute attr;
gfc_ref *ref;
- int is_pure;
- int pointer, check_intent_in, proc_pointer;
+ bool is_pure, is_implicit_pure, rank_remap;
+ int proc_pointer;
if (lvalue->symtree->n.sym->ts.type == BT_UNKNOWN
&& !lvalue->symtree->n.sym->attr.proc_pointer)
return FAILURE;
}
-
- /* 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;
proc_pointer = lvalue->symtree->n.sym->attr.proc_pointer;
+ rank_remap = false;
for (ref = lvalue->ref; ref; ref = ref->next)
{
- if (pointer)
- check_intent_in = 0;
-
if (ref->type == REF_COMPONENT)
- {
- pointer = ref->u.c.component->attr.pointer;
- proc_pointer = ref->u.c.component->attr.proc_pointer;
- }
+ proc_pointer = ref->u.c.component->attr.proc_pointer;
if (ref->type == REF_ARRAY && ref->next == NULL)
{
+ int dim;
+
if (ref->u.ar.type == AR_FULL)
break;
if (gfc_notify_std (GFC_STD_F2003,"Fortran 2003: Bounds "
"specification for '%s' in pointer assignment "
- "at %L", lvalue->symtree->n.sym->name,
+ "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;
- }
- }
+ return FAILURE;
- if (check_intent_in && lvalue->symtree->n.sym->attr.intent == INTENT_IN)
- {
- gfc_error ("Cannot assign to INTENT(IN) variable '%s' at %L",
- lvalue->symtree->n.sym->name, &lvalue->where);
- return FAILURE;
- }
+ /* When bounds are given, all lbounds are necessary and either all
+ or none of the upper bounds; no strides are allowed. If the
+ upper bounds are present, we may do rank remapping. */
+ for (dim = 0; dim < ref->u.ar.dimen; ++dim)
+ {
+ if (!ref->u.ar.start[dim]
+ || ref->u.ar.dimen_type[dim] != DIMEN_RANGE)
+ {
+ gfc_error ("Lower bound has to be present at %L",
+ &lvalue->where);
+ return FAILURE;
+ }
+ if (ref->u.ar.stride[dim])
+ {
+ gfc_error ("Stride must not be present at %L",
+ &lvalue->where);
+ return FAILURE;
+ }
- if (!pointer && !proc_pointer)
- {
- gfc_error ("Pointer assignment to non-POINTER at %L", &lvalue->where);
- return FAILURE;
+ if (dim == 0)
+ rank_remap = (ref->u.ar.end[dim] != NULL);
+ else
+ {
+ if ((rank_remap && !ref->u.ar.end[dim])
+ || (!rank_remap && ref->u.ar.end[dim]))
+ {
+ gfc_error ("Either all or none of the upper bounds"
+ " must be specified at %L", &lvalue->where);
+ return FAILURE;
+ }
+ }
+ }
+ }
}
is_pure = gfc_pure (NULL);
-
- if (is_pure && gfc_impure_variable (lvalue->symtree->n.sym)
- && lvalue->symtree->n.sym->value != rvalue)
- {
- gfc_error ("Bad pointer object in PURE procedure at %L", &lvalue->where);
- return FAILURE;
- }
+ is_implicit_pure = gfc_implicit_pure (NULL);
/* If rvalue is a NULL() or NULLIFY, we're done. Otherwise the type,
kind, etc for lvalue and rvalue must match, and rvalue must be a
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->symtree->name, &rvalue->where) == FAILURE)
return FAILURE;
}
- /* TODO: Enable interface check for PPCs. */
- if (is_proc_ptr_comp (rvalue, NULL))
- return SUCCESS;
- if ((rvalue->expr_type == EXPR_VARIABLE
- && !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym, 0, 1, err,
- sizeof(err)))
- || (rvalue->expr_type == EXPR_FUNCTION
- && !gfc_compare_interfaces (lvalue->symtree->n.sym,
- rvalue->symtree->n.sym->result, 0, 1,
- err, sizeof(err))))
+
+ /* 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;
}
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);
return FAILURE;
}
- if (lvalue->rank != rvalue->rank)
+ if (lvalue->rank != rvalue->rank && !rank_remap)
{
- gfc_error ("Different ranks in pointer assignment at %L",
- &lvalue->where);
+ gfc_error ("Different ranks in pointer assignment at %L", &lvalue->where);
return FAILURE;
}
+ if (lvalue->ts.type == BT_CLASS && rvalue->ts.type == BT_DERIVED)
+ /* Make sure the vtab is present. */
+ gfc_find_derived_vtab (rvalue->ts.u.derived);
+
+ /* Check rank remapping. */
+ if (rank_remap)
+ {
+ mpz_t lsize, rsize;
+
+ /* If this can be determined, check that the target must be at least as
+ large as the pointer assigned to it is. */
+ if (gfc_array_size (lvalue, &lsize) == SUCCESS
+ && gfc_array_size (rvalue, &rsize) == SUCCESS
+ && mpz_cmp (rsize, lsize) < 0)
+ {
+ gfc_error ("Rank remapping target is smaller than size of the"
+ " pointer (%ld < %ld) at %L",
+ mpz_get_si (rsize), mpz_get_si (lsize),
+ &lvalue->where);
+ return FAILURE;
+ }
+
+ /* The target must be either rank one or it must be simply contiguous
+ and F2008 must be allowed. */
+ if (rvalue->rank != 1)
+ {
+ if (!gfc_is_simply_contiguous (rvalue, true))
+ {
+ gfc_error ("Rank remapping target must be rank 1 or"
+ " simply contiguous at %L", &rvalue->where);
+ return FAILURE;
+ }
+ if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Rank remapping"
+ " target is not rank 1 at %L", &rvalue->where)
+ == FAILURE)
+ return FAILURE;
+ }
+ }
+
/* Now punt if we are dealing with a NULLIFY(X) or X = NULL(X). */
if (rvalue->expr_type == EXPR_NULL)
return SUCCESS;
lvalue->symtree->n.sym->attr.subref_array_pointer = 1;
attr = gfc_expr_attr (rvalue);
+
+ if (rvalue->expr_type == EXPR_FUNCTION && !attr.pointer)
+ {
+ gfc_error ("Target expression in pointer assignment "
+ "at %L must deliver a pointer result",
+ &rvalue->where);
+ return FAILURE;
+ }
+
if (!attr.target && !attr.pointer)
{
gfc_error ("Pointer assignment target is neither TARGET "
"procedure at %L", &rvalue->where);
}
+ if (is_implicit_pure && gfc_impure_variable (rvalue->symtree->n.sym))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+
if (gfc_has_vector_index (rvalue))
{
gfc_error ("Pointer assignment with vector subscript "
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;
}
lvalue.ts = sym->ts;
if (sym->as)
lvalue.rank = sym->as->rank;
- lvalue.symtree = (gfc_symtree *) gfc_getmem (sizeof (gfc_symtree));
+ lvalue.symtree = XCNEW (gfc_symtree);
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 && 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);
- gfc_free (lvalue.symtree);
+ free (lvalue.symtree);
+
+ if (r == FAILURE)
+ return r;
+
+ if (sym->attr.pointer && rvalue->expr_type != EXPR_NULL)
+ {
+ /* F08:C461. Additional checks for pointer initialization. */
+ symbol_attribute attr;
+ attr = gfc_expr_attr (rvalue);
+ if (attr.allocatable)
+ {
+ gfc_error ("Pointer initialization target at %C "
+ "must not be ALLOCATABLE ");
+ return FAILURE;
+ }
+ if (!attr.target || attr.pointer)
+ {
+ gfc_error ("Pointer initialization target at %C "
+ "must have the TARGET attribute");
+ return FAILURE;
+ }
+ if (!attr.save)
+ {
+ gfc_error ("Pointer initialization target at %C "
+ "must have the SAVE attribute");
+ return FAILURE;
+ }
+ }
+
+ if (sym->attr.proc_pointer && rvalue->expr_type != EXPR_NULL)
+ {
+ /* F08:C1220. Additional checks for procedure pointer initialization. */
+ symbol_attribute attr = gfc_expr_attr (rvalue);
+ if (attr.proc_pointer)
+ {
+ gfc_error ("Procedure pointer initialization target at %L "
+ "may not be a procedure pointer", &rvalue->where);
+ return FAILURE;
+ }
+ }
- return r;
+ return SUCCESS;
}
+/* 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->attr.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
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (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->attr.allocatable)
+ if (comp->attr.allocatable
+ || (comp->ts.type == BT_CLASS && CLASS_DATA (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;
}
e->ref->u.ar.type = AR_FULL;
}
- return e;
+ return e;
+}
+
+
+gfc_expr *
+gfc_lval_expr_from_sym (gfc_symbol *sym)
+{
+ gfc_expr *lval;
+ lval = gfc_get_expr ();
+ lval->expr_type = EXPR_VARIABLE;
+ lval->where = sym->declared_at;
+ lval->ts = sym->ts;
+ lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
+
+ /* It will always be a full array. */
+ lval->rank = sym->as ? sym->as->rank : 0;
+ if (lval->rank)
+ {
+ lval->ref = gfc_get_ref ();
+ lval->ref->type = REF_ARRAY;
+ lval->ref->u.ar.type = AR_FULL;
+ lval->ref->u.ar.dimen = lval->rank;
+ lval->ref->u.ar.where = sym->declared_at;
+ lval->ref->u.ar.as = sym->as;
+ }
+
+ return lval;
+}
+
+
+/* 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;
}
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))
provided). */
bool
-is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
+gfc_is_proc_ptr_comp (gfc_expr *expr, gfc_component **comp)
{
gfc_ref *ref;
bool ppc = false;
{
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_ref_this_image (gfc_ref *ref)
+{
+ int n;
+
+ gcc_assert (ref->type == REF_ARRAY && ref->u.ar.codimen > 0);
+
+ for (n = ref->u.ar.dimen; n < ref->u.ar.dimen + ref->u.ar.codimen; n++)
+ if (ref->u.ar.dimen_type[n] != DIMEN_THIS_IMAGE)
+ return false;
+
+ return true;
+}
+
+
+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 !gfc_ref_this_image (ref);
+
+ return false;
+}
+
+
+/* Coarrays are variables with a corank but not being coindexed. However, also
+ the following is a coarray: A subobject of a coarray is a coarray if it does
+ not have any cosubscripts, vector subscripts, allocatable component
+ selection, or pointer component selection. (F2008, 2.4.7) */
+
+bool
+gfc_is_coarray (gfc_expr *e)
+{
+ gfc_ref *ref;
+ gfc_symbol *sym;
+ gfc_component *comp;
+ bool coindexed;
+ bool coarray;
+ int i;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ coindexed = false;
+ sym = e->symtree->n.sym;
+
+ if (sym->ts.type == BT_CLASS && sym->attr.class_ok)
+ coarray = CLASS_DATA (sym)->attr.codimension;
+ else
+ coarray = sym->attr.codimension;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ switch (ref->type)
+ {
+ case REF_COMPONENT:
+ comp = ref->u.c.component;
+ if (comp->attr.pointer || comp->attr.allocatable)
+ {
+ coindexed = false;
+ if (comp->ts.type == BT_CLASS && comp->attr.class_ok)
+ coarray = CLASS_DATA (comp)->attr.codimension;
+ else
+ coarray = comp->attr.codimension;
+ }
+ break;
+
+ case REF_ARRAY:
+ if (!coarray)
+ break;
+
+ if (ref->u.ar.codimen > 0 && !gfc_ref_this_image (ref))
+ {
+ coindexed = true;
+ break;
+ }
+
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ if (ref->u.ar.dimen_type[i] == DIMEN_VECTOR)
+ {
+ coarray = false;
+ break;
+ }
+ break;
+
+ case REF_SUBSTRING:
+ break;
+ }
+
+ return coarray && !coindexed;
+}
+
+
+int
+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;
+}
+
+
+/* Build call to an intrinsic procedure. The number of arguments has to be
+ passed (rather than ending the list with a NULL value) because we may
+ want to add arguments but with a NULL-expression. */
+
+gfc_expr*
+gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
+{
+ gfc_expr* result;
+ gfc_actual_arglist* atail;
+ gfc_intrinsic_sym* isym;
+ va_list ap;
+ unsigned i;
+
+ isym = gfc_find_function (name);
+ gcc_assert (isym);
+
+ result = gfc_get_expr ();
+ result->expr_type = EXPR_FUNCTION;
+ result->ts = isym->ts;
+ result->where = where;
+ result->value.function.name = name;
+ result->value.function.isym = isym;
+
+ va_start (ap, numarg);
+ atail = NULL;
+ for (i = 0; i < numarg; ++i)
+ {
+ if (atail)
+ {
+ atail->next = gfc_get_actual_arglist ();
+ atail = atail->next;
+ }
+ else
+ atail = result->value.function.actual = gfc_get_actual_arglist ();
+
+ atail->expr = va_arg (ap, gfc_expr*);
+ }
+ va_end (ap);
+
+ return result;
+}
+
+
+/* Check if an expression may appear in a variable definition context
+ (F2008, 16.6.7) or pointer association context (F2008, 16.6.8).
+ This is called from the various places when resolving
+ the pieces that make up such a context.
+
+ Optionally, a possible error message can be suppressed if context is NULL
+ and just the return status (SUCCESS / FAILURE) be requested. */
+
+gfc_try
+gfc_check_vardef_context (gfc_expr* e, bool pointer, bool alloc_obj,
+ const char* context)
+{
+ gfc_symbol* sym = NULL;
+ bool is_pointer;
+ bool check_intentin;
+ bool ptr_component;
+ symbol_attribute attr;
+ gfc_ref* ref;
+
+ if (e->expr_type == EXPR_VARIABLE)
+ {
+ gcc_assert (e->symtree);
+ sym = e->symtree->n.sym;
+ }
+ else if (e->expr_type == EXPR_FUNCTION)
+ {
+ gcc_assert (e->symtree);
+ sym = e->value.function.esym ? e->value.function.esym : e->symtree->n.sym;
+ }
+
+ attr = gfc_expr_attr (e);
+ if (!pointer && e->expr_type == EXPR_FUNCTION && attr.pointer)
+ {
+ if (!(gfc_option.allow_std & GFC_STD_F2008))
+ {
+ if (context)
+ gfc_error ("Fortran 2008: Pointer functions in variable definition"
+ " context (%s) at %L", context, &e->where);
+ return FAILURE;
+ }
+ }
+ else if (e->expr_type != EXPR_VARIABLE)
+ {
+ if (context)
+ gfc_error ("Non-variable expression in variable definition context (%s)"
+ " at %L", context, &e->where);
+ return FAILURE;
+ }
+
+ if (!pointer && sym->attr.flavor == FL_PARAMETER)
+ {
+ if (context)
+ gfc_error ("Named constant '%s' in variable definition context (%s)"
+ " at %L", sym->name, context, &e->where);
+ return FAILURE;
+ }
+ if (!pointer && sym->attr.flavor != FL_VARIABLE
+ && !(sym->attr.flavor == FL_PROCEDURE && sym == sym->result)
+ && !(sym->attr.flavor == FL_PROCEDURE && sym->attr.proc_pointer))
+ {
+ if (context)
+ gfc_error ("'%s' in variable definition context (%s) at %L is not"
+ " a variable", sym->name, context, &e->where);
+ return FAILURE;
+ }
+
+ /* Find out whether the expr is a pointer; this also means following
+ component references to the last one. */
+ is_pointer = (attr.pointer || attr.proc_pointer);
+ if (pointer && !is_pointer)
+ {
+ if (context)
+ gfc_error ("Non-POINTER in pointer association context (%s)"
+ " at %L", context, &e->where);
+ return FAILURE;
+ }
+
+ /* F2008, C1303. */
+ if (!alloc_obj
+ && (attr.lock_comp
+ || (e->ts.type == BT_DERIVED
+ && e->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
+ && e->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)))
+ {
+ if (context)
+ gfc_error ("LOCK_TYPE in variable definition context (%s) at %L",
+ context, &e->where);
+ return FAILURE;
+ }
+
+ /* INTENT(IN) dummy argument. Check this, unless the object itself is
+ the component of sub-component of a pointer. Obviously,
+ procedure pointers are of no interest here. */
+ check_intentin = true;
+ ptr_component = sym->attr.pointer;
+ for (ref = e->ref; ref && check_intentin; ref = ref->next)
+ {
+ if (ptr_component && ref->type == REF_COMPONENT)
+ check_intentin = false;
+ if (ref->type == REF_COMPONENT && ref->u.c.component->attr.pointer)
+ ptr_component = true;
+ }
+ if (check_intentin && sym->attr.intent == INTENT_IN)
+ {
+ if (pointer && is_pointer)
+ {
+ if (context)
+ gfc_error ("Dummy argument '%s' with INTENT(IN) in pointer"
+ " association context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ if (!pointer && !is_pointer)
+ {
+ if (context)
+ gfc_error ("Dummy argument '%s' with INTENT(IN) in variable"
+ " definition context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ }
+
+ /* PROTECTED and use-associated. */
+ if (sym->attr.is_protected && sym->attr.use_assoc && check_intentin)
+ {
+ if (pointer && is_pointer)
+ {
+ if (context)
+ gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+ " pointer association context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ if (!pointer && !is_pointer)
+ {
+ if (context)
+ gfc_error ("Variable '%s' is PROTECTED and can not appear in a"
+ " variable definition context (%s) at %L",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+ }
+
+ /* Variable not assignable from a PURE procedure but appears in
+ variable definition context. */
+ if (!pointer && gfc_pure (NULL) && gfc_impure_variable (sym))
+ {
+ if (context)
+ gfc_error ("Variable '%s' can not appear in a variable definition"
+ " context (%s) at %L in PURE procedure",
+ sym->name, context, &e->where);
+ return FAILURE;
+ }
+
+ if (!pointer && gfc_implicit_pure (NULL) && gfc_impure_variable (sym))
+ gfc_current_ns->proc_name->attr.implicit_pure = 0;
+
+ /* Check variable definition context for associate-names. */
+ if (!pointer && sym->assoc)
+ {
+ const char* name;
+ gfc_association_list* assoc;
+
+ gcc_assert (sym->assoc->target);
+
+ /* If this is a SELECT TYPE temporary (the association is used internally
+ for SELECT TYPE), silently go over to the target. */
+ if (sym->attr.select_type_temporary)
+ {
+ gfc_expr* t = sym->assoc->target;
+
+ gcc_assert (t->expr_type == EXPR_VARIABLE);
+ name = t->symtree->name;
+
+ if (t->symtree->n.sym->assoc)
+ assoc = t->symtree->n.sym->assoc;
+ else
+ assoc = sym->assoc;
+ }
+ else
+ {
+ name = sym->name;
+ assoc = sym->assoc;
+ }
+ gcc_assert (name && assoc);
+
+ /* Is association to a valid variable? */
+ if (!assoc->variable)
+ {
+ if (context)
+ {
+ if (assoc->target->expr_type == EXPR_VARIABLE)
+ gfc_error ("'%s' at %L associated to vector-indexed target can"
+ " not be used in a variable definition context (%s)",
+ name, &e->where, context);
+ else
+ gfc_error ("'%s' at %L associated to expression can"
+ " not be used in a variable definition context (%s)",
+ name, &e->where, context);
+ }
+ return FAILURE;
+ }
+
+ /* Target must be allowed to appear in a variable definition context. */
+ if (gfc_check_vardef_context (assoc->target, pointer, false, NULL)
+ == FAILURE)
+ {
+ if (context)
+ gfc_error ("Associate-name '%s' can not appear in a variable"
+ " definition context (%s) at %L because its target"
+ " at %L can not, either",
+ name, context, &e->where,
+ &assoc->target->where);
+ return FAILURE;
+ }
+ }
+
+ return SUCCESS;
+}
OSDN Git Service
