/* 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.
#include "intrinsic.h"
#include "target-memory.h"
#include "constructor.h"
+#include "version.h" /* For version_string. */
gfc_expr gfc_bad_expr;
linked-list traversal. Masked elements are set to NULL. */
gfc_array_size (array, &size);
arraysize = mpz_get_ui (size);
+ mpz_clear (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;
}
gfc_expr *
+gfc_simplify_dreal (gfc_expr *e)
+{
+ gfc_expr *result = NULL;
+
+ if (e->expr_type != EXPR_CONSTANT)
+ return NULL;
+
+ result = gfc_get_constant_expr (BT_REAL, e->ts.kind, &e->where);
+ mpc_real (result->value.real, e->value.complex, GFC_RND_MODE);
+
+ return range_check (result, "DREAL");
+}
+
+
+gfc_expr *
gfc_simplify_anint (gfc_expr *e, gfc_expr *k)
{
gfc_expr *result;
k = gfc_validate_kind (BT_INTEGER, arg1->ts.kind, false);
size = gfc_integer_kinds[k].bit_size;
- if (gfc_extract_int (shiftarg, &shift) != NULL)
- {
- gfc_error ("Invalid SHIFT argument of DSHIFTL at %L", &shiftarg->where);
- return &gfc_bad_expr;
- }
-
- gcc_assert (shift >= 0 && shift <= size);
+ gfc_extract_int (shiftarg, &shift);
/* DSHIFTR(I,J,SHIFT) = DSHIFTL(I,J,SIZE-SHIFT). */
if (right)
}
+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)
{
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (y, &pos) != NULL || pos < 0)
- {
- gfc_error ("Invalid second argument of IBCLR at %L", &y->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (y, &pos);
k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- if (pos >= gfc_integer_kinds[k].bit_size)
- {
- gfc_error ("Second argument of IBCLR exceeds bit size at %L",
- &y->where);
- return &gfc_bad_expr;
- }
-
result = gfc_copy_expr (x);
convert_mpz_to_unsigned (result->value.integer,
|| z->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (y, &pos) != NULL || pos < 0)
- {
- gfc_error ("Invalid second argument of IBITS at %L", &y->where);
- return &gfc_bad_expr;
- }
-
- if (gfc_extract_int (z, &len) != NULL || len < 0)
- {
- gfc_error ("Invalid third argument of IBITS at %L", &z->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (y, &pos);
+ gfc_extract_int (z, &len);
k = gfc_validate_kind (BT_INTEGER, x->ts.kind, false);
gfc_internal_error ("IBITS: Bad bit");
}
- gfc_free (bits);
+ free (bits);
convert_mpz_to_signed (result->value.integer,
gfc_integer_kinds[k].bit_size);
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (y, &pos) != NULL || pos < 0)
- {
- gfc_error ("Invalid second argument of IBSET at %L", &y->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (y, &pos);
k = gfc_validate_kind (x->ts.type, x->ts.kind, false);
- if (pos >= gfc_integer_kinds[k].bit_size)
- {
- gfc_error ("Second argument of IBSET exceeds bit size at %L",
- &y->where);
- return &gfc_bad_expr;
- }
-
result = gfc_copy_expr (x);
convert_mpz_to_unsigned (result->value.integer,
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (s, &shift) != NULL)
- {
- gfc_error ("Invalid second argument of %s at %L", name, &s->where);
- return &gfc_bad_expr;
- }
+
+ gfc_extract_int (s, &shift);
k = gfc_validate_kind (BT_INTEGER, e->ts.kind, false);
bitsize = gfc_integer_kinds[k].bit_size;
}
convert_mpz_to_signed (result->value.integer, bitsize);
- gfc_free (bits);
+ free (bits);
return result;
}
if (e->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (s, &shift) != NULL)
- {
- gfc_error ("Invalid second argument of ISHFTC at %L", &s->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (s, &shift);
k = gfc_validate_kind (e->ts.type, e->ts.kind, false);
isize = gfc_integer_kinds[k].bit_size;
if (sz->expr_type != EXPR_CONSTANT)
return NULL;
- if (gfc_extract_int (sz, &ssize) != NULL || ssize <= 0)
- {
- gfc_error ("Invalid third argument of ISHFTC at %L", &sz->where);
- return &gfc_bad_expr;
- }
+ gfc_extract_int (sz, &ssize);
- if (ssize > isize)
- {
- gfc_error ("Magnitude of third argument of ISHFTC exceeds "
- "BIT_SIZE of first argument at %L", &s->where);
- return &gfc_bad_expr;
- }
}
else
ssize = isize;
if (ashift > ssize)
{
- if (sz != NULL)
- gfc_error ("Magnitude of second argument of ISHFTC exceeds "
- "third argument at %L", &s->where);
- else
+ if (sz == NULL)
gfc_error ("Magnitude of second argument of ISHFTC exceeds "
"BIT_SIZE of first argument at %L", &s->where);
return &gfc_bad_expr;
convert_mpz_to_signed (result->value.integer, isize);
- gfc_free (bits);
+ free (bits);
return result;
}
gcc_assert (array->expr_type == EXPR_VARIABLE);
gcc_assert (as);
+ if (gfc_resolve_array_spec (as, 0) == FAILURE)
+ return NULL;
+
/* 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)
{
gfc_array_spec *as;
int d;
+ if (array->ts.type == BT_CLASS)
+ return NULL;
+
if (array->expr_type != EXPR_VARIABLE)
{
as = NULL;
return NULL;
/* Follow any component references. */
- as = array->symtree->n.sym->as;
+ as = (array->ts.type == BT_CLASS && array->ts.u.derived->components)
+ ? array->ts.u.derived->components->as
+ : array->symtree->n.sym->as;
for (ref = array->ref; ref; ref = ref->next)
{
switch (ref->type)
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;
}
}
- gcc_unreachable ();
+ if (!as)
+ gcc_unreachable ();
done:
- if (as->type == AS_DEFERRED || as->type == AS_ASSUMED_SHAPE)
+ if (as->cotype == AS_DEFERRED || as->cotype == AS_ASSUMED_SHAPE)
return NULL;
if (dim == NULL)
/* Simplify the cobounds for each dimension. */
for (d = 0; d < as->corank; d++)
{
- bounds[d] = simplify_bound_dim (array, kind, d + 1 + array->rank,
+ bounds[d] = simplify_bound_dim (array, kind, d + 1 + as->rank,
upper, as, ref, true);
if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
{
return &gfc_bad_expr;
}
- return simplify_bound_dim (array, kind, d+array->rank, upper, as, ref, true);
+ return simplify_bound_dim (array, kind, d+as->rank, upper, as, ref, true);
}
}
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));
if (x->expr_type != EXPR_CONSTANT || s->expr_type != EXPR_CONSTANT)
return NULL;
- if (mpfr_sgn (s->value.real) == 0)
- {
- gfc_error ("Second argument of NEAREST at %L shall not be zero",
- &s->where);
- return &gfc_bad_expr;
- }
-
result = gfc_copy_expr (x);
/* Save current values of emin and emax. */
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_simplify_size (gfc_expr *array, gfc_expr *dim, gfc_expr *kind)
{
mpz_t size;
+ gfc_expr *return_value;
int d;
int k = get_kind (BT_INTEGER, kind, "SIZE", gfc_default_integer_kind);
case INTRINSIC_NOT:
case INTRINSIC_UPLUS:
case INTRINSIC_UMINUS:
+ case INTRINSIC_PARENTHESES:
replacement = array->value.op.op1;
break;
return NULL;
}
- return gfc_get_int_expr (k, &array->where, mpz_get_si (size));
+ return_value = gfc_get_int_expr (k, &array->where, mpz_get_si (size));
+ mpz_clear (size);
+ return return_value;
}
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_expr *
gfc_simplify_this_image (gfc_expr *coarray, gfc_expr *dim)
{
- gfc_ref *ref;
- gfc_array_spec *as;
- int d;
+ if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
+ return NULL;
if (coarray == NULL)
{
return result;
}
- gcc_assert (coarray->expr_type == EXPR_VARIABLE);
-
- /* Follow any component references. */
- as = coarray->symtree->n.sym->as;
- for (ref = coarray->ref; ref; ref = ref->next)
- if (ref->type == REF_COMPONENT)
- as = ref->u.ar.as;
-
- if (as->type == AS_DEFERRED)
- goto not_implemented; /* return NULL;*/
-
- if (dim == NULL)
- {
- /* Multi-dimensional bounds. */
- gfc_expr *bounds[GFC_MAX_DIMENSIONS];
- gfc_expr *e;
-
- /* Simplify the bounds for each dimension. */
- for (d = 0; d < as->corank; d++)
- {
- bounds[d] = simplify_bound_dim (coarray, NULL, d + as->rank + 1, 0,
- as, NULL, true);
- if (bounds[d] == NULL || bounds[d] == &gfc_bad_expr)
- {
- int j;
-
- for (j = 0; j < d; j++)
- gfc_free_expr (bounds[j]);
- if (bounds[d] == NULL)
- goto not_implemented;
- return bounds[d];
- }
- }
-
- /* Allocate the result expression. */
- e = gfc_get_expr ();
- e->where = coarray->where;
- e->expr_type = EXPR_ARRAY;
- e->ts.type = BT_INTEGER;
- e->ts.kind = gfc_default_integer_kind;
-
- e->rank = 1;
- e->shape = gfc_get_shape (1);
- mpz_init_set_ui (e->shape[0], as->corank);
-
- /* Create the constructor for this array. */
- for (d = 0; d < as->corank; d++)
- gfc_constructor_append_expr (&e->value.constructor,
- bounds[d], &e->where);
-
- return e;
- }
- else
- {
- gfc_expr *e;
- /* A DIM argument is specified. */
- if (dim->expr_type != EXPR_CONSTANT)
- goto not_implemented; /*return NULL;*/
-
- d = mpz_get_si (dim->value.integer);
-
- if (d < 1 || d > as->corank)
- {
- gfc_error ("DIM argument at %L is out of bounds", &dim->where);
- 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;
- }
-
-not_implemented:
- gfc_error ("Not yet implemented: THIS_IMAGE for coarray with non-constant "
- "cobounds at %L", &coarray->where);
- return &gfc_bad_expr;
+ /* For -fcoarray=single, this_image(A) is the same as lcobound(A). */
+ return simplify_cobound (coarray, dim, NULL, 0);
}
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);
}
else
return NULL;
}
+
+
+gfc_expr *
+gfc_simplify_compiler_options (void)
+{
+ char *str;
+ gfc_expr *result;
+
+ str = gfc_get_option_string ();
+ result = gfc_get_character_expr (gfc_default_character_kind,
+ &gfc_current_locus, str, strlen (str));
+ free (str);
+ return result;
+}
+
+
+gfc_expr *
+gfc_simplify_compiler_version (void)
+{
+ char *buffer;
+ size_t len;
+
+ 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);
+}
OSDN Git Service
