bool
gfc_convert_boz (gfc_expr *expr, gfc_typespec *ts)
{
size_t buffer_size, boz_bit_size, ts_bit_size;
int index;
unsigned char *buffer;
if (!expr->is_boz)
return true;
gcc_assert (expr->expr_type == EXPR_CONSTANT
&& expr->ts.type == BT_INTEGER);
/* Don't convert BOZ to logical, character, derived etc. */
if (ts->type == BT_REAL)
{
buffer_size = size_float (ts->kind);
ts_bit_size = buffer_size * 8;
}
else if (ts->type == BT_COMPLEX)
{
buffer_size = size_complex (ts->kind);
ts_bit_size = buffer_size * 8 / 2;
}
else
return true;
/* Convert BOZ to the smallest possible integer kind. */
boz_bit_size = mpz_sizeinbase (expr->value.integer, 2);
if (boz_bit_size > ts_bit_size)
{
gfc_error_now ("BOZ constant at %L is too large (%ld vs %ld bits)",
&expr->where, (long) boz_bit_size, (long) ts_bit_size);
return false;
}
for (index = 0; gfc_integer_kinds[index].kind != 0; ++index)
if ((unsigned) gfc_integer_kinds[index].bit_size >= ts_bit_size)
break;
expr->ts.kind = gfc_integer_kinds[index].kind;
buffer_size = MAX (buffer_size, size_integer (expr->ts.kind));
buffer = (unsigned char*)alloca (buffer_size);
encode_integer (expr->ts.kind, expr->value.integer, buffer, buffer_size);
mpz_clear (expr->value.integer);
if (ts->type == BT_REAL)
{
mpfr_init (expr->value.real);
gfc_interpret_float (ts->kind, buffer, buffer_size, expr->value.real);
}
else
{
#ifdef HAVE_mpc
mpc_init2 (expr->value.complex, mpfr_get_default_prec());
#else
mpfr_init (expr->value.complex.r);
mpfr_init (expr->value.complex.i);
#endif
gfc_interpret_complex (ts->kind, buffer, buffer_size,
#ifdef HAVE_mpc
expr->value.complex
#else
expr->value.complex.r, expr->value.complex.i
#endif
);
}
expr->is_boz = 0;
expr->ts.type = ts->type;
expr->ts.kind = ts->kind;
return true;
}
match
gfc_match_omp_threadprivate (void)
{
locus old_loc;
char n[GFC_MAX_SYMBOL_LEN+1];
gfc_symbol *sym;
match m;
gfc_symtree *st;
old_loc = gfc_current_locus;
m = gfc_match (" (");
if (m != MATCH_YES)
return m;
for (;;)
{
m = gfc_match_symbol (&sym, 0);
switch (m)
{
case MATCH_YES:
if (sym->attr.in_common)
gfc_error_now ("Threadprivate variable at %C is an element of "
"a COMMON block");
else if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE)
goto cleanup;
goto next_item;
case MATCH_NO:
break;
case MATCH_ERROR:
goto cleanup;
}
m = gfc_match (" / %n /", n);
if (m == MATCH_ERROR)
goto cleanup;
if (m == MATCH_NO || n[0] == '\0')
goto syntax;
st = gfc_find_symtree (gfc_current_ns->common_root, n);
if (st == NULL)
{
gfc_error ("COMMON block /%s/ not found at %C", n);
goto cleanup;
}
st->n.common->threadprivate = 1;
for (sym = st->n.common->head; sym; sym = sym->common_next)
if (gfc_add_threadprivate (&sym->attr, sym->name,
&sym->declared_at) == FAILURE)
goto cleanup;
next_item:
if (gfc_match_char (')') == MATCH_YES)
break;
if (gfc_match_char (',') != MATCH_YES)
goto syntax;
}
return MATCH_YES;
syntax:
gfc_error ("Syntax error in !$OMP THREADPRIVATE list at %C");
cleanup:
gfc_current_locus = old_loc;
return MATCH_ERROR;
}
load_file (char *filename, bool initial)
{
char *line;
gfc_linebuf *b;
gfc_file *f;
FILE *input;
int len, line_len;
for (f = current_file; f; f = f->up)
if (strcmp (filename, f->filename) == 0)
{
gfc_error_now ("File '%s' is being included recursively", filename);
return FAILURE;
}
if (initial)
{
input = gfc_open_file (filename);
if (input == NULL)
{
gfc_error_now ("Can't open file '%s'", filename);
return FAILURE;
}
}
else
{
input = gfc_open_included_file (filename, false);
if (input == NULL)
{
gfc_error_now ("Can't open included file '%s'", filename);
return FAILURE;
}
}
/* Load the file. */
f = get_file (filename, initial ? LC_RENAME : LC_ENTER);
f->up = current_file;
current_file = f;
current_file->line = 1;
line = NULL;
line_len = 0;
for (;;)
{
int trunc = load_line (input, &line, &line_len);
len = strlen (line);
if (feof (input) && len == 0)
break;
/* There are three things this line can be: a line of Fortran
source, an include line or a C preprocessor directive. */
if (line[0] == '#')
{
preprocessor_line (line);
continue;
}
if (include_line (line))
{
current_file->line++;
continue;
}
/* Add line. */
b = gfc_getmem (gfc_linebuf_header_size + len + 1);
#ifdef USE_MAPPED_LOCATION
b->location
= linemap_line_start (&line_table, current_file->line++, 120);
#else
b->linenum = current_file->line++;
#endif
b->file = current_file;
b->truncated = trunc;
strcpy (b->line, line);
if (line_head == NULL)
line_head = b;
else
line_tail->next = b;
line_tail = b;
}
/* Release the line buffer allocated in load_line. */
gfc_free (line);
fclose (input);
current_file = current_file->up;
#ifdef USE_MAPPED_LOCATION
linemap_add (&line_table, LC_LEAVE, 0, NULL, 0);
#endif
return SUCCESS;
}
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;
}
