/* Write a constant expression in binary form to a buffer. */
int
gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
size_t buffer_size)
{
if (source == NULL)
return 0;
if (source->expr_type == EXPR_ARRAY)
return encode_array (source, buffer, buffer_size);
gcc_assert (source->expr_type == EXPR_CONSTANT
|| source->expr_type == EXPR_STRUCTURE
|| source->expr_type == EXPR_SUBSTRING);
/* If we already have a target-memory representation, we use that rather
than recreating one. */
if (source->representation.string)
{
memcpy (buffer, source->representation.string,
source->representation.length);
return source->representation.length;
}
switch (source->ts.type)
{
case BT_INTEGER:
return encode_integer (source->ts.kind, source->value.integer, buffer,
buffer_size);
case BT_REAL:
return encode_float (source->ts.kind, source->value.real, buffer,
buffer_size);
case BT_COMPLEX:
return encode_complex (source->ts.kind, source->value.complex.r,
source->value.complex.i, buffer, buffer_size);
case BT_LOGICAL:
return encode_logical (source->ts.kind, source->value.logical, buffer,
buffer_size);
case BT_CHARACTER:
if (source->expr_type == EXPR_CONSTANT || source->ref == NULL)
return encode_character (source->value.character.length,
source->value.character.string, buffer,
buffer_size);
else
{
int start, end;
gcc_assert (source->expr_type == EXPR_SUBSTRING);
gfc_extract_int (source->ref->u.ss.start, &start);
gfc_extract_int (source->ref->u.ss.end, &end);
return encode_character (MAX(end - start + 1, 0),
&source->value.character.string[start-1],
buffer, buffer_size);
}
case BT_DERIVED:
return encode_derived (source, buffer, buffer_size);
default:
gfc_internal_error ("Invalid expression in gfc_target_encode_expr.");
return 0;
}
}
size_t
gfc_target_expr_size (gfc_expr *e)
{
tree type;
gcc_assert (e != NULL);
if (e->expr_type == EXPR_ARRAY)
return size_array (e);
switch (e->ts.type)
{
case BT_INTEGER:
return size_integer (e->ts.kind);
case BT_REAL:
return size_float (e->ts.kind);
case BT_COMPLEX:
return size_complex (e->ts.kind);
case BT_LOGICAL:
return size_logical (e->ts.kind);
case BT_CHARACTER:
if (e->expr_type == EXPR_SUBSTRING && e->ref)
{
int start, end;
gfc_extract_int (e->ref->u.ss.start, &start);
gfc_extract_int (e->ref->u.ss.end, &end);
return size_character (MAX(end - start + 1, 0), e->ts.kind);
}
else
return size_character (e->value.character.length, e->ts.kind);
case BT_HOLLERITH:
return e->representation.length;
case BT_DERIVED:
type = gfc_typenode_for_spec (&e->ts);
return int_size_in_bytes (type);
default:
gfc_internal_error ("Invalid expression in gfc_target_expr_size.");
return 0;
}
}
static gfc_expr *
create_character_intializer (gfc_expr * init, gfc_typespec * ts,
gfc_ref * ref, gfc_expr * rvalue)
{
int len;
int start;
int end;
char *dest;
gfc_extract_int (ts->cl->length, &len);
if (init == NULL)
{
/* Create a new initializer. */
init = gfc_get_expr ();
init->expr_type = EXPR_CONSTANT;
init->ts = *ts;
dest = gfc_getmem (len + 1);
dest[len] = '\0';
init->value.character.length = len;
init->value.character.string = dest;
/* Blank the string if we're only setting a substring. */
if (ref != NULL)
memset (dest, ' ', len);
}
else
dest = init->value.character.string;
if (ref)
{
gfc_expr *start_expr, *end_expr;
gcc_assert (ref->type == REF_SUBSTRING);
/* Only set a substring of the destination. Fortran substring bounds
are one-based [start, end], we want zero based [start, end). */
start_expr = gfc_copy_expr (ref->u.ss.start);
end_expr = gfc_copy_expr (ref->u.ss.end);
if ((gfc_simplify_expr (start_expr, 1) == FAILURE)
|| (gfc_simplify_expr (end_expr, 1)) == FAILURE)
{
gfc_error ("failure to simplify substring reference in DATA"
"statement at %L", &ref->u.ss.start->where);
return NULL;
}
gfc_extract_int (start_expr, &start);
start--;
gfc_extract_int (end_expr, &end);
}
else
{
/* Set the whole string. */
start = 0;
end = len;
}
/* Copy the initial value. */
len = rvalue->value.character.length;
if (len > end - start)
{
len = end - start;
gfc_warning_now ("initialization string truncated to match variable "
"at %L", &rvalue->where);
}
memcpy (&dest[start], rvalue->value.character.string, len);
/* Pad with spaces. Substrings will already be blanked. */
if (len < end - start && ref == NULL)
memset (&dest[start + len], ' ', end - (start + len));
if (rvalue->ts.type == BT_HOLLERITH)
init->from_H = 1;
return init;
}
static gfc_expr *
create_character_initializer (gfc_expr *init, gfc_typespec *ts,
gfc_ref *ref, gfc_expr *rvalue)
{
int len, start, end, tlen;
gfc_char_t *dest;
bool alloced_init = false;
gfc_extract_int (ts->u.cl->length, &len);
if (init == NULL)
{
/* Create a new initializer. */
init = gfc_get_character_expr (ts->kind, NULL, NULL, len);
init->ts = *ts;
alloced_init = true;
}
dest = init->value.character.string;
if (ref)
{
gfc_expr *start_expr, *end_expr;
gcc_assert (ref->type == REF_SUBSTRING);
/* Only set a substring of the destination. Fortran substring bounds
are one-based [start, end], we want zero based [start, end). */
start_expr = gfc_copy_expr (ref->u.ss.start);
end_expr = gfc_copy_expr (ref->u.ss.end);
if ((!gfc_simplify_expr(start_expr, 1))
|| !(gfc_simplify_expr(end_expr, 1)))
{
gfc_error ("failure to simplify substring reference in DATA "
"statement at %L", &ref->u.ss.start->where);
gfc_free_expr (start_expr);
gfc_free_expr (end_expr);
if (alloced_init)
gfc_free_expr (init);
return NULL;
}
gfc_extract_int (start_expr, &start);
gfc_free_expr (start_expr);
start--;
gfc_extract_int (end_expr, &end);
gfc_free_expr (end_expr);
}
else
{
/* Set the whole string. */
start = 0;
end = len;
}
/* Copy the initial value. */
if (rvalue->ts.type == BT_HOLLERITH)
len = rvalue->representation.length - rvalue->ts.u.pad;
else
len = rvalue->value.character.length;
tlen = end - start;
if (len > tlen)
{
if (tlen < 0)
{
gfc_warning_now (0, "Unused initialization string at %L because "
"variable has zero length", &rvalue->where);
len = 0;
}
else
{
gfc_warning_now (0, "Initialization string at %L was truncated to "
"fit the variable (%d/%d)", &rvalue->where,
tlen, len);
len = tlen;
}
}
if (rvalue->ts.type == BT_HOLLERITH)
{
int i;
for (i = 0; i < len; i++)
dest[start+i] = rvalue->representation.string[i];
}
else
memcpy (&dest[start], rvalue->value.character.string,
len * sizeof (gfc_char_t));
/* Pad with spaces. Substrings will already be blanked. */
if (len < tlen && ref == NULL)
gfc_wide_memset (&dest[start + len], ' ', end - (start + len));
if (rvalue->ts.type == BT_HOLLERITH)
{
init->representation.length = init->value.character.length;
init->representation.string
= gfc_widechar_to_char (init->value.character.string,
init->value.character.length);
}
return init;
}
static match
gfc_match_omp_clauses (gfc_omp_clauses **cp, int mask)
{
gfc_omp_clauses *c = gfc_get_omp_clauses ();
locus old_loc;
bool needs_space = true, first = true;
*cp = NULL;
while (1)
{
if ((first || gfc_match_char (',') != MATCH_YES)
&& (needs_space && gfc_match_space () != MATCH_YES))
break;
needs_space = false;
first = false;
gfc_gobble_whitespace ();
if ((mask & OMP_CLAUSE_IF) && c->if_expr == NULL
&& gfc_match ("if ( %e )", &c->if_expr) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_NUM_THREADS) && c->num_threads == NULL
&& gfc_match ("num_threads ( %e )", &c->num_threads) == MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_PRIVATE)
&& gfc_match_omp_variable_list ("private (",
&c->lists[OMP_LIST_PRIVATE], true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_FIRSTPRIVATE)
&& gfc_match_omp_variable_list ("firstprivate (",
&c->lists[OMP_LIST_FIRSTPRIVATE],
true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_LASTPRIVATE)
&& gfc_match_omp_variable_list ("lastprivate (",
&c->lists[OMP_LIST_LASTPRIVATE],
true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_COPYPRIVATE)
&& gfc_match_omp_variable_list ("copyprivate (",
&c->lists[OMP_LIST_COPYPRIVATE],
true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_SHARED)
&& gfc_match_omp_variable_list ("shared (",
&c->lists[OMP_LIST_SHARED], true)
== MATCH_YES)
continue;
if ((mask & OMP_CLAUSE_COPYIN)
&& gfc_match_omp_variable_list ("copyin (",
&c->lists[OMP_LIST_COPYIN], true)
== MATCH_YES)
continue;
old_loc = gfc_current_locus;
if ((mask & OMP_CLAUSE_REDUCTION)
&& gfc_match ("reduction ( ") == MATCH_YES)
{
int reduction = OMP_LIST_NUM;
char buffer[GFC_MAX_SYMBOL_LEN + 1];
if (gfc_match_char ('+') == MATCH_YES)
reduction = OMP_LIST_PLUS;
else if (gfc_match_char ('*') == MATCH_YES)
reduction = OMP_LIST_MULT;
else if (gfc_match_char ('-') == MATCH_YES)
reduction = OMP_LIST_SUB;
else if (gfc_match (".and.") == MATCH_YES)
reduction = OMP_LIST_AND;
else if (gfc_match (".or.") == MATCH_YES)
reduction = OMP_LIST_OR;
else if (gfc_match (".eqv.") == MATCH_YES)
reduction = OMP_LIST_EQV;
else if (gfc_match (".neqv.") == MATCH_YES)
reduction = OMP_LIST_NEQV;
else if (gfc_match_name (buffer) == MATCH_YES)
{
gfc_symbol *sym;
const char *n = buffer;
gfc_find_symbol (buffer, NULL, 1, &sym);
if (sym != NULL)
{
if (sym->attr.intrinsic)
n = sym->name;
else if ((sym->attr.flavor != FL_UNKNOWN
&& sym->attr.flavor != FL_PROCEDURE)
|| sym->attr.external
|| sym->attr.generic
|| sym->attr.entry
|| sym->attr.result
|| sym->attr.dummy
|| sym->attr.subroutine
|| sym->attr.pointer
|| sym->attr.target
|| sym->attr.cray_pointer
|| sym->attr.cray_pointee
|| (sym->attr.proc != PROC_UNKNOWN
&& sym->attr.proc != PROC_INTRINSIC)
|| sym->attr.if_source != IFSRC_UNKNOWN
|| sym == sym->ns->proc_name)
{
gfc_error_now ("%s is not INTRINSIC procedure name "
"at %C", buffer);
sym = NULL;
}
else
n = sym->name;
}
if (strcmp (n, "max") == 0)
reduction = OMP_LIST_MAX;
else if (strcmp (n, "min") == 0)
reduction = OMP_LIST_MIN;
else if (strcmp (n, "iand") == 0)
reduction = OMP_LIST_IAND;
else if (strcmp (n, "ior") == 0)
reduction = OMP_LIST_IOR;
else if (strcmp (n, "ieor") == 0)
reduction = OMP_LIST_IEOR;
if (reduction != OMP_LIST_NUM
&& sym != NULL
&& ! sym->attr.intrinsic
&& ! sym->attr.use_assoc
&& ((sym->attr.flavor == FL_UNKNOWN
&& gfc_add_flavor (&sym->attr, FL_PROCEDURE,
sym->name, NULL) == FAILURE)
|| gfc_add_intrinsic (&sym->attr, NULL) == FAILURE))
{
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
}
if (reduction != OMP_LIST_NUM
&& gfc_match_omp_variable_list (" :", &c->lists[reduction],
false)
== MATCH_YES)
continue;
else
gfc_current_locus = old_loc;
}
if ((mask & OMP_CLAUSE_DEFAULT)
&& c->default_sharing == OMP_DEFAULT_UNKNOWN)
{
if (gfc_match ("default ( shared )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_SHARED;
else if (gfc_match ("default ( private )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_PRIVATE;
else if (gfc_match ("default ( none )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_NONE;
else if (gfc_match ("default ( firstprivate )") == MATCH_YES)
c->default_sharing = OMP_DEFAULT_FIRSTPRIVATE;
if (c->default_sharing != OMP_DEFAULT_UNKNOWN)
continue;
}
old_loc = gfc_current_locus;
if ((mask & OMP_CLAUSE_SCHEDULE)
&& c->sched_kind == OMP_SCHED_NONE
&& gfc_match ("schedule ( ") == MATCH_YES)
{
if (gfc_match ("static") == MATCH_YES)
c->sched_kind = OMP_SCHED_STATIC;
else if (gfc_match ("dynamic") == MATCH_YES)
c->sched_kind = OMP_SCHED_DYNAMIC;
else if (gfc_match ("guided") == MATCH_YES)
c->sched_kind = OMP_SCHED_GUIDED;
else if (gfc_match ("runtime") == MATCH_YES)
c->sched_kind = OMP_SCHED_RUNTIME;
else if (gfc_match ("auto") == MATCH_YES)
c->sched_kind = OMP_SCHED_AUTO;
if (c->sched_kind != OMP_SCHED_NONE)
{
match m = MATCH_NO;
if (c->sched_kind != OMP_SCHED_RUNTIME
&& c->sched_kind != OMP_SCHED_AUTO)
m = gfc_match (" , %e )", &c->chunk_size);
if (m != MATCH_YES)
m = gfc_match_char (')');
if (m != MATCH_YES)
c->sched_kind = OMP_SCHED_NONE;
}
if (c->sched_kind != OMP_SCHED_NONE)
continue;
else
gfc_current_locus = old_loc;
}
if ((mask & OMP_CLAUSE_ORDERED) && !c->ordered
&& gfc_match ("ordered") == MATCH_YES)
{
c->ordered = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_UNTIED) && !c->untied
&& gfc_match ("untied") == MATCH_YES)
{
c->untied = needs_space = true;
continue;
}
if ((mask & OMP_CLAUSE_COLLAPSE) && !c->collapse)
{
gfc_expr *cexpr = NULL;
match m = gfc_match ("collapse ( %e )", &cexpr);
if (m == MATCH_YES)
{
int collapse;
const char *p = gfc_extract_int (cexpr, &collapse);
if (p)
{
gfc_error_now (p);
collapse = 1;
}
else if (collapse <= 0)
{
gfc_error_now ("COLLAPSE clause argument not"
" constant positive integer at %C");
collapse = 1;
}
c->collapse = collapse;
gfc_free_expr (cexpr);
continue;
}
}
break;
}
if (gfc_match_omp_eos () != MATCH_YES)
{
gfc_free_omp_clauses (c);
return MATCH_ERROR;
}
*cp = c;
return MATCH_YES;
}