/* Simplify intrinsic functions at compile-time.
Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009,
- 2010 Free Software Foundation, Inc.
+ 2010, 2011 Free Software Foundation, Inc.
Contributed by Andy Vaught & Katherine Holcomb
This file is part of GCC.
gfc_array_size (array, &size);
arraysize = mpz_get_ui (size);
- arrayvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * arraysize);
+ arrayvec = XCNEWVEC (gfc_expr*, arraysize);
array_ctor = gfc_constructor_first (array->value.constructor);
mask_ctor = NULL;
resultsize = mpz_get_ui (size);
mpz_clear (size);
- resultvec = (gfc_expr**) gfc_getmem (sizeof (gfc_expr*) * resultsize);
+ resultvec = XCNEWVEC (gfc_expr*, resultsize);
result_ctor = gfc_constructor_first (result->value.constructor);
for (i = 0; i < resultsize; ++i)
{
result_ctor = gfc_constructor_next (result_ctor);
}
- gfc_free (arrayvec);
- gfc_free (resultvec);
+ free (arrayvec);
+ free (resultvec);
return result;
}
}
+static bool
+is_last_ref_vtab (gfc_expr *e)
+{
+ gfc_ref *ref;
+ gfc_component *comp = NULL;
+
+ if (e->expr_type != EXPR_VARIABLE)
+ return false;
+
+ for (ref = e->ref; ref; ref = ref->next)
+ if (ref->type == REF_COMPONENT)
+ comp = ref->u.c.component;
+
+ if (!e->ref || !comp)
+ return e->symtree->n.sym->attr.vtab;
+
+ if (comp->name[0] == '_' && strcmp (comp->name, "_vptr") == 0)
+ return true;
+
+ return false;
+}
+
+
+gfc_expr *
+gfc_simplify_extends_type_of (gfc_expr *a, gfc_expr *mold)
+{
+ /* Avoid simplification of resolved symbols. */
+ if (is_last_ref_vtab (a) || is_last_ref_vtab (mold))
+ return NULL;
+
+ if (a->ts.type == BT_DERIVED && mold->ts.type == BT_DERIVED)
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_type_is_extension_of (mold->ts.u.derived,
+ a->ts.u.derived));
+ /* Return .false. if the dynamic type can never be the same. */
+ if ((a->ts.type == BT_CLASS && mold->ts.type == BT_CLASS
+ && !gfc_type_is_extension_of
+ (mold->ts.u.derived->components->ts.u.derived,
+ a->ts.u.derived->components->ts.u.derived)
+ && !gfc_type_is_extension_of
+ (a->ts.u.derived->components->ts.u.derived,
+ mold->ts.u.derived->components->ts.u.derived))
+ || (a->ts.type == BT_DERIVED && mold->ts.type == BT_CLASS
+ && !gfc_type_is_extension_of
+ (a->ts.u.derived,
+ mold->ts.u.derived->components->ts.u.derived)
+ && !gfc_type_is_extension_of
+ (mold->ts.u.derived->components->ts.u.derived,
+ a->ts.u.derived))
+ || (a->ts.type == BT_CLASS && mold->ts.type == BT_DERIVED
+ && !gfc_type_is_extension_of
+ (mold->ts.u.derived,
+ a->ts.u.derived->components->ts.u.derived)))
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+ if (mold->ts.type == BT_DERIVED
+ && gfc_type_is_extension_of (mold->ts.u.derived,
+ a->ts.u.derived->components->ts.u.derived))
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, true);
+
+ return NULL;
+}
+
+
+gfc_expr *
+gfc_simplify_same_type_as (gfc_expr *a, gfc_expr *b)
+{
+ /* Avoid simplification of resolved symbols. */
+ if (is_last_ref_vtab (a) || is_last_ref_vtab (b))
+ return NULL;
+
+ /* Return .false. if the dynamic type can never be the
+ same. */
+ if ((a->ts.type == BT_CLASS || b->ts.type == BT_CLASS)
+ && !gfc_type_compatible (&a->ts, &b->ts)
+ && !gfc_type_compatible (&b->ts, &a->ts))
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where, false);
+
+ if (a->ts.type != BT_DERIVED || b->ts.type != BT_DERIVED)
+ return NULL;
+
+ return gfc_get_logical_expr (gfc_default_logical_kind, &a->where,
+ gfc_compare_derived_types (a->ts.u.derived,
+ b->ts.u.derived));
+}
+
+
gfc_expr *
gfc_simplify_floor (gfc_expr *e, gfc_expr *k)
{
gfc_internal_error ("IBITS: Bad bit");
}
- gfc_free (bits);
+ free (bits);
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
}
convert_mpz_to_signed (result->value.integer, bitsize);
- gfc_free (bits);
+ free (bits);
return result;
}
convert_mpz_to_signed (result->value.integer, isize);
- gfc_free (bits);
+ free (bits);
return result;
}
/* The last dimension of an assumed-size array is special. */
if ((!coarray && d == as->rank && as->type == AS_ASSUMED_SIZE && !upper)
- || (coarray && d == as->rank + as->corank))
+ || (coarray && d == as->rank + as->corank
+ && (!upper || gfc_option.coarray == GFC_FCOARRAY_SINGLE)))
{
if (as->lower[d-1]->expr_type == EXPR_CONSTANT)
{
switch (ref->u.ar.type)
{
case AR_ELEMENT:
- if (ref->next == NULL)
+ if (ref->u.ar.as->corank > 0)
{
- gcc_assert (ref->u.ar.as->corank > 0
- && ref->u.ar.as->rank == 0);
- as = ref->u.ar.as;
+ gcc_assert (as == ref->u.ar.as);
goto done;
}
as = NULL;
gfc_expr *
gfc_simplify_lcobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- gfc_expr *e;
- /* return simplify_cobound (array, dim, kind, 0);*/
-
- e = simplify_cobound (array, dim, kind, 0);
- if (e != NULL)
- return e;
-
- gfc_error ("Not yet implemented: LCOBOUND for coarray with non-constant "
- "cobounds at %L", &array->where);
- return &gfc_bad_expr;
+ return simplify_cobound (array, dim, kind, 0);
}
gfc_expr *
LENGTH(arg) - LENGTH(extremum));
STRING(extremum)[LENGTH(arg)] = '\0'; /* For debugger */
LENGTH(extremum) = LENGTH(arg);
- gfc_free (tmp);
+ free (tmp);
}
if (gfc_compare_string (arg, extremum) * sign > 0)
{
- gfc_free (STRING(extremum));
+ free (STRING(extremum));
STRING(extremum) = gfc_get_wide_string (LENGTH(extremum) + 1);
memcpy (STRING(extremum), STRING(arg),
LENGTH(arg) * sizeof (gfc_char_t));
return &gfc_bad_expr;
}
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ return NULL;
+
/* FIXME: gfc_current_locus is wrong. */
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
gfc_expr *
+gfc_simplify_rank (gfc_expr *e)
+{
+ return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank);
+}
+
+
+gfc_expr *
gfc_simplify_real (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result = NULL;
gfc_expr *
-gfc_simplify_shape (gfc_expr *source)
+gfc_simplify_shape (gfc_expr *source, gfc_expr *kind)
{
mpz_t shape[GFC_MAX_DIMENSIONS];
gfc_expr *result, *e, *f;
gfc_array_ref *ar;
int n;
gfc_try t;
+ int k = get_kind (BT_INTEGER, kind, "SHAPE", gfc_default_integer_kind);
- if (source->rank == 0)
- return gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ result = gfc_get_array_expr (BT_INTEGER, k, &source->where);
- result = gfc_get_array_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ if (source->rank == 0)
+ return result;
if (source->expr_type == EXPR_VARIABLE)
{
for (n = 0; n < source->rank; n++)
{
- e = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
- &source->where);
+ e = gfc_get_constant_expr (BT_INTEGER, k, &source->where);
if (t == SUCCESS)
{
gfc_expr *mold_element;
size_t source_size;
size_t result_size;
- size_t result_elt_size;
size_t buffer_size;
mpz_t tmp;
unsigned char *buffer;
+ size_t result_length;
+
if (!gfc_is_constant_expr (source)
|| (gfc_init_expr_flag && !gfc_is_constant_expr (mold))
|| !gfc_is_constant_expr (size))
return NULL;
- if (source->expr_type == EXPR_FUNCTION)
+ if (gfc_calculate_transfer_sizes (source, mold, size, &source_size,
+ &result_size, &result_length) == FAILURE)
return NULL;
/* Calculate the size of the source. */
&& gfc_array_size (source, &tmp) == FAILURE)
gfc_internal_error ("Failure getting length of a constant array.");
- source_size = gfc_target_expr_size (source);
-
/* Create an empty new expression with the appropriate characteristics. */
result = gfc_get_constant_expr (mold->ts.type, mold->ts.kind,
&source->where);
result->value.character.length = mold_element->value.character.length;
/* Set the number of elements in the result, and determine its size. */
- result_elt_size = gfc_target_expr_size (mold_element);
- if (result_elt_size == 0)
- {
- gfc_free_expr (result);
- return NULL;
- }
if (mold->expr_type == EXPR_ARRAY || mold->rank || size)
{
- int result_length;
-
result->expr_type = EXPR_ARRAY;
result->rank = 1;
-
- if (size)
- result_length = (size_t)mpz_get_ui (size->value.integer);
- else
- {
- result_length = source_size / result_elt_size;
- if (result_length * result_elt_size < source_size)
- result_length += 1;
- }
-
result->shape = gfc_get_shape (1);
mpz_init_set_ui (result->shape[0], result_length);
-
- result_size = result_length * result_elt_size;
}
else
- {
- result->rank = 0;
- result_size = result_elt_size;
- }
-
- if (gfc_option.warn_surprising && source_size < result_size)
- gfc_warning("Intrinsic TRANSFER at %L has partly undefined result: "
- "source size %ld < result size %ld", &source->where,
- (long) source_size, (long) result_size);
+ result->rank = 0;
/* Allocate the buffer to store the binary version of the source. */
buffer_size = MAX (source_size, result_size);
gfc_target_encode_expr (source, buffer, buffer_size);
/* And read the buffer back into the new expression. */
- gfc_target_interpret_expr (buffer, buffer_size, result);
+ gfc_target_interpret_expr (buffer, buffer_size, result, false);
return result;
}
int d;
if (!is_constant_array_expr (sub))
- goto not_implemented; /* return NULL;*/
+ return NULL;
/* Follow any component references. */
as = coarray->symtree->n.sym->as;
as = ref->u.ar.as;
if (as->type == AS_DEFERRED)
- goto not_implemented; /* return NULL;*/
+ return NULL;
/* "valid sequence of cosubscripts" are required; thus, return 0 unless
the cosubscript addresses the first image. */
gfc_expr *ca_bound;
int cmp;
- if (sub_cons == NULL)
- {
- gfc_error ("Too few elements in expression for SUB= argument at %L",
- &sub->where);
- return &gfc_bad_expr;
- }
+ gcc_assert (sub_cons != NULL);
ca_bound = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as,
NULL, true);
if (ca_bound == NULL)
- goto not_implemented; /* return NULL */
+ return NULL;
if (ca_bound == &gfc_bad_expr)
return ca_bound;
sub_cons = gfc_constructor_next (sub_cons);
}
- if (sub_cons != NULL)
- {
- gfc_error ("Too many elements in expression for SUB= argument at %L",
- &sub->where);
- return &gfc_bad_expr;
- }
+ gcc_assert (sub_cons == NULL);
+
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && !first_image)
+ return NULL;
result = gfc_get_constant_expr (BT_INTEGER, gfc_default_integer_kind,
&gfc_current_locus);
mpz_set_si (result->value.integer, 0);
return result;
-
-not_implemented:
- gfc_error ("Not yet implemented: IMAGE_INDEX for coarray with non-constant "
- "cobounds at %L", &coarray->where);
- return &gfc_bad_expr;
}
gfc_array_spec *as;
int d;
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ return NULL;
+
if (coarray == NULL)
{
gfc_expr *result;
as = ref->u.ar.as;
if (as->type == AS_DEFERRED)
- goto not_implemented; /* return NULL;*/
+ return NULL;
if (dim == NULL)
{
for (j = 0; j < d; j++)
gfc_free_expr (bounds[j]);
- if (bounds[d] == NULL)
- goto not_implemented;
+
return bounds[d];
}
}
}
else
{
- gfc_expr *e;
/* A DIM argument is specified. */
if (dim->expr_type != EXPR_CONSTANT)
- goto not_implemented; /*return NULL;*/
+ return NULL;
d = mpz_get_si (dim->value.integer);
return &gfc_bad_expr;
}
- /*return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);*/
- e = simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL, true);
- if (e != NULL)
- return e;
- else
- goto not_implemented;
+ return simplify_bound_dim (coarray, NULL, d + as->rank, 0, as, NULL,
+ true);
}
-
-not_implemented:
- gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
- "cobounds at %L", &coarray->where);
- return &gfc_bad_expr;
}
gfc_expr *
gfc_simplify_ucobound (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
- gfc_expr *e;
- /* return simplify_cobound (array, dim, kind, 1);*/
-
- e = simplify_cobound (array, dim, kind, 1);
- if (e != NULL)
- return e;
-
- gfc_error ("Not yet implemented: UCOBOUND for coarray with non-constant "
- "cobounds at %L", &array->where);
- return &gfc_bad_expr;
+ return simplify_cobound (array, dim, kind, 1);
}
str = gfc_get_option_string ();
result = gfc_get_character_expr (gfc_default_character_kind,
&gfc_current_locus, str, strlen (str));
- gfc_free (str);
+ free (str);
return result;
}
char *buffer;
size_t len;
- len = strlen ("GCC version ") + strlen (version_string) + 1;
- buffer = (char*) alloca (len);
- snprintf (buffer, len, "GCC version %s", version_string);
+ len = strlen ("GCC version ") + strlen (version_string);
+ buffer = XALLOCAVEC (char, len + 1);
+ snprintf (buffer, len + 1, "GCC version %s", version_string);
return gfc_get_character_expr (gfc_default_character_kind,
&gfc_current_locus, buffer, len);
}