/* 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
Free Software Foundation, Inc.
Contributed by Andy Vaught
#include "arith.h"
#include "match.h"
#include "target-memory.h" /* for gfc_convert_boz */
+#include "constructor.h"
-/* Get a new expr node. */
+
+/* The following set of functions provide access to gfc_expr* of
+ various types - actual all but EXPR_FUNCTION and EXPR_VARIABLE.
+
+ There are two functions available elsewhere that provide
+ slightly different flavours of variables. Namely:
+ expr.c (gfc_get_variable_expr)
+ symbol.c (gfc_lval_expr_from_sym)
+ TODO: Merge these functions, if possible. */
+
+/* Get a new expression node. */
gfc_expr *
gfc_get_expr (void)
e->shape = NULL;
e->ref = NULL;
e->symtree = NULL;
- e->con_by_offset = NULL;
return e;
}
-/* Free an argument list and everything below it. */
+/* Get a new expression node that is an array constructor
+ of given type and kind. */
-void
-gfc_free_actual_arglist (gfc_actual_arglist *a1)
+gfc_expr *
+gfc_get_array_expr (bt type, int kind, locus *where)
{
- gfc_actual_arglist *a2;
+ gfc_expr *e;
- while (a1)
- {
- a2 = a1->next;
- gfc_free_expr (a1->expr);
- gfc_free (a1);
- a1 = a2;
- }
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_ARRAY;
+ e->value.constructor = NULL;
+ e->rank = 1;
+ e->shape = NULL;
+
+ e->ts.type = type;
+ e->ts.kind = kind;
+ if (where)
+ e->where = *where;
+
+ return e;
}
-/* Copy an arglist structure and all of the arguments. */
+/* Get a new expression node that is the NULL expression. */
-gfc_actual_arglist *
-gfc_copy_actual_arglist (gfc_actual_arglist *p)
+gfc_expr *
+gfc_get_null_expr (locus *where)
{
- gfc_actual_arglist *head, *tail, *new_arg;
+ gfc_expr *e;
- head = tail = NULL;
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_NULL;
+ e->ts.type = BT_UNKNOWN;
- for (; p; p = p->next)
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an operator expression node. */
+
+gfc_expr *
+gfc_get_operator_expr (locus *where, gfc_intrinsic_op op,
+ gfc_expr *op1, gfc_expr *op2)
+{
+ gfc_expr *e;
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_OP;
+ e->value.op.op = op;
+ e->value.op.op1 = op1;
+ e->value.op.op2 = op2;
+
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an structure constructor
+ of given type and kind. */
+
+gfc_expr *
+gfc_get_structure_constructor_expr (bt type, int kind, locus *where)
+{
+ gfc_expr *e;
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_STRUCTURE;
+ e->value.constructor = NULL;
+
+ e->ts.type = type;
+ e->ts.kind = kind;
+ if (where)
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an constant of given type and kind. */
+
+gfc_expr *
+gfc_get_constant_expr (bt type, int kind, locus *where)
+{
+ gfc_expr *e;
+
+ if (!where)
+ gfc_internal_error ("gfc_get_constant_expr(): locus 'where' cannot be NULL");
+
+ e = gfc_get_expr ();
+
+ e->expr_type = EXPR_CONSTANT;
+ e->ts.type = type;
+ e->ts.kind = kind;
+ e->where = *where;
+
+ switch (type)
{
- new_arg = gfc_get_actual_arglist ();
- *new_arg = *p;
+ case BT_INTEGER:
+ mpz_init (e->value.integer);
+ break;
- new_arg->expr = gfc_copy_expr (p->expr);
- new_arg->next = NULL;
+ case BT_REAL:
+ gfc_set_model_kind (kind);
+ mpfr_init (e->value.real);
+ break;
- if (head == NULL)
- head = new_arg;
- else
- tail->next = new_arg;
+ case BT_COMPLEX:
+ gfc_set_model_kind (kind);
+ mpc_init2 (e->value.complex, mpfr_get_default_prec());
+ break;
- tail = new_arg;
+ default:
+ break;
}
- return head;
+ return e;
}
-/* Free a list of reference structures. */
+/* Get a new expression node that is an string constant.
+ If no string is passed, a string of len is allocated,
+ blanked and null-terminated. */
-void
-gfc_free_ref_list (gfc_ref *p)
+gfc_expr *
+gfc_get_character_expr (int kind, locus *where, const char *src, int len)
{
- gfc_ref *q;
- int i;
+ gfc_expr *e;
+ gfc_char_t *dest;
- for (; p; p = q)
+ if (!src)
{
- q = p->next;
+ dest = gfc_get_wide_string (len + 1);
+ gfc_wide_memset (dest, ' ', len);
+ dest[len] = '\0';
+ }
+ else
+ dest = gfc_char_to_widechar (src);
- switch (p->type)
+ e = gfc_get_constant_expr (BT_CHARACTER, kind,
+ where ? where : &gfc_current_locus);
+ e->value.character.string = dest;
+ e->value.character.length = len;
+
+ return e;
+}
+
+
+/* Get a new expression node that is an integer constant. */
+
+gfc_expr *
+gfc_get_int_expr (int kind, locus *where, int value)
+{
+ gfc_expr *p;
+ p = gfc_get_constant_expr (BT_INTEGER, kind,
+ where ? where : &gfc_current_locus);
+
+ mpz_init_set_si (p->value.integer, value);
+
+ return p;
+}
+
+
+/* Get a new expression node that is a logical constant. */
+
+gfc_expr *
+gfc_get_logical_expr (int kind, locus *where, bool value)
+{
+ gfc_expr *p;
+ p = gfc_get_constant_expr (BT_LOGICAL, kind,
+ where ? where : &gfc_current_locus);
+
+ p->value.logical = value;
+
+ return p;
+}
+
+
+gfc_expr *
+gfc_get_iokind_expr (locus *where, io_kind k)
+{
+ gfc_expr *e;
+
+ /* Set the types to something compatible with iokind. This is needed to
+ get through gfc_free_expr later since iokind really has no Basic Type,
+ BT, of its own. */
+
+ e = gfc_get_expr ();
+ e->expr_type = EXPR_CONSTANT;
+ e->ts.type = BT_LOGICAL;
+ e->value.iokind = k;
+ e->where = *where;
+
+ return e;
+}
+
+
+/* Given an expression pointer, return a copy of the expression. This
+ subroutine is recursive. */
+
+gfc_expr *
+gfc_copy_expr (gfc_expr *p)
+{
+ gfc_expr *q;
+ gfc_char_t *s;
+ char *c;
+
+ if (p == NULL)
+ return NULL;
+
+ q = gfc_get_expr ();
+ *q = *p;
+
+ switch (q->expr_type)
+ {
+ case EXPR_SUBSTRING:
+ s = gfc_get_wide_string (p->value.character.length + 1);
+ q->value.character.string = s;
+ memcpy (s, p->value.character.string,
+ (p->value.character.length + 1) * sizeof (gfc_char_t));
+ break;
+
+ case EXPR_CONSTANT:
+ /* Copy target representation, if it exists. */
+ if (p->representation.string)
{
- case REF_ARRAY:
- for (i = 0; i < GFC_MAX_DIMENSIONS; i++)
+ c = XCNEWVEC (char, p->representation.length + 1);
+ q->representation.string = c;
+ memcpy (c, p->representation.string, (p->representation.length + 1));
+ }
+
+ /* Copy the values of any pointer components of p->value. */
+ switch (q->ts.type)
+ {
+ case BT_INTEGER:
+ mpz_init_set (q->value.integer, p->value.integer);
+ break;
+
+ case BT_REAL:
+ gfc_set_model_kind (q->ts.kind);
+ mpfr_init (q->value.real);
+ mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
+ break;
+
+ case BT_COMPLEX:
+ gfc_set_model_kind (q->ts.kind);
+ mpc_init2 (q->value.complex, mpfr_get_default_prec());
+ mpc_set (q->value.complex, p->value.complex, GFC_MPC_RND_MODE);
+ break;
+
+ case BT_CHARACTER:
+ if (p->representation.string)
+ q->value.character.string
+ = gfc_char_to_widechar (q->representation.string);
+ else
{
- gfc_free_expr (p->u.ar.start[i]);
- gfc_free_expr (p->u.ar.end[i]);
- gfc_free_expr (p->u.ar.stride[i]);
- }
+ s = gfc_get_wide_string (p->value.character.length + 1);
+ q->value.character.string = s;
+ /* This is the case for the C_NULL_CHAR named constant. */
+ if (p->value.character.length == 0
+ && (p->ts.is_c_interop || p->ts.is_iso_c))
+ {
+ *s = '\0';
+ /* Need to set the length to 1 to make sure the NUL
+ terminator is copied. */
+ q->value.character.length = 1;
+ }
+ else
+ memcpy (s, p->value.character.string,
+ (p->value.character.length + 1) * sizeof (gfc_char_t));
+ }
break;
- case REF_SUBSTRING:
- gfc_free_expr (p->u.ss.start);
- gfc_free_expr (p->u.ss.end);
+ case BT_HOLLERITH:
+ case BT_LOGICAL:
+ case BT_DERIVED:
+ case BT_CLASS:
+ break; /* Already done. */
+
+ case BT_PROCEDURE:
+ case BT_VOID:
+ /* Should never be reached. */
+ case BT_UNKNOWN:
+ gfc_internal_error ("gfc_copy_expr(): Bad expr node");
+ /* Not reached. */
+ }
+
+ break;
+
+ case EXPR_OP:
+ switch (q->value.op.op)
+ {
+ case INTRINSIC_NOT:
+ case INTRINSIC_PARENTHESES:
+ case INTRINSIC_UPLUS:
+ case INTRINSIC_UMINUS:
+ q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
break;
- case REF_COMPONENT:
+ default: /* Binary operators. */
+ q->value.op.op1 = gfc_copy_expr (p->value.op.op1);
+ q->value.op.op2 = gfc_copy_expr (p->value.op.op2);
break;
}
- gfc_free (p);
+ break;
+
+ case EXPR_FUNCTION:
+ q->value.function.actual =
+ gfc_copy_actual_arglist (p->value.function.actual);
+ break;
+
+ case EXPR_COMPCALL:
+ case EXPR_PPC:
+ q->value.compcall.actual =
+ gfc_copy_actual_arglist (p->value.compcall.actual);
+ q->value.compcall.tbp = p->value.compcall.tbp;
+ break;
+
+ case EXPR_STRUCTURE:
+ case EXPR_ARRAY:
+ q->value.constructor = gfc_constructor_copy (p->value.constructor);
+ break;
+
+ case EXPR_VARIABLE:
+ case EXPR_NULL:
+ break;
}
+
+ q->shape = gfc_copy_shape (p->shape, p->rank);
+
+ q->ref = gfc_copy_ref (p->ref);
+
+ return q;
}
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
/* Copy a shape array. */
-mpz_t *
-gfc_copy_shape (mpz_t *shape, int rank)
-{
- mpz_t *new_shape;
- int n;
-
- if (shape == NULL)
- return NULL;
-
- new_shape = gfc_get_shape (rank);
-
- for (n = 0; n < rank; n++)
- mpz_init_set (new_shape[n], shape[n]);
-
- return new_shape;
-}
-
-
-/* Copy a shape array excluding dimension N, where N is an integer
- constant expression. Dimensions are numbered in fortran style --
- starting with ONE.
-
- So, if the original shape array contains R elements
- { s1 ... sN-1 sN sN+1 ... sR-1 sR}
- the result contains R-1 elements:
- { s1 ... sN-1 sN+1 ... sR-1}
-
- If anything goes wrong -- N is not a constant, its value is out
- of range -- or anything else, just returns NULL. */
-
-mpz_t *
-gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
-{
- mpz_t *new_shape, *s;
- int i, n;
-
- if (shape == NULL
- || rank <= 1
- || dim == NULL
- || dim->expr_type != EXPR_CONSTANT
- || dim->ts.type != BT_INTEGER)
- return NULL;
-
- n = mpz_get_si (dim->value.integer);
- n--; /* Convert to zero based index. */
- if (n < 0 || n >= rank)
- return NULL;
-
- s = new_shape = gfc_get_shape (rank - 1);
-
- for (i = 0; i < rank; i++)
- {
- if (i == n)
- continue;
- mpz_init_set (*s, shape[i]);
- s++;
- }
-
- return new_shape;
-}
-
-
-/* Given an expression pointer, return a copy of the expression. This
- subroutine is recursive. */
-
-gfc_expr *
-gfc_copy_expr (gfc_expr *p)
-{
- gfc_expr *q;
- gfc_char_t *s;
- char *c;
-
- if (p == NULL)
- return NULL;
-
- q = gfc_get_expr ();
- *q = *p;
-
- switch (q->expr_type)
- {
- case EXPR_SUBSTRING:
- s = gfc_get_wide_string (p->value.character.length + 1);
- q->value.character.string = s;
- memcpy (s, p->value.character.string,
- (p->value.character.length + 1) * sizeof (gfc_char_t));
- break;
-
- case EXPR_CONSTANT:
- /* Copy target representation, if it exists. */
- if (p->representation.string)
- {
- c = XCNEWVEC (char, p->representation.length + 1);
- q->representation.string = c;
- memcpy (c, p->representation.string, (p->representation.length + 1));
- }
-
- /* Copy the values of any pointer components of p->value. */
- switch (q->ts.type)
- {
- case BT_INTEGER:
- mpz_init_set (q->value.integer, p->value.integer);
- break;
-
- case BT_REAL:
- gfc_set_model_kind (q->ts.kind);
- mpfr_init (q->value.real);
- mpfr_set (q->value.real, p->value.real, GFC_RND_MODE);
- break;
-
- case BT_COMPLEX:
- gfc_set_model_kind (q->ts.kind);
- 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
- {
- s = gfc_get_wide_string (p->value.character.length + 1);
- q->value.character.string = s;
+mpz_t *
+gfc_copy_shape (mpz_t *shape, int rank)
+{
+ mpz_t *new_shape;
+ int n;
- /* 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;
+ if (shape == NULL)
+ return NULL;
- case BT_HOLLERITH:
- case BT_LOGICAL:
- case BT_DERIVED:
- case BT_CLASS:
- break; /* Already done. */
+ new_shape = gfc_get_shape (rank);
- case BT_PROCEDURE:
- case BT_VOID:
- /* Should never be reached. */
- case BT_UNKNOWN:
- gfc_internal_error ("gfc_copy_expr(): Bad expr node");
- /* Not reached. */
- }
+ for (n = 0; n < rank; n++)
+ mpz_init_set (new_shape[n], shape[n]);
- break;
+ return new_shape;
+}
- 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;
- }
+/* Copy a shape array excluding dimension N, where N is an integer
+ constant expression. Dimensions are numbered in fortran style --
+ starting with ONE.
- break;
+ So, if the original shape array contains R elements
+ { s1 ... sN-1 sN sN+1 ... sR-1 sR}
+ the result contains R-1 elements:
+ { s1 ... sN-1 sN+1 ... sR-1}
- case EXPR_FUNCTION:
- q->value.function.actual =
- gfc_copy_actual_arglist (p->value.function.actual);
- break;
+ If anything goes wrong -- N is not a constant, its value is out
+ of range -- or anything else, just returns NULL. */
- 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;
+mpz_t *
+gfc_copy_shape_excluding (mpz_t *shape, int rank, gfc_expr *dim)
+{
+ mpz_t *new_shape, *s;
+ int i, n;
- case EXPR_STRUCTURE:
- case EXPR_ARRAY:
- q->value.constructor = gfc_copy_constructor (p->value.constructor);
- break;
+ if (shape == NULL
+ || rank <= 1
+ || dim == NULL
+ || dim->expr_type != EXPR_CONSTANT
+ || dim->ts.type != BT_INTEGER)
+ return NULL;
- case EXPR_VARIABLE:
- case EXPR_NULL:
- break;
- }
+ n = mpz_get_si (dim->value.integer);
+ n--; /* Convert to zero based index. */
+ if (n < 0 || n >= rank)
+ return NULL;
- q->shape = gfc_copy_shape (p->shape, p->rank);
+ s = new_shape = gfc_get_shape (rank - 1);
- q->ref = gfc_copy_ref (p->ref);
+ for (i = 0; i < rank; i++)
+ {
+ if (i == n)
+ continue;
+ mpz_init_set (*s, shape[i]);
+ s++;
+ }
- return q;
+ return new_shape;
}
}
-/* Returns an expression node that is an integer constant. */
-
-gfc_expr *
-gfc_int_expr (int i)
-{
- gfc_expr *p;
-
- p = gfc_get_expr ();
-
- p->expr_type = EXPR_CONSTANT;
- p->ts.type = BT_INTEGER;
- p->ts.kind = gfc_default_integer_kind;
-
- p->where = gfc_current_locus;
- mpz_init_set_si (p->value.integer, i);
-
- return p;
-}
-
-
-/* Returns an expression node that is a logical constant. */
-
-gfc_expr *
-gfc_logical_expr (int i, locus *where)
-{
- gfc_expr *p;
-
- p = gfc_get_expr ();
-
- p->expr_type = EXPR_CONSTANT;
- p->ts.type = BT_LOGICAL;
- p->ts.kind = gfc_default_logical_kind;
-
- if (where == NULL)
- where = &gfc_current_locus;
- p->where = *where;
- p->value.logical = i;
-
- return p;
-}
-
-
/* Return an expression node with an optional argument list attached.
A variable number of gfc_expr pointers are strung together in an
argument list with a NULL pointer terminating the list. */
{
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;
}
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;
}
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;
}
static gfc_try
simplify_const_ref (gfc_expr *p)
{
- gfc_constructor *cons;
+ gfc_constructor *cons, *c;
gfc_expr *newp;
gfc_ref *last_ref;
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 (p->ts.type == BT_DERIVED
&& p->ref->next
- && p->value.constructor)
+ && (c = gfc_constructor_first (p->value.constructor)))
{
/* There may have been component references. */
- p->ts = p->value.constructor->expr->ts;
+ p->ts = c->expr->ts;
}
last_ref = p->ref;
character length according to the first element
(as all should have the same length). */
int string_len;
- if (p->value.constructor)
+ 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
gfc_free_expr (p->ts.u.cl->length);
- p->ts.u.cl->length = gfc_int_expr (string_len);
+ p->ts.u.cl->length
+ = gfc_get_int_expr (gfc_default_integer_kind,
+ NULL, string_len);
}
}
gfc_free_ref_list (p->ref);
p->value.character.string = s;
p->value.character.length = end - start;
p->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- p->ts.u.cl->length = gfc_int_expr (p->value.character.length);
+ 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)
scalarize_intrinsic_call (gfc_expr *e)
{
gfc_actual_arglist *a, *b;
- gfc_constructor *args[5], *ctor, *new_ctor;
+ gfc_constructor_base ctor;
+ gfc_constructor *args[5];
+ gfc_constructor *ci, *new_ctor;
gfc_expr *expr, *old;
int n, i, rank[5], array_arg;
-
+
/* Find which, if any, arguments are arrays. Assume that the old
expression carries the type information and that the first arg
that is an array expression carries all the shape information.*/
old = gfc_copy_expr (e);
- gfc_free_constructor (expr->value.constructor);
+ gfc_constructor_free (expr->value.constructor);
expr->value.constructor = NULL;
-
expr->ts = old->ts;
expr->where = old->where;
expr->expr_type = EXPR_ARRAY;
{
rank[n] = a->expr->rank;
ctor = a->expr->symtree->n.sym->value->value.constructor;
- args[n] = gfc_copy_constructor (ctor);
+ args[n] = gfc_constructor_first (ctor);
}
else if (a->expr && a->expr->expr_type == EXPR_ARRAY)
{
rank[n] = a->expr->rank;
else
rank[n] = 1;
- args[n] = gfc_copy_constructor (a->expr->value.constructor);
+ ctor = gfc_constructor_copy (a->expr->value.constructor);
+ args[n] = gfc_constructor_first (ctor);
}
else
args[n] = NULL;
+
n++;
}
/* Using the array argument as the master, step through the array
calling the function for each element and advancing the array
constructors together. */
- ctor = args[array_arg - 1];
- new_ctor = NULL;
- for (; ctor; ctor = ctor->next)
+ for (ci = args[array_arg - 1]; ci; ci = gfc_constructor_next (ci))
{
- if (expr->value.constructor == NULL)
- expr->value.constructor
- = new_ctor = gfc_get_constructor ();
+ new_ctor = gfc_constructor_append_expr (&expr->value.constructor,
+ gfc_copy_expr (old), NULL);
+
+ gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
+ a = NULL;
+ b = old->value.function.actual;
+ for (i = 0; i < n; i++)
+ {
+ if (a == NULL)
+ new_ctor->expr->value.function.actual
+ = a = gfc_get_actual_arglist ();
else
{
- new_ctor->next = gfc_get_constructor ();
- new_ctor = new_ctor->next;
+ a->next = gfc_get_actual_arglist ();
+ a = a->next;
}
- new_ctor->expr = gfc_copy_expr (old);
- gfc_free_actual_arglist (new_ctor->expr->value.function.actual);
- a = NULL;
- b = old->value.function.actual;
- for (i = 0; i < n; i++)
- {
- if (a == NULL)
- new_ctor->expr->value.function.actual
- = a = gfc_get_actual_arglist ();
- else
- {
- a->next = gfc_get_actual_arglist ();
- a = a->next;
- }
- if (args[i])
- a->expr = gfc_copy_expr (args[i]->expr);
- else
- a->expr = gfc_copy_expr (b->expr);
- b = b->next;
- }
+ if (args[i])
+ a->expr = gfc_copy_expr (args[i]->expr);
+ else
+ a->expr = gfc_copy_expr (b->expr);
+
+ b = b->next;
+ }
- /* Simplify the function calls. If the simplification fails, the
- error will be flagged up down-stream or the library will deal
- with it. */
- gfc_simplify_expr (new_ctor->expr, 0);
+ /* Simplify the function calls. If the simplification fails, the
+ error will be flagged up down-stream or the library will deal
+ with it. */
+ gfc_simplify_expr (new_ctor->expr, 0);
- for (i = 0; i < n; i++)
- if (args[i])
- args[i] = args[i]->next;
+ for (i = 0; i < n; i++)
+ if (args[i])
+ args[i] = gfc_constructor_next (args[i]);
- for (i = 1; i < n; i++)
- if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
- || (args[i] == NULL && args[array_arg - 1] != NULL)))
- goto compliance;
+ for (i = 1; i < n; i++)
+ if (rank[i] && ((args[i] != NULL && args[array_arg - 1] == NULL)
+ || (args[i] == NULL && args[array_arg - 1] != NULL)))
+ goto compliance;
}
free_expr0 (e);
static gfc_try
check_alloc_comp_init (gfc_expr *e)
{
- gfc_component *c;
+ gfc_component *comp;
gfc_constructor *ctor;
gcc_assert (e->expr_type == EXPR_STRUCTURE);
gcc_assert (e->ts.type == BT_DERIVED);
- for (c = e->ts.u.derived->components, ctor = e->value.constructor;
- c; c = c->next, ctor = ctor->next)
+ for (comp = e->ts.u.derived->components,
+ ctor = gfc_constructor_first (e->value.constructor);
+ comp; comp = comp->next, ctor = gfc_constructor_next (ctor))
{
- if (c->attr.allocatable
+ if (comp->attr.allocatable
&& ctor->expr->expr_type != EXPR_NULL)
{
gfc_error("Invalid initialization expression for ALLOCATABLE "
"component '%s' in structure constructor at %L",
- c->name, &ctor->expr->where);
+ comp->name, &ctor->expr->where);
return FAILURE;
}
}
{
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;
/* 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);
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)
{
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;
}
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->u.derived->components; c; c = c->next)
- if (c->initializer || c->attr.allocatable)
+ for (comp = ts->u.derived->components; comp; comp = comp->next)
+ if (comp->initializer || comp->attr.allocatable)
break;
- if (!c)
+ if (!comp)
return NULL;
- /* Build the constructor. */
- init = gfc_get_expr ();
- init->expr_type = EXPR_STRUCTURE;
+ init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
+ &ts->u.derived->declared_at);
init->ts = *ts;
- init->where = ts->u.derived->declared_at;
- tail = NULL;
- for (c = ts->u.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)
{
- 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;
+}
+
+
+/* Build a NULL initializer for CLASS pointers,
+ initializing the $data and $vptr components to zero. */
+
+gfc_expr *
+gfc_class_null_initializer (gfc_typespec *ts)
+{
+ gfc_expr *init;
+ gfc_component *comp;
+
+ init = gfc_get_structure_constructor_expr (ts->type, ts->kind,
+ &ts->u.derived->declared_at);
+ init->ts = *ts;
+
+ for (comp = ts->u.derived->components; comp; comp = comp->next)
+ {
+ gfc_constructor *ctor = gfc_constructor_get();
+ 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;
}
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;
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, (gfc_symbol *)dest, &replace_comp, 0);
}
+
+bool
+gfc_is_coindexed (gfc_expr *e)
+{
+ gfc_ref *ref;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_ARRAY && ref->u.ar.codimen > 0)
+ return true;
+
+ return false;
+}
+
+
+/* Check whether the expression has an ultimate allocatable component.
+ Being itself allocatable does not count. */
+bool
+gfc_has_ultimate_allocatable (gfc_expr *e)
+{
+ gfc_ref *ref, *last = NULL;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+
+ if (last && last->u.c.component->ts.type == BT_CLASS)
+ return last->u.c.component->ts.u.derived->components->attr.alloc_comp;
+ else if (last && last->u.c.component->ts.type == BT_DERIVED)
+ return last->u.c.component->ts.u.derived->attr.alloc_comp;
+ else if (last)
+ return false;
+
+ if (e->ts.type == BT_CLASS)
+ return e->ts.u.derived->components->attr.alloc_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.alloc_comp;
+ else
+ return false;
+}
+
+
+/* Check whether the expression has an pointer component.
+ Being itself a pointer does not count. */
+bool
+gfc_has_ultimate_pointer (gfc_expr *e)
+{
+ gfc_ref *ref, *last = NULL;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ last = ref;
+
+ if (last && last->u.c.component->ts.type == BT_CLASS)
+ return last->u.c.component->ts.u.derived->components->attr.pointer_comp;
+ else if (last && last->u.c.component->ts.type == BT_DERIVED)
+ return last->u.c.component->ts.u.derived->attr.pointer_comp;
+ else if (last)
+ return false;
+
+ if (e->ts.type == BT_CLASS)
+ return e->ts.u.derived->components->attr.pointer_comp;
+ else if (e->ts.type == BT_DERIVED)
+ return e->ts.u.derived->attr.pointer_comp;
+ else
+ return false;
+}
OSDN Git Service
