void
gfc_add_include_path (const char *path)
{
gfc_directorylist *dir;
const char *p;
p = path;
while (*p == ' ' || *p == '\t') /* someone might do 'gfortran "-I include"' */
if (*p++ == '\0')
return;
dir = include_dirs;
if (!dir)
{
dir = include_dirs = gfc_getmem (sizeof (gfc_directorylist));
}
else
{
while (dir->next)
dir = dir->next;
dir->next = gfc_getmem (sizeof (gfc_directorylist));
dir = dir->next;
}
dir->next = NULL;
dir->path = gfc_getmem (strlen (p) + 2);
strcpy (dir->path, p);
strcat (dir->path, "/"); /* make '/' last character */
}
tree
gfc_conv_string_init (tree length, gfc_expr * expr)
{
char *s;
HOST_WIDE_INT len;
int slen;
tree str;
gcc_assert (expr->expr_type == EXPR_CONSTANT);
gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
gcc_assert (INTEGER_CST_P (length));
gcc_assert (TREE_INT_CST_HIGH (length) == 0);
len = TREE_INT_CST_LOW (length);
slen = expr->value.character.length;
if (len > slen)
{
s = gfc_getmem (len);
memcpy (s, expr->value.character.string, slen);
memset (&s[slen], ' ', len - slen);
str = gfc_build_string_const (len, s);
gfc_free (s);
}
else
str = gfc_build_string_const (len, expr->value.character.string);
return str;
}
gfc_code *
gfc_get_code (void)
{
gfc_code *c;
c = gfc_getmem (sizeof (gfc_code));
c->loc = gfc_current_locus;
return c;
}
void
gfc_get_backend_locus (locus * loc)
{
loc->lb = gfc_getmem (sizeof (gfc_linebuf));
#ifdef USE_MAPPED_LOCATION
loc->lb->location = input_location;
#else
loc->lb->linenum = input_line;
#endif
loc->lb->file = gfc_current_backend_file;
}
static void
copy_equiv_list_to_ns (segment_info *c)
{
segment_info *f;
gfc_equiv_info *s;
gfc_equiv_list *l;
l = (gfc_equiv_list *) gfc_getmem (sizeof (gfc_equiv_list));
l->next = c->sym->ns->equiv_lists;
c->sym->ns->equiv_lists = l;
for (f = c; f; f = f->next)
{
s = (gfc_equiv_info *) gfc_getmem (sizeof (gfc_equiv_info));
s->next = l->equiv;
l->equiv = s;
s->sym = f->sym;
s->offset = f->offset;
s->length = f->length;
}
}
static void
gfc_handle_module_path_options (const char *arg)
{
if (gfc_option.module_dir != NULL)
gfc_fatal_error ("gfortran: Only one -J option allowed");
gfc_option.module_dir = (char *) gfc_getmem (strlen (arg) + 2);
strcpy (gfc_option.module_dir, arg);
strcat (gfc_option.module_dir, "/");
gfc_add_include_path (gfc_option.module_dir, true, false);
}
static gfc_file *
get_file (char *name, enum lc_reason reason ATTRIBUTE_UNUSED)
{
gfc_file *f;
f = gfc_getmem (sizeof (gfc_file));
f->filename = gfc_getmem (strlen (name) + 1);
strcpy (f->filename, name);
f->next = file_head;
file_head = f;
f->included_by = current_file;
if (current_file != NULL)
f->inclusion_line = current_file->line;
#ifdef USE_MAPPED_LOCATION
linemap_add (&line_table, reason, false, f->filename, 1);
#endif
return f;
}
int
gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{
if (result->ts.cl && result->ts.cl->length)
result->value.character.length =
(int)mpz_get_ui (result->ts.cl->length->value.integer);
gcc_assert (buffer_size >= size_character (result->value.character.length));
result->value.character.string =
gfc_getmem (result->value.character.length + 1);
memcpy (result->value.character.string, buffer,
result->value.character.length);
result->value.character.string [result->value.character.length] = '\0';
return result->value.character.length;
}
static segment_info *
get_segment_info (gfc_symbol * sym, HOST_WIDE_INT offset)
{
segment_info *s;
/* Make sure we've got the character length. */
if (sym->ts.type == BT_CHARACTER)
gfc_conv_const_charlen (sym->ts.u.cl);
/* Create the segment_info and fill it in. */
s = (segment_info *) gfc_getmem (sizeof (segment_info));
s->sym = sym;
/* We will use this type when building the segment aggregate type. */
s->field = gfc_sym_type (sym);
s->length = int_size_in_bytes (s->field);
s->offset = offset;
return s;
}
static void
preprocessor_line (char *c)
{
bool flag[5];
int i, line;
char *filename;
gfc_file *f;
int escaped;
c++;
while (*c == ' ' || *c == '\t')
c++;
if (*c < '0' || *c > '9')
goto bad_cpp_line;
line = atoi (c);
c = strchr (c, ' ');
if (c == NULL)
{
/* No file name given. Set new line number. */
current_file->line = line;
return;
}
/* Skip spaces. */
while (*c == ' ' || *c == '\t')
c++;
/* Skip quote. */
if (*c != '"')
goto bad_cpp_line;
++c;
filename = c;
/* Make filename end at quote. */
escaped = false;
while (*c && ! (! escaped && *c == '"'))
{
if (escaped)
escaped = false;
else
escaped = *c == '\\';
++c;
}
if (! *c)
/* Preprocessor line has no closing quote. */
goto bad_cpp_line;
*c++ = '\0';
/* Get flags. */
flag[1] = flag[2] = flag[3] = flag[4] = false;
for (;;)
{
c = strchr (c, ' ');
if (c == NULL)
break;
c++;
i = atoi (c);
if (1 <= i && i <= 4)
flag[i] = true;
}
/* Interpret flags. */
if (flag[1]) /* Starting new file. */
{
f = get_file (filename, LC_RENAME);
f->up = current_file;
current_file = f;
}
if (flag[2]) /* Ending current file. */
{
if (!current_file->up
|| strcmp (current_file->up->filename, filename) != 0)
{
gfc_warning_now ("%s:%d: file %s left but not entered",
current_file->filename, current_file->line,
filename);
return;
}
current_file = current_file->up;
}
/* The name of the file can be a temporary file produced by
cpp. Replace the name if it is different. */
if (strcmp (current_file->filename, filename) != 0)
{
gfc_free (current_file->filename);
current_file->filename = gfc_getmem (strlen (filename) + 1);
strcpy (current_file->filename, filename);
}
/* Set new line number. */
current_file->line = line;
return;
bad_cpp_line:
gfc_warning_now ("%s:%d: Illegal preprocessor directive",
current_file->filename, current_file->line);
current_file->line++;
}
static int
load_line (FILE * input, char **pbuf, int *pbuflen)
{
int c, maxlen, i, preprocessor_flag, buflen = *pbuflen;
int trunc_flag = 0;
char *buffer;
/* Determine the maximum allowed line length. */
if (gfc_current_form == FORM_FREE)
maxlen = GFC_MAX_LINE;
else
maxlen = gfc_option.fixed_line_length;
if (*pbuf == NULL)
{
/* Allocate the line buffer, storing its length into buflen. */
if (maxlen > 0)
buflen = maxlen;
else
buflen = GFC_MAX_LINE;
*pbuf = gfc_getmem (buflen + 1);
}
i = 0;
buffer = *pbuf;
preprocessor_flag = 0;
c = fgetc (input);
if (c == '#')
/* In order to not truncate preprocessor lines, we have to
remember that this is one. */
preprocessor_flag = 1;
ungetc (c, input);
for (;;)
{
c = fgetc (input);
if (c == EOF)
break;
if (c == '\n')
break;
if (c == '\r')
continue; /* Gobble characters. */
if (c == '\0')
continue;
if (c == '\032')
{
/* Ctrl-Z ends the file. */
while (fgetc (input) != EOF);
break;
}
if (gfc_current_form == FORM_FIXED && c == '\t' && i <= 6)
{ /* Tab expansion. */
while (i <= 6)
{
*buffer++ = ' ';
i++;
}
continue;
}
*buffer++ = c;
i++;
if (maxlen == 0 || preprocessor_flag)
{
if (i >= buflen)
{
/* Reallocate line buffer to double size to hold the
overlong line. */
buflen = buflen * 2;
*pbuf = xrealloc (*pbuf, buflen + 1);
buffer = (*pbuf)+i;
}
}
else if (i >= maxlen)
{
/* Truncate the rest of the line. */
for (;;)
{
c = fgetc (input);
if (c == '\n' || c == EOF)
break;
trunc_flag = 1;
}
ungetc ('\n', input);
}
}
/* Pad lines to the selected line length in fixed form. */
if (gfc_current_form == FORM_FIXED
&& gfc_option.fixed_line_length > 0
&& !preprocessor_flag
&& c != EOF)
while (i++ < gfc_option.fixed_line_length)
*buffer++ = ' ';
*buffer = '\0';
*pbuflen = buflen;
return trunc_flag;
}
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 tree
get_init_field (segment_info *head, tree union_type, tree *field_init,
record_layout_info rli)
{
segment_info *s;
HOST_WIDE_INT length = 0;
HOST_WIDE_INT offset = 0;
unsigned HOST_WIDE_INT known_align, desired_align;
bool overlap = false;
tree tmp, field;
tree init;
unsigned char *data, *chk;
VEC(constructor_elt,gc) *v = NULL;
tree type = unsigned_char_type_node;
int i;
/* Obtain the size of the union and check if there are any overlapping
initializers. */
for (s = head; s; s = s->next)
{
HOST_WIDE_INT slen = s->offset + s->length;
if (s->sym->value)
{
if (s->offset < offset)
overlap = true;
offset = slen;
}
length = length < slen ? slen : length;
}
if (!overlap)
return NULL_TREE;
/* Now absorb all the initializer data into a single vector,
whilst checking for overlapping, unequal values. */
data = (unsigned char*)gfc_getmem ((size_t)length);
chk = (unsigned char*)gfc_getmem ((size_t)length);
/* TODO - change this when default initialization is implemented. */
memset (data, '\0', (size_t)length);
memset (chk, '\0', (size_t)length);
for (s = head; s; s = s->next)
if (s->sym->value)
gfc_merge_initializers (s->sym->ts, s->sym->value,
&data[s->offset],
&chk[s->offset],
(size_t)s->length);
for (i = 0; i < length; i++)
CONSTRUCTOR_APPEND_ELT (v, NULL, build_int_cst (type, data[i]));
gfc_free (data);
gfc_free (chk);
/* Build a char[length] array to hold the initializers. Much of what
follows is borrowed from build_field, above. */
tmp = build_int_cst (gfc_array_index_type, length - 1);
tmp = build_range_type (gfc_array_index_type,
gfc_index_zero_node, tmp);
tmp = build_array_type (type, tmp);
field = build_decl (gfc_current_locus.lb->location,
FIELD_DECL, NULL_TREE, tmp);
known_align = BIGGEST_ALIGNMENT;
desired_align = update_alignment_for_field (rli, field, known_align);
if (desired_align > known_align)
DECL_PACKED (field) = 1;
DECL_FIELD_CONTEXT (field) = union_type;
DECL_FIELD_OFFSET (field) = size_int (0);
DECL_FIELD_BIT_OFFSET (field) = bitsize_zero_node;
SET_DECL_OFFSET_ALIGN (field, known_align);
rli->offset = size_binop (MAX_EXPR, rli->offset,
size_binop (PLUS_EXPR,
DECL_FIELD_OFFSET (field),
DECL_SIZE_UNIT (field)));
init = build_constructor (TREE_TYPE (field), v);
TREE_CONSTANT (init) = 1;
*field_init = init;
for (s = head; s; s = s->next)
{
if (s->sym->value == NULL)
continue;
gfc_free_expr (s->sym->value);
s->sym->value = NULL;
}
return field;
}
tree
gfc_conv_mpfr_to_tree (mpfr_t f, int kind)
{
tree res;
tree type;
mp_exp_t exp;
char *p;
char *q;
int n;
int edigits;
for (n = 0; gfc_real_kinds[n].kind != 0; n++)
{
if (gfc_real_kinds[n].kind == kind)
break;
}
gcc_assert (gfc_real_kinds[n].kind);
n = MAX (abs (gfc_real_kinds[n].min_exponent),
abs (gfc_real_kinds[n].max_exponent));
edigits = 1;
while (n > 0)
{
n = n / 10;
edigits += 3;
}
if (kind == gfc_default_double_kind)
p = mpfr_get_str (NULL, &exp, 10, 17, f, GFC_RND_MODE);
else
p = mpfr_get_str (NULL, &exp, 10, 8, f, GFC_RND_MODE);
/* We also have one minus sign, "e", "." and a null terminator. */
q = (char *) gfc_getmem (strlen (p) + edigits + 4);
if (p[0])
{
if (p[0] == '-')
{
strcpy (&q[2], &p[1]);
q[0] = '-';
q[1] = '.';
}
else
{
strcpy (&q[1], p);
q[0] = '.';
}
strcat (q, "e");
sprintf (&q[strlen (q)], "%d", (int) exp);
}
else
{
strcpy (q, "0");
}
type = gfc_get_real_type (kind);
res = build_real (type, REAL_VALUE_ATOF (q, TYPE_MODE (type)));
gfc_free (q);
gfc_free (p);
return res;
}
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;
}
/* Read a binary buffer to a constant expression. */
int
gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
gfc_expr *result)
{
if (result->expr_type == EXPR_ARRAY)
return interpret_array (buffer, buffer_size, result);
switch (result->ts.type)
{
case BT_INTEGER:
result->representation.length =
gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
result->value.integer);
break;
case BT_REAL:
result->representation.length =
gfc_interpret_float (result->ts.kind, buffer, buffer_size,
result->value.real);
break;
case BT_COMPLEX:
result->representation.length =
gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
#ifdef HAVE_mpc
result->value.complex
#else
result->value.complex.r,
result->value.complex.i
#endif
);
break;
case BT_LOGICAL:
result->representation.length =
gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
&result->value.logical);
break;
case BT_CHARACTER:
result->representation.length =
gfc_interpret_character (buffer, buffer_size, result);
break;
case BT_DERIVED:
result->representation.length =
gfc_interpret_derived (buffer, buffer_size, result);
break;
default:
gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
break;
}
if (result->ts.type == BT_CHARACTER)
result->representation.string
= gfc_widechar_to_char (result->value.character.string,
result->value.character.length);
else
{
result->representation.string =
(char *) gfc_getmem (result->representation.length + 1);
memcpy (result->representation.string, buffer,
result->representation.length);
result->representation.string[result->representation.length] = '\0';
}
return result->representation.length;
}
static int
count_types_test (gfc_formal_arglist * f1, gfc_formal_arglist * f2)
{
int rc, ac1, ac2, i, j, k, n1;
gfc_formal_arglist *f;
typedef struct
{
int flag;
gfc_symbol *sym;
}
arginfo;
arginfo *arg;
n1 = 0;
for (f = f1; f; f = f->next)
n1++;
/* Build an array of integers that gives the same integer to
arguments of the same type/rank. */
arg = gfc_getmem (n1 * sizeof (arginfo));
f = f1;
for (i = 0; i < n1; i++, f = f->next)
{
arg[i].flag = -1;
arg[i].sym = f->sym;
}
k = 0;
for (i = 0; i < n1; i++)
{
if (arg[i].flag != -1)
continue;
if (arg[i].sym->attr.optional)
continue; /* Skip optional arguments */
arg[i].flag = k;
/* Find other nonoptional arguments of the same type/rank. */
for (j = i + 1; j < n1; j++)
if (!arg[j].sym->attr.optional
&& compare_type_rank_if (arg[i].sym, arg[j].sym))
arg[j].flag = k;
k++;
}
/* Now loop over each distinct type found in f1. */
k = 0;
rc = 0;
for (i = 0; i < n1; i++)
{
if (arg[i].flag != k)
continue;
ac1 = 1;
for (j = i + 1; j < n1; j++)
if (arg[j].flag == k)
ac1++;
/* Count the number of arguments in f2 with that type, including
those that are optional. */
ac2 = 0;
for (f = f2; f; f = f->next)
if (compare_type_rank_if (arg[i].sym, f->sym))
ac2++;
if (ac1 > ac2)
{
rc = 1;
break;
}
k++;
}
gfc_free (arg);
return rc;
}