static mpz_t *
get_mpz (gfc_expr *e)
{
if (e->expr_type != EXPR_CONSTANT)
gfc_internal_error ("get_mpz(): Not an integer constant");
return &e->value.integer;
}
const char *
gfc_typename (gfc_typespec *ts)
{
static char buffer1[GFC_MAX_SYMBOL_LEN + 7]; /* 7 for "TYPE()" + '\0'. */
static char buffer2[GFC_MAX_SYMBOL_LEN + 7];
static int flag = 0;
char *buffer;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
switch (ts->type)
{
case BT_INTEGER:
sprintf (buffer, "INTEGER(%d)", ts->kind);
break;
case BT_REAL:
sprintf (buffer, "REAL(%d)", ts->kind);
break;
case BT_COMPLEX:
sprintf (buffer, "COMPLEX(%d)", ts->kind);
break;
case BT_LOGICAL:
sprintf (buffer, "LOGICAL(%d)", ts->kind);
break;
case BT_CHARACTER:
sprintf (buffer, "CHARACTER(%d)", ts->kind);
break;
case BT_HOLLERITH:
sprintf (buffer, "HOLLERITH");
break;
case BT_DERIVED:
sprintf (buffer, "TYPE(%s)", ts->u.derived->name);
break;
case BT_CLASS:
ts = &ts->u.derived->components->ts;
if (ts->u.derived->attr.unlimited_polymorphic)
sprintf (buffer, "CLASS(*)");
else
sprintf (buffer, "CLASS(%s)", ts->u.derived->name);
break;
case BT_ASSUMED:
sprintf (buffer, "TYPE(*)");
break;
case BT_PROCEDURE:
strcpy (buffer, "PROCEDURE");
break;
case BT_UNKNOWN:
strcpy (buffer, "UNKNOWN");
break;
default:
gfc_internal_error ("gfc_typename(): Undefined type");
}
return buffer;
}
const char *
gfc_code2string (const mstring *m, int code)
{
while (m->string != NULL)
{
if (m->tag == code)
return m->string;
m++;
}
gfc_internal_error ("gfc_code2string(): Bad code");
/* Not reached */
}
const char *
gfc_basic_typename (bt type)
{
const char *p;
switch (type)
{
case BT_INTEGER:
p = "INTEGER";
break;
case BT_REAL:
p = "REAL";
break;
case BT_COMPLEX:
p = "COMPLEX";
break;
case BT_LOGICAL:
p = "LOGICAL";
break;
case BT_CHARACTER:
p = "CHARACTER";
break;
case BT_HOLLERITH:
p = "HOLLERITH";
break;
case BT_DERIVED:
p = "DERIVED";
break;
case BT_CLASS:
p = "CLASS";
break;
case BT_PROCEDURE:
p = "PROCEDURE";
break;
case BT_VOID:
p = "VOID";
break;
case BT_UNKNOWN:
p = "UNKNOWN";
break;
case BT_ASSUMED:
p = "TYPE(*)";
break;
default:
gfc_internal_error ("gfc_basic_typename(): Undefined type");
}
return p;
}
const char *
gfc_typename (gfc_typespec * ts)
{
static char buffer1[60], buffer2[60];
static int flag = 0;
char *buffer;
buffer = flag ? buffer1 : buffer2;
flag = !flag;
switch (ts->type)
{
case BT_INTEGER:
sprintf (buffer, "INTEGER(%d)", ts->kind);
break;
case BT_REAL:
sprintf (buffer, "REAL(%d)", ts->kind);
break;
case BT_COMPLEX:
sprintf (buffer, "COMPLEX(%d)", ts->kind);
break;
case BT_LOGICAL:
sprintf (buffer, "LOGICAL(%d)", ts->kind);
break;
case BT_CHARACTER:
sprintf (buffer, "CHARACTER(%d)", ts->kind);
break;
case BT_HOLLERITH:
sprintf (buffer, "HOLLERITH");
break;
case BT_DERIVED:
sprintf (buffer, "TYPE(%s)", ts->derived->name);
break;
case BT_PROCEDURE:
strcpy (buffer, "PROCEDURE");
break;
case BT_UNKNOWN:
strcpy (buffer, "UNKNOWN");
break;
default:
gfc_internal_error ("gfc_typespec(): Undefined type");
}
return buffer;
}
void
gfc_get_section_index (gfc_array_ref *ar, mpz_t *section_index, mpz_t *offset)
{
int i;
mpz_t delta;
mpz_t tmp;
mpz_set_si (*offset, 0);
mpz_init (tmp);
mpz_init_set_si (delta, 1);
for (i = 0; i < ar->dimen; i++)
{
mpz_init (section_index[i]);
switch (ar->dimen_type[i])
{
case DIMEN_ELEMENT:
case DIMEN_RANGE:
if (ar->start[i])
{
mpz_sub (tmp, ar->start[i]->value.integer,
ar->as->lower[i]->value.integer);
mpz_mul (tmp, tmp, delta);
mpz_add (*offset, tmp, *offset);
mpz_set (section_index[i], ar->start[i]->value.integer);
}
else
mpz_set (section_index[i], ar->as->lower[i]->value.integer);
break;
case DIMEN_VECTOR:
gfc_internal_error ("TODO: Vector sections in data statements");
default:
gcc_unreachable ();
}
mpz_sub (tmp, ar->as->upper[i]->value.integer,
ar->as->lower[i]->value.integer);
mpz_add_ui (tmp, tmp, 1);
mpz_mul (delta, tmp, delta);
}
mpz_clear (tmp);
mpz_clear (delta);
}
static HOST_WIDE_INT
element_number (gfc_array_ref *ar)
{
mpz_t multiplier, offset, extent, n;
gfc_array_spec *as;
HOST_WIDE_INT i, rank;
as = ar->as;
rank = as->rank;
mpz_init_set_ui (multiplier, 1);
mpz_init_set_ui (offset, 0);
mpz_init (extent);
mpz_init (n);
for (i = 0; i < rank; i++)
{
if (ar->dimen_type[i] != DIMEN_ELEMENT)
gfc_internal_error ("element_number(): Bad dimension type");
mpz_sub (n, *get_mpz (ar->start[i]), *get_mpz (as->lower[i]));
mpz_mul (n, n, multiplier);
mpz_add (offset, offset, n);
mpz_sub (extent, *get_mpz (as->upper[i]), *get_mpz (as->lower[i]));
mpz_add_ui (extent, extent, 1);
if (mpz_sgn (extent) < 0)
mpz_set_ui (extent, 0);
mpz_mul (multiplier, multiplier, extent);
}
i = mpz_get_ui (offset);
mpz_clear (multiplier);
mpz_clear (offset);
mpz_clear (extent);
mpz_clear (n);
return i;
}
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 void
show_array_spec (gfc_array_spec *as)
{
const char *c;
int i;
if (as == NULL)
{
fputs ("()", dumpfile);
return;
}
fprintf (dumpfile, "(%d [%d]", as->rank, as->corank);
if (as->rank + as->corank > 0 || as->rank == -1)
{
switch (as->type)
{
case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
case AS_DEFERRED: c = "AS_DEFERRED"; break;
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
case AS_ASSUMED_RANK: c = "AS_ASSUMED_RANK"; break;
default:
gfc_internal_error ("show_array_spec(): Unhandled array shape "
"type.");
}
fprintf (dumpfile, " %s ", c);
for (i = 0; i < as->rank + as->corank; i++)
{
show_expr (as->lower[i]);
fputc (' ', dumpfile);
show_expr (as->upper[i]);
fputc (' ', dumpfile);
}
}
fputc (')', dumpfile);
}
static void
gfc_show_array_spec (gfc_array_spec * as)
{
const char *c;
int i;
if (as == NULL)
{
gfc_status ("()");
return;
}
gfc_status ("(%d", as->rank);
if (as->rank != 0)
{
switch (as->type)
{
case AS_EXPLICIT: c = "AS_EXPLICIT"; break;
case AS_DEFERRED: c = "AS_DEFERRED"; break;
case AS_ASSUMED_SIZE: c = "AS_ASSUMED_SIZE"; break;
case AS_ASSUMED_SHAPE: c = "AS_ASSUMED_SHAPE"; break;
default:
gfc_internal_error
("gfc_show_array_spec(): Unhandled array shape type.");
}
gfc_status (" %s ", c);
for (i = 0; i < as->rank; i++)
{
gfc_show_expr (as->lower[i]);
gfc_status_char (' ');
gfc_show_expr (as->upper[i]);
gfc_status_char (' ');
}
}
gfc_status (")");
}
void
gfc_show_expr (gfc_expr * p)
{
const char *c;
int i;
if (p == NULL)
{
gfc_status ("()");
return;
}
switch (p->expr_type)
{
case EXPR_SUBSTRING:
c = p->value.character.string;
for (i = 0; i < p->value.character.length; i++, c++)
{
if (*c == '\'')
gfc_status ("''");
else
gfc_status ("%c", *c);
}
gfc_show_ref (p->ref);
break;
case EXPR_STRUCTURE:
gfc_status ("%s(", p->ts.derived->name);
gfc_show_constructor (p->value.constructor);
gfc_status_char (')');
break;
case EXPR_ARRAY:
gfc_status ("(/ ");
gfc_show_constructor (p->value.constructor);
gfc_status (" /)");
gfc_show_ref (p->ref);
break;
case EXPR_NULL:
gfc_status ("NULL()");
break;
case EXPR_CONSTANT:
if (p->from_H || p->ts.type == BT_HOLLERITH)
{
gfc_status ("%dH", p->value.character.length);
c = p->value.character.string;
for (i = 0; i < p->value.character.length; i++, c++)
{
gfc_status_char (*c);
}
break;
}
switch (p->ts.type)
{
case BT_INTEGER:
mpz_out_str (stdout, 10, p->value.integer);
if (p->ts.kind != gfc_default_integer_kind)
gfc_status ("_%d", p->ts.kind);
break;
case BT_LOGICAL:
if (p->value.logical)
gfc_status (".true.");
else
gfc_status (".false.");
break;
case BT_REAL:
mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
if (p->ts.kind != gfc_default_real_kind)
gfc_status ("_%d", p->ts.kind);
break;
case BT_CHARACTER:
c = p->value.character.string;
gfc_status_char ('\'');
for (i = 0; i < p->value.character.length; i++, c++)
{
if (*c == '\'')
gfc_status ("''");
else
gfc_status_char (*c);
}
gfc_status_char ('\'');
break;
case BT_COMPLEX:
gfc_status ("(complex ");
mpfr_out_str (stdout, 10, 0, p->value.complex.r, GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind)
gfc_status ("_%d", p->ts.kind);
gfc_status (" ");
mpfr_out_str (stdout, 10, 0, p->value.complex.i, GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind)
gfc_status ("_%d", p->ts.kind);
gfc_status (")");
break;
default:
gfc_status ("???");
break;
}
break;
case EXPR_VARIABLE:
if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
gfc_status ("%s:", p->symtree->n.sym->ns->proc_name->name);
gfc_status ("%s", p->symtree->n.sym->name);
gfc_show_ref (p->ref);
break;
case EXPR_OP:
gfc_status ("(");
switch (p->value.op.operator)
{
case INTRINSIC_UPLUS:
gfc_status ("U+ ");
break;
case INTRINSIC_UMINUS:
gfc_status ("U- ");
break;
case INTRINSIC_PLUS:
gfc_status ("+ ");
break;
case INTRINSIC_MINUS:
gfc_status ("- ");
break;
case INTRINSIC_TIMES:
gfc_status ("* ");
break;
case INTRINSIC_DIVIDE:
gfc_status ("/ ");
break;
case INTRINSIC_POWER:
gfc_status ("** ");
break;
case INTRINSIC_CONCAT:
gfc_status ("// ");
break;
case INTRINSIC_AND:
gfc_status ("AND ");
break;
case INTRINSIC_OR:
gfc_status ("OR ");
break;
case INTRINSIC_EQV:
gfc_status ("EQV ");
break;
case INTRINSIC_NEQV:
gfc_status ("NEQV ");
break;
case INTRINSIC_EQ:
gfc_status ("= ");
break;
case INTRINSIC_NE:
gfc_status ("<> ");
break;
case INTRINSIC_GT:
gfc_status ("> ");
break;
case INTRINSIC_GE:
gfc_status (">= ");
break;
case INTRINSIC_LT:
gfc_status ("< ");
break;
case INTRINSIC_LE:
gfc_status ("<= ");
break;
case INTRINSIC_NOT:
gfc_status ("NOT ");
break;
case INTRINSIC_PARENTHESES:
gfc_status ("parens");
break;
default:
gfc_internal_error
("gfc_show_expr(): Bad intrinsic in expression!");
}
gfc_show_expr (p->value.op.op1);
if (p->value.op.op2)
{
gfc_status (" ");
gfc_show_expr (p->value.op.op2);
}
gfc_status (")");
break;
case EXPR_FUNCTION:
if (p->value.function.name == NULL)
{
gfc_status ("%s[", p->symtree->n.sym->name);
gfc_show_actual_arglist (p->value.function.actual);
gfc_status_char (']');
}
else
{
gfc_status ("%s[[", p->value.function.name);
gfc_show_actual_arglist (p->value.function.actual);
gfc_status_char (']');
gfc_status_char (']');
}
break;
default:
gfc_internal_error ("gfc_show_expr(): Don't know how to show expr");
}
}
/* 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 match
match_level_4 (gfc_expr **result)
{
gfc_expr *left, *right, *r;
gfc_intrinsic_op i;
locus old_loc;
locus where;
match m;
m = match_level_3 (&left);
if (m != MATCH_YES)
return m;
old_loc = gfc_current_locus;
if (gfc_match_intrinsic_op (&i) != MATCH_YES)
{
*result = left;
return MATCH_YES;
}
if (i != INTRINSIC_EQ && i != INTRINSIC_NE && i != INTRINSIC_GE
&& i != INTRINSIC_LE && i != INTRINSIC_LT && i != INTRINSIC_GT
&& i != INTRINSIC_EQ_OS && i != INTRINSIC_NE_OS && i != INTRINSIC_GE_OS
&& i != INTRINSIC_LE_OS && i != INTRINSIC_LT_OS && i != INTRINSIC_GT_OS)
{
gfc_current_locus = old_loc;
*result = left;
return MATCH_YES;
}
where = gfc_current_locus;
m = match_level_3 (&right);
if (m == MATCH_NO)
gfc_error (expression_syntax);
if (m != MATCH_YES)
{
gfc_free_expr (left);
return MATCH_ERROR;
}
switch (i)
{
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
r = gfc_eq (left, right, i);
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
r = gfc_ne (left, right, i);
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
r = gfc_lt (left, right, i);
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
r = gfc_le (left, right, i);
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
r = gfc_gt (left, right, i);
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
r = gfc_ge (left, right, i);
break;
default:
gfc_internal_error ("match_level_4(): Bad operator");
}
if (r == NULL)
{
gfc_free_expr (left);
gfc_free_expr (right);
return MATCH_ERROR;
}
r->where = where;
*result = r;
return MATCH_YES;
}
static void
show_expr (gfc_expr *p)
{
const char *c;
int i;
if (p == NULL)
{
fputs ("()", dumpfile);
return;
}
switch (p->expr_type)
{
case EXPR_SUBSTRING:
show_char_const (p->value.character.string, p->value.character.length);
show_ref (p->ref);
break;
case EXPR_STRUCTURE:
fprintf (dumpfile, "%s(", p->ts.u.derived->name);
show_constructor (p->value.constructor);
fputc (')', dumpfile);
break;
case EXPR_ARRAY:
fputs ("(/ ", dumpfile);
show_constructor (p->value.constructor);
fputs (" /)", dumpfile);
show_ref (p->ref);
break;
case EXPR_NULL:
fputs ("NULL()", dumpfile);
break;
case EXPR_CONSTANT:
switch (p->ts.type)
{
case BT_INTEGER:
mpz_out_str (stdout, 10, p->value.integer);
if (p->ts.kind != gfc_default_integer_kind)
fprintf (dumpfile, "_%d", p->ts.kind);
break;
case BT_LOGICAL:
if (p->value.logical)
fputs (".true.", dumpfile);
else
fputs (".false.", dumpfile);
break;
case BT_REAL:
mpfr_out_str (stdout, 10, 0, p->value.real, GFC_RND_MODE);
if (p->ts.kind != gfc_default_real_kind)
fprintf (dumpfile, "_%d", p->ts.kind);
break;
case BT_CHARACTER:
show_char_const (p->value.character.string,
p->value.character.length);
break;
case BT_COMPLEX:
fputs ("(complex ", dumpfile);
mpfr_out_str (stdout, 10, 0, mpc_realref (p->value.complex),
GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind)
fprintf (dumpfile, "_%d", p->ts.kind);
fputc (' ', dumpfile);
mpfr_out_str (stdout, 10, 0, mpc_imagref (p->value.complex),
GFC_RND_MODE);
if (p->ts.kind != gfc_default_complex_kind)
fprintf (dumpfile, "_%d", p->ts.kind);
fputc (')', dumpfile);
break;
case BT_HOLLERITH:
fprintf (dumpfile, "%dH", p->representation.length);
c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++)
{
fputc (*c, dumpfile);
}
break;
default:
fputs ("???", dumpfile);
break;
}
if (p->representation.string)
{
fputs (" {", dumpfile);
c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++)
{
fprintf (dumpfile, "%.2x", (unsigned int) *c);
if (i < p->representation.length - 1)
fputc (',', dumpfile);
}
fputc ('}', dumpfile);
}
break;
case EXPR_VARIABLE:
if (p->symtree->n.sym->ns && p->symtree->n.sym->ns->proc_name)
fprintf (dumpfile, "%s:", p->symtree->n.sym->ns->proc_name->name);
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
show_ref (p->ref);
break;
case EXPR_OP:
fputc ('(', dumpfile);
switch (p->value.op.op)
{
case INTRINSIC_UPLUS:
fputs ("U+ ", dumpfile);
break;
case INTRINSIC_UMINUS:
fputs ("U- ", dumpfile);
break;
case INTRINSIC_PLUS:
fputs ("+ ", dumpfile);
break;
case INTRINSIC_MINUS:
fputs ("- ", dumpfile);
break;
case INTRINSIC_TIMES:
fputs ("* ", dumpfile);
break;
case INTRINSIC_DIVIDE:
fputs ("/ ", dumpfile);
break;
case INTRINSIC_POWER:
fputs ("** ", dumpfile);
break;
case INTRINSIC_CONCAT:
fputs ("// ", dumpfile);
break;
case INTRINSIC_AND:
fputs ("AND ", dumpfile);
break;
case INTRINSIC_OR:
fputs ("OR ", dumpfile);
break;
case INTRINSIC_EQV:
fputs ("EQV ", dumpfile);
break;
case INTRINSIC_NEQV:
fputs ("NEQV ", dumpfile);
break;
case INTRINSIC_EQ:
case INTRINSIC_EQ_OS:
fputs ("= ", dumpfile);
break;
case INTRINSIC_NE:
case INTRINSIC_NE_OS:
fputs ("/= ", dumpfile);
break;
case INTRINSIC_GT:
case INTRINSIC_GT_OS:
fputs ("> ", dumpfile);
break;
case INTRINSIC_GE:
case INTRINSIC_GE_OS:
fputs (">= ", dumpfile);
break;
case INTRINSIC_LT:
case INTRINSIC_LT_OS:
fputs ("< ", dumpfile);
break;
case INTRINSIC_LE:
case INTRINSIC_LE_OS:
fputs ("<= ", dumpfile);
break;
case INTRINSIC_NOT:
fputs ("NOT ", dumpfile);
break;
case INTRINSIC_PARENTHESES:
fputs ("parens ", dumpfile);
break;
default:
gfc_internal_error
("show_expr(): Bad intrinsic in expression!");
}
show_expr (p->value.op.op1);
if (p->value.op.op2)
{
fputc (' ', dumpfile);
show_expr (p->value.op.op2);
}
fputc (')', dumpfile);
break;
case EXPR_FUNCTION:
if (p->value.function.name == NULL)
{
fprintf (dumpfile, "%s", p->symtree->n.sym->name);
if (gfc_is_proc_ptr_comp (p))
show_ref (p->ref);
fputc ('[', dumpfile);
show_actual_arglist (p->value.function.actual);
fputc (']', dumpfile);
}
else
{
fprintf (dumpfile, "%s", p->value.function.name);
if (gfc_is_proc_ptr_comp (p))
show_ref (p->ref);
fputc ('[', dumpfile);
fputc ('[', dumpfile);
show_actual_arglist (p->value.function.actual);
fputc (']', dumpfile);
fputc (']', dumpfile);
}
break;
case EXPR_COMPCALL:
show_compcall (p);
break;
default:
gfc_internal_error ("show_expr(): Don't know how to show expr");
}
}
static void
show_array_ref (gfc_array_ref * ar)
{
int i;
fputc ('(', dumpfile);
switch (ar->type)
{
case AR_FULL:
fputs ("FULL", dumpfile);
break;
case AR_SECTION:
for (i = 0; i < ar->dimen; i++)
{
/* There are two types of array sections: either the
elements are identified by an integer array ('vector'),
or by an index range. In the former case we only have to
print the start expression which contains the vector, in
the latter case we have to print any of lower and upper
bound and the stride, if they're present. */
if (ar->start[i] != NULL)
show_expr (ar->start[i]);
if (ar->dimen_type[i] == DIMEN_RANGE)
{
fputc (':', dumpfile);
if (ar->end[i] != NULL)
show_expr (ar->end[i]);
if (ar->stride[i] != NULL)
{
fputc (':', dumpfile);
show_expr (ar->stride[i]);
}
}
if (i != ar->dimen - 1)
fputs (" , ", dumpfile);
}
break;
case AR_ELEMENT:
for (i = 0; i < ar->dimen; i++)
{
show_expr (ar->start[i]);
if (i != ar->dimen - 1)
fputs (" , ", dumpfile);
}
break;
case AR_UNKNOWN:
fputs ("UNKNOWN", dumpfile);
break;
default:
gfc_internal_error ("show_array_ref(): Unknown array reference");
}
fputc (')', dumpfile);
}
static void
show_code_node (int level, gfc_code *c)
{
gfc_forall_iterator *fa;
gfc_open *open;
gfc_case *cp;
gfc_alloc *a;
gfc_code *d;
gfc_close *close;
gfc_filepos *fp;
gfc_inquire *i;
gfc_dt *dt;
gfc_namespace *ns;
if (c->here)
{
fputc ('\n', dumpfile);
code_indent (level, c->here);
}
else
show_indent ();
switch (c->op)
{
case EXEC_END_PROCEDURE:
break;
case EXEC_NOP:
fputs ("NOP", dumpfile);
break;
case EXEC_CONTINUE:
fputs ("CONTINUE", dumpfile);
break;
case EXEC_ENTRY:
fprintf (dumpfile, "ENTRY %s", c->ext.entry->sym->name);
break;
case EXEC_INIT_ASSIGN:
case EXEC_ASSIGN:
fputs ("ASSIGN ", dumpfile);
show_expr (c->expr1);
fputc (' ', dumpfile);
show_expr (c->expr2);
break;
case EXEC_LABEL_ASSIGN:
fputs ("LABEL ASSIGN ", dumpfile);
show_expr (c->expr1);
fprintf (dumpfile, " %d", c->label1->value);
break;
case EXEC_POINTER_ASSIGN:
fputs ("POINTER ASSIGN ", dumpfile);
show_expr (c->expr1);
fputc (' ', dumpfile);
show_expr (c->expr2);
break;
case EXEC_GOTO:
fputs ("GOTO ", dumpfile);
if (c->label1)
fprintf (dumpfile, "%d", c->label1->value);
else
{
show_expr (c->expr1);
d = c->block;
if (d != NULL)
{
fputs (", (", dumpfile);
for (; d; d = d ->block)
{
code_indent (level, d->label1);
if (d->block != NULL)
fputc (',', dumpfile);
else
fputc (')', dumpfile);
}
}
}
break;
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
if (c->resolved_sym)
fprintf (dumpfile, "CALL %s ", c->resolved_sym->name);
else if (c->symtree)
fprintf (dumpfile, "CALL %s ", c->symtree->name);
else
fputs ("CALL ?? ", dumpfile);
show_actual_arglist (c->ext.actual);
break;
case EXEC_COMPCALL:
fputs ("CALL ", dumpfile);
show_compcall (c->expr1);
break;
case EXEC_CALL_PPC:
fputs ("CALL ", dumpfile);
show_expr (c->expr1);
show_actual_arglist (c->ext.actual);
break;
case EXEC_RETURN:
fputs ("RETURN ", dumpfile);
if (c->expr1)
show_expr (c->expr1);
break;
case EXEC_PAUSE:
fputs ("PAUSE ", dumpfile);
if (c->expr1 != NULL)
show_expr (c->expr1);
else
fprintf (dumpfile, "%d", c->ext.stop_code);
break;
case EXEC_ERROR_STOP:
fputs ("ERROR ", dumpfile);
/* Fall through. */
case EXEC_STOP:
fputs ("STOP ", dumpfile);
if (c->expr1 != NULL)
show_expr (c->expr1);
else
fprintf (dumpfile, "%d", c->ext.stop_code);
break;
case EXEC_SYNC_ALL:
fputs ("SYNC ALL ", dumpfile);
if (c->expr2 != NULL)
{
fputs (" stat=", dumpfile);
show_expr (c->expr2);
}
if (c->expr3 != NULL)
{
fputs (" errmsg=", dumpfile);
show_expr (c->expr3);
}
break;
case EXEC_SYNC_MEMORY:
fputs ("SYNC MEMORY ", dumpfile);
if (c->expr2 != NULL)
{
fputs (" stat=", dumpfile);
show_expr (c->expr2);
}
if (c->expr3 != NULL)
{
fputs (" errmsg=", dumpfile);
show_expr (c->expr3);
}
break;
case EXEC_SYNC_IMAGES:
fputs ("SYNC IMAGES image-set=", dumpfile);
if (c->expr1 != NULL)
show_expr (c->expr1);
else
fputs ("* ", dumpfile);
if (c->expr2 != NULL)
{
fputs (" stat=", dumpfile);
show_expr (c->expr2);
}
if (c->expr3 != NULL)
{
fputs (" errmsg=", dumpfile);
show_expr (c->expr3);
}
break;
case EXEC_LOCK:
case EXEC_UNLOCK:
if (c->op == EXEC_LOCK)
fputs ("LOCK ", dumpfile);
else
fputs ("UNLOCK ", dumpfile);
fputs ("lock-variable=", dumpfile);
if (c->expr1 != NULL)
show_expr (c->expr1);
if (c->expr4 != NULL)
{
fputs (" acquired_lock=", dumpfile);
show_expr (c->expr4);
}
if (c->expr2 != NULL)
{
fputs (" stat=", dumpfile);
show_expr (c->expr2);
}
if (c->expr3 != NULL)
{
fputs (" errmsg=", dumpfile);
show_expr (c->expr3);
}
break;
case EXEC_ARITHMETIC_IF:
fputs ("IF ", dumpfile);
show_expr (c->expr1);
fprintf (dumpfile, " %d, %d, %d",
c->label1->value, c->label2->value, c->label3->value);
break;
case EXEC_IF:
d = c->block;
fputs ("IF ", dumpfile);
show_expr (d->expr1);
++show_level;
show_code (level + 1, d->next);
--show_level;
d = d->block;
for (; d; d = d->block)
{
code_indent (level, 0);
if (d->expr1 == NULL)
fputs ("ELSE", dumpfile);
else
{
fputs ("ELSE IF ", dumpfile);
show_expr (d->expr1);
}
++show_level;
show_code (level + 1, d->next);
--show_level;
}
if (c->label1)
code_indent (level, c->label1);
else
show_indent ();
fputs ("ENDIF", dumpfile);
break;
case EXEC_BLOCK:
{
const char* blocktype;
gfc_namespace *saved_ns;
if (c->ext.block.assoc)
blocktype = "ASSOCIATE";
else
blocktype = "BLOCK";
show_indent ();
fprintf (dumpfile, "%s ", blocktype);
++show_level;
ns = c->ext.block.ns;
saved_ns = gfc_current_ns;
gfc_current_ns = ns;
gfc_traverse_symtree (ns->sym_root, show_symtree);
gfc_current_ns = saved_ns;
show_code (show_level, ns->code);
--show_level;
show_indent ();
fprintf (dumpfile, "END %s ", blocktype);
break;
}
case EXEC_SELECT:
d = c->block;
fputs ("SELECT CASE ", dumpfile);
show_expr (c->expr1);
fputc ('\n', dumpfile);
for (; d; d = d->block)
{
code_indent (level, 0);
fputs ("CASE ", dumpfile);
for (cp = d->ext.block.case_list; cp; cp = cp->next)
{
fputc ('(', dumpfile);
show_expr (cp->low);
fputc (' ', dumpfile);
show_expr (cp->high);
fputc (')', dumpfile);
fputc (' ', dumpfile);
}
fputc ('\n', dumpfile);
show_code (level + 1, d->next);
}
code_indent (level, c->label1);
fputs ("END SELECT", dumpfile);
break;
case EXEC_WHERE:
fputs ("WHERE ", dumpfile);
d = c->block;
show_expr (d->expr1);
fputc ('\n', dumpfile);
show_code (level + 1, d->next);
for (d = d->block; d; d = d->block)
{
code_indent (level, 0);
fputs ("ELSE WHERE ", dumpfile);
show_expr (d->expr1);
fputc ('\n', dumpfile);
show_code (level + 1, d->next);
}
code_indent (level, 0);
fputs ("END WHERE", dumpfile);
break;
case EXEC_FORALL:
fputs ("FORALL ", dumpfile);
for (fa = c->ext.forall_iterator; fa; fa = fa->next)
{
show_expr (fa->var);
fputc (' ', dumpfile);
show_expr (fa->start);
fputc (':', dumpfile);
show_expr (fa->end);
fputc (':', dumpfile);
show_expr (fa->stride);
if (fa->next != NULL)
fputc (',', dumpfile);
}
if (c->expr1 != NULL)
{
fputc (',', dumpfile);
show_expr (c->expr1);
}
fputc ('\n', dumpfile);
show_code (level + 1, c->block->next);
code_indent (level, 0);
fputs ("END FORALL", dumpfile);
break;
case EXEC_CRITICAL:
fputs ("CRITICAL\n", dumpfile);
show_code (level + 1, c->block->next);
code_indent (level, 0);
fputs ("END CRITICAL", dumpfile);
break;
case EXEC_DO:
fputs ("DO ", dumpfile);
if (c->label1)
fprintf (dumpfile, " %-5d ", c->label1->value);
show_expr (c->ext.iterator->var);
fputc ('=', dumpfile);
show_expr (c->ext.iterator->start);
fputc (' ', dumpfile);
show_expr (c->ext.iterator->end);
fputc (' ', dumpfile);
show_expr (c->ext.iterator->step);
++show_level;
show_code (level + 1, c->block->next);
--show_level;
if (c->label1)
break;
show_indent ();
fputs ("END DO", dumpfile);
break;
case EXEC_DO_CONCURRENT:
fputs ("DO CONCURRENT ", dumpfile);
for (fa = c->ext.forall_iterator; fa; fa = fa->next)
{
show_expr (fa->var);
fputc (' ', dumpfile);
show_expr (fa->start);
fputc (':', dumpfile);
show_expr (fa->end);
fputc (':', dumpfile);
show_expr (fa->stride);
if (fa->next != NULL)
fputc (',', dumpfile);
}
show_expr (c->expr1);
show_code (level + 1, c->block->next);
code_indent (level, c->label1);
fputs ("END DO", dumpfile);
break;
case EXEC_DO_WHILE:
fputs ("DO WHILE ", dumpfile);
show_expr (c->expr1);
fputc ('\n', dumpfile);
show_code (level + 1, c->block->next);
code_indent (level, c->label1);
fputs ("END DO", dumpfile);
break;
case EXEC_CYCLE:
fputs ("CYCLE", dumpfile);
if (c->symtree)
fprintf (dumpfile, " %s", c->symtree->n.sym->name);
break;
case EXEC_EXIT:
fputs ("EXIT", dumpfile);
if (c->symtree)
fprintf (dumpfile, " %s", c->symtree->n.sym->name);
break;
case EXEC_ALLOCATE:
fputs ("ALLOCATE ", dumpfile);
if (c->expr1)
{
fputs (" STAT=", dumpfile);
show_expr (c->expr1);
}
if (c->expr2)
{
fputs (" ERRMSG=", dumpfile);
show_expr (c->expr2);
}
if (c->expr3)
{
if (c->expr3->mold)
fputs (" MOLD=", dumpfile);
else
fputs (" SOURCE=", dumpfile);
show_expr (c->expr3);
}
for (a = c->ext.alloc.list; a; a = a->next)
{
fputc (' ', dumpfile);
show_expr (a->expr);
}
break;
case EXEC_DEALLOCATE:
fputs ("DEALLOCATE ", dumpfile);
if (c->expr1)
{
fputs (" STAT=", dumpfile);
show_expr (c->expr1);
}
if (c->expr2)
{
fputs (" ERRMSG=", dumpfile);
show_expr (c->expr2);
}
for (a = c->ext.alloc.list; a; a = a->next)
{
fputc (' ', dumpfile);
show_expr (a->expr);
}
break;
case EXEC_OPEN:
fputs ("OPEN", dumpfile);
open = c->ext.open;
if (open->unit)
{
fputs (" UNIT=", dumpfile);
show_expr (open->unit);
}
if (open->iomsg)
{
fputs (" IOMSG=", dumpfile);
show_expr (open->iomsg);
}
if (open->iostat)
{
fputs (" IOSTAT=", dumpfile);
show_expr (open->iostat);
}
if (open->file)
{
fputs (" FILE=", dumpfile);
show_expr (open->file);
}
if (open->status)
{
fputs (" STATUS=", dumpfile);
show_expr (open->status);
}
if (open->access)
{
fputs (" ACCESS=", dumpfile);
show_expr (open->access);
}
if (open->form)
{
fputs (" FORM=", dumpfile);
show_expr (open->form);
}
if (open->recl)
{
fputs (" RECL=", dumpfile);
show_expr (open->recl);
}
if (open->blank)
{
fputs (" BLANK=", dumpfile);
show_expr (open->blank);
}
if (open->position)
{
fputs (" POSITION=", dumpfile);
show_expr (open->position);
}
if (open->action)
{
fputs (" ACTION=", dumpfile);
show_expr (open->action);
}
if (open->delim)
{
fputs (" DELIM=", dumpfile);
show_expr (open->delim);
}
if (open->pad)
{
fputs (" PAD=", dumpfile);
show_expr (open->pad);
}
if (open->decimal)
{
fputs (" DECIMAL=", dumpfile);
show_expr (open->decimal);
}
if (open->encoding)
{
fputs (" ENCODING=", dumpfile);
show_expr (open->encoding);
}
if (open->round)
{
fputs (" ROUND=", dumpfile);
show_expr (open->round);
}
if (open->sign)
{
fputs (" SIGN=", dumpfile);
show_expr (open->sign);
}
if (open->convert)
{
fputs (" CONVERT=", dumpfile);
show_expr (open->convert);
}
if (open->asynchronous)
{
fputs (" ASYNCHRONOUS=", dumpfile);
show_expr (open->asynchronous);
}
if (open->err != NULL)
fprintf (dumpfile, " ERR=%d", open->err->value);
break;
case EXEC_CLOSE:
fputs ("CLOSE", dumpfile);
close = c->ext.close;
if (close->unit)
{
fputs (" UNIT=", dumpfile);
show_expr (close->unit);
}
if (close->iomsg)
{
fputs (" IOMSG=", dumpfile);
show_expr (close->iomsg);
}
if (close->iostat)
{
fputs (" IOSTAT=", dumpfile);
show_expr (close->iostat);
}
if (close->status)
{
fputs (" STATUS=", dumpfile);
show_expr (close->status);
}
if (close->err != NULL)
fprintf (dumpfile, " ERR=%d", close->err->value);
break;
case EXEC_BACKSPACE:
fputs ("BACKSPACE", dumpfile);
goto show_filepos;
case EXEC_ENDFILE:
fputs ("ENDFILE", dumpfile);
goto show_filepos;
case EXEC_REWIND:
fputs ("REWIND", dumpfile);
goto show_filepos;
case EXEC_FLUSH:
fputs ("FLUSH", dumpfile);
show_filepos:
fp = c->ext.filepos;
if (fp->unit)
{
fputs (" UNIT=", dumpfile);
show_expr (fp->unit);
}
if (fp->iomsg)
{
fputs (" IOMSG=", dumpfile);
show_expr (fp->iomsg);
}
if (fp->iostat)
{
fputs (" IOSTAT=", dumpfile);
show_expr (fp->iostat);
}
if (fp->err != NULL)
fprintf (dumpfile, " ERR=%d", fp->err->value);
break;
case EXEC_INQUIRE:
fputs ("INQUIRE", dumpfile);
i = c->ext.inquire;
if (i->unit)
{
fputs (" UNIT=", dumpfile);
show_expr (i->unit);
}
if (i->file)
{
fputs (" FILE=", dumpfile);
show_expr (i->file);
}
if (i->iomsg)
{
fputs (" IOMSG=", dumpfile);
show_expr (i->iomsg);
}
if (i->iostat)
{
fputs (" IOSTAT=", dumpfile);
show_expr (i->iostat);
}
if (i->exist)
{
fputs (" EXIST=", dumpfile);
show_expr (i->exist);
}
if (i->opened)
{
fputs (" OPENED=", dumpfile);
show_expr (i->opened);
}
if (i->number)
{
fputs (" NUMBER=", dumpfile);
show_expr (i->number);
}
if (i->named)
{
fputs (" NAMED=", dumpfile);
show_expr (i->named);
}
if (i->name)
{
fputs (" NAME=", dumpfile);
show_expr (i->name);
}
if (i->access)
{
fputs (" ACCESS=", dumpfile);
show_expr (i->access);
}
if (i->sequential)
{
fputs (" SEQUENTIAL=", dumpfile);
show_expr (i->sequential);
}
if (i->direct)
{
fputs (" DIRECT=", dumpfile);
show_expr (i->direct);
}
if (i->form)
{
fputs (" FORM=", dumpfile);
show_expr (i->form);
}
if (i->formatted)
{
fputs (" FORMATTED", dumpfile);
show_expr (i->formatted);
}
if (i->unformatted)
{
fputs (" UNFORMATTED=", dumpfile);
show_expr (i->unformatted);
}
if (i->recl)
{
fputs (" RECL=", dumpfile);
show_expr (i->recl);
}
if (i->nextrec)
{
fputs (" NEXTREC=", dumpfile);
show_expr (i->nextrec);
}
if (i->blank)
{
fputs (" BLANK=", dumpfile);
show_expr (i->blank);
}
if (i->position)
{
fputs (" POSITION=", dumpfile);
show_expr (i->position);
}
if (i->action)
{
fputs (" ACTION=", dumpfile);
show_expr (i->action);
}
if (i->read)
{
fputs (" READ=", dumpfile);
show_expr (i->read);
}
if (i->write)
{
fputs (" WRITE=", dumpfile);
show_expr (i->write);
}
if (i->readwrite)
{
fputs (" READWRITE=", dumpfile);
show_expr (i->readwrite);
}
if (i->delim)
{
fputs (" DELIM=", dumpfile);
show_expr (i->delim);
}
if (i->pad)
{
fputs (" PAD=", dumpfile);
show_expr (i->pad);
}
if (i->convert)
{
fputs (" CONVERT=", dumpfile);
show_expr (i->convert);
}
if (i->asynchronous)
{
fputs (" ASYNCHRONOUS=", dumpfile);
show_expr (i->asynchronous);
}
if (i->decimal)
{
fputs (" DECIMAL=", dumpfile);
show_expr (i->decimal);
}
if (i->encoding)
{
fputs (" ENCODING=", dumpfile);
show_expr (i->encoding);
}
if (i->pending)
{
fputs (" PENDING=", dumpfile);
show_expr (i->pending);
}
if (i->round)
{
fputs (" ROUND=", dumpfile);
show_expr (i->round);
}
if (i->sign)
{
fputs (" SIGN=", dumpfile);
show_expr (i->sign);
}
if (i->size)
{
fputs (" SIZE=", dumpfile);
show_expr (i->size);
}
if (i->id)
{
fputs (" ID=", dumpfile);
show_expr (i->id);
}
if (i->err != NULL)
fprintf (dumpfile, " ERR=%d", i->err->value);
break;
case EXEC_IOLENGTH:
fputs ("IOLENGTH ", dumpfile);
show_expr (c->expr1);
goto show_dt_code;
break;
case EXEC_READ:
fputs ("READ", dumpfile);
goto show_dt;
case EXEC_WRITE:
fputs ("WRITE", dumpfile);
show_dt:
dt = c->ext.dt;
if (dt->io_unit)
{
fputs (" UNIT=", dumpfile);
show_expr (dt->io_unit);
}
if (dt->format_expr)
{
fputs (" FMT=", dumpfile);
show_expr (dt->format_expr);
}
if (dt->format_label != NULL)
fprintf (dumpfile, " FMT=%d", dt->format_label->value);
if (dt->namelist)
fprintf (dumpfile, " NML=%s", dt->namelist->name);
if (dt->iomsg)
{
fputs (" IOMSG=", dumpfile);
show_expr (dt->iomsg);
}
if (dt->iostat)
{
fputs (" IOSTAT=", dumpfile);
show_expr (dt->iostat);
}
if (dt->size)
{
fputs (" SIZE=", dumpfile);
show_expr (dt->size);
}
if (dt->rec)
{
fputs (" REC=", dumpfile);
show_expr (dt->rec);
}
if (dt->advance)
{
fputs (" ADVANCE=", dumpfile);
show_expr (dt->advance);
}
if (dt->id)
{
fputs (" ID=", dumpfile);
show_expr (dt->id);
}
if (dt->pos)
{
fputs (" POS=", dumpfile);
show_expr (dt->pos);
}
if (dt->asynchronous)
{
fputs (" ASYNCHRONOUS=", dumpfile);
show_expr (dt->asynchronous);
}
if (dt->blank)
{
fputs (" BLANK=", dumpfile);
show_expr (dt->blank);
}
if (dt->decimal)
{
fputs (" DECIMAL=", dumpfile);
show_expr (dt->decimal);
}
if (dt->delim)
{
fputs (" DELIM=", dumpfile);
show_expr (dt->delim);
}
if (dt->pad)
{
fputs (" PAD=", dumpfile);
show_expr (dt->pad);
}
if (dt->round)
{
fputs (" ROUND=", dumpfile);
show_expr (dt->round);
}
if (dt->sign)
{
fputs (" SIGN=", dumpfile);
show_expr (dt->sign);
}
show_dt_code:
for (c = c->block->next; c; c = c->next)
show_code_node (level + (c->next != NULL), c);
return;
case EXEC_TRANSFER:
fputs ("TRANSFER ", dumpfile);
show_expr (c->expr1);
break;
case EXEC_DT_END:
fputs ("DT_END", dumpfile);
dt = c->ext.dt;
if (dt->err != NULL)
fprintf (dumpfile, " ERR=%d", dt->err->value);
if (dt->end != NULL)
fprintf (dumpfile, " END=%d", dt->end->value);
if (dt->eor != NULL)
fprintf (dumpfile, " EOR=%d", dt->eor->value);
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_CRITICAL:
case EXEC_OMP_FLUSH:
case EXEC_OMP_DO:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_PARALLEL_WORKSHARE:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TASK:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
case EXEC_OMP_WORKSHARE:
show_omp_node (level, c);
break;
default:
gfc_internal_error ("show_code_node(): Bad statement code");
}
}
void
gfc_free_statement (gfc_code *p)
{
if (p->expr1)
gfc_free_expr (p->expr1);
if (p->expr2)
gfc_free_expr (p->expr2);
switch (p->op)
{
case EXEC_NOP:
case EXEC_END_BLOCK:
case EXEC_END_NESTED_BLOCK:
case EXEC_ASSIGN:
case EXEC_INIT_ASSIGN:
case EXEC_GOTO:
case EXEC_CYCLE:
case EXEC_RETURN:
case EXEC_END_PROCEDURE:
case EXEC_IF:
case EXEC_PAUSE:
case EXEC_STOP:
case EXEC_ERROR_STOP:
case EXEC_EXIT:
case EXEC_WHERE:
case EXEC_IOLENGTH:
case EXEC_POINTER_ASSIGN:
case EXEC_DO_WHILE:
case EXEC_CONTINUE:
case EXEC_TRANSFER:
case EXEC_LABEL_ASSIGN:
case EXEC_ENTRY:
case EXEC_ARITHMETIC_IF:
case EXEC_CRITICAL:
case EXEC_SYNC_ALL:
case EXEC_SYNC_IMAGES:
case EXEC_SYNC_MEMORY:
case EXEC_LOCK:
case EXEC_UNLOCK:
break;
case EXEC_BLOCK:
gfc_free_namespace (p->ext.block.ns);
gfc_free_association_list (p->ext.block.assoc);
break;
case EXEC_COMPCALL:
case EXEC_CALL_PPC:
case EXEC_CALL:
case EXEC_ASSIGN_CALL:
gfc_free_actual_arglist (p->ext.actual);
break;
case EXEC_SELECT:
case EXEC_SELECT_TYPE:
if (p->ext.block.case_list)
gfc_free_case_list (p->ext.block.case_list);
break;
case EXEC_DO:
gfc_free_iterator (p->ext.iterator, 1);
break;
case EXEC_ALLOCATE:
case EXEC_DEALLOCATE:
gfc_free_alloc_list (p->ext.alloc.list);
break;
case EXEC_OPEN:
gfc_free_open (p->ext.open);
break;
case EXEC_CLOSE:
gfc_free_close (p->ext.close);
break;
case EXEC_BACKSPACE:
case EXEC_ENDFILE:
case EXEC_REWIND:
case EXEC_FLUSH:
gfc_free_filepos (p->ext.filepos);
break;
case EXEC_INQUIRE:
gfc_free_inquire (p->ext.inquire);
break;
case EXEC_WAIT:
gfc_free_wait (p->ext.wait);
break;
case EXEC_READ:
case EXEC_WRITE:
gfc_free_dt (p->ext.dt);
break;
case EXEC_DT_END:
/* The ext.dt member is a duplicate pointer and doesn't need to
be freed. */
break;
case EXEC_DO_CONCURRENT:
case EXEC_FORALL:
gfc_free_forall_iterator (p->ext.forall_iterator);
break;
case EXEC_OMP_CANCEL:
case EXEC_OMP_CANCELLATION_POINT:
case EXEC_OMP_DISTRIBUTE:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
case EXEC_OMP_DISTRIBUTE_SIMD:
case EXEC_OMP_DO:
case EXEC_OMP_DO_SIMD:
case EXEC_OMP_END_SINGLE:
case EXEC_OMP_PARALLEL:
case EXEC_OMP_PARALLEL_DO:
case EXEC_OMP_PARALLEL_DO_SIMD:
case EXEC_OMP_PARALLEL_SECTIONS:
case EXEC_OMP_SECTIONS:
case EXEC_OMP_SIMD:
case EXEC_OMP_SINGLE:
case EXEC_OMP_TARGET:
case EXEC_OMP_TARGET_DATA:
case EXEC_OMP_TARGET_TEAMS:
case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE:
case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
case EXEC_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
case EXEC_OMP_TARGET_UPDATE:
case EXEC_OMP_TASK:
case EXEC_OMP_TEAMS:
case EXEC_OMP_TEAMS_DISTRIBUTE:
case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
case EXEC_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
case EXEC_OMP_TEAMS_DISTRIBUTE_SIMD:
case EXEC_OMP_WORKSHARE:
case EXEC_OMP_PARALLEL_WORKSHARE:
gfc_free_omp_clauses (p->ext.omp_clauses);
break;
case EXEC_OMP_CRITICAL:
free (CONST_CAST (char *, p->ext.omp_name));
break;
case EXEC_OMP_FLUSH:
gfc_free_omp_namelist (p->ext.omp_namelist);
break;
case EXEC_OMP_ATOMIC:
case EXEC_OMP_BARRIER:
case EXEC_OMP_MASTER:
case EXEC_OMP_ORDERED:
case EXEC_OMP_END_NOWAIT:
case EXEC_OMP_TASKGROUP:
case EXEC_OMP_TASKWAIT:
case EXEC_OMP_TASKYIELD:
break;
default:
gfc_internal_error ("gfc_free_statement(): Bad statement");
}
}
static void
gfc_show_code_node (int level, gfc_code * c)
{
gfc_forall_iterator *fa;
gfc_open *open;
gfc_case *cp;
gfc_alloc *a;
gfc_code *d;
gfc_close *close;
gfc_filepos *fp;
gfc_inquire *i;
gfc_dt *dt;
code_indent (level, c->here);
switch (c->op)
{
case EXEC_NOP:
gfc_status ("NOP");
break;
case EXEC_CONTINUE:
gfc_status ("CONTINUE");
break;
case EXEC_ENTRY:
gfc_status ("ENTRY %s", c->ext.entry->sym->name);
break;
case EXEC_INIT_ASSIGN:
case EXEC_ASSIGN:
gfc_status ("ASSIGN ");
gfc_show_expr (c->expr);
gfc_status_char (' ');
gfc_show_expr (c->expr2);
break;
case EXEC_LABEL_ASSIGN:
gfc_status ("LABEL ASSIGN ");
gfc_show_expr (c->expr);
gfc_status (" %d", c->label->value);
break;
case EXEC_POINTER_ASSIGN:
gfc_status ("POINTER ASSIGN ");
gfc_show_expr (c->expr);
gfc_status_char (' ');
gfc_show_expr (c->expr2);
break;
case EXEC_GOTO:
gfc_status ("GOTO ");
if (c->label)
gfc_status ("%d", c->label->value);
else
{
gfc_show_expr (c->expr);
d = c->block;
if (d != NULL)
{
gfc_status (", (");
for (; d; d = d ->block)
{
code_indent (level, d->label);
if (d->block != NULL)
gfc_status_char (',');
else
gfc_status_char (')');
}
}
}
break;
case EXEC_CALL:
if (c->resolved_sym)
gfc_status ("CALL %s ", c->resolved_sym->name);
else if (c->symtree)
gfc_status ("CALL %s ", c->symtree->name);
else
gfc_status ("CALL ?? ");
gfc_show_actual_arglist (c->ext.actual);
break;
case EXEC_RETURN:
gfc_status ("RETURN ");
if (c->expr)
gfc_show_expr (c->expr);
break;
case EXEC_PAUSE:
gfc_status ("PAUSE ");
if (c->expr != NULL)
gfc_show_expr (c->expr);
else
gfc_status ("%d", c->ext.stop_code);
break;
case EXEC_STOP:
gfc_status ("STOP ");
if (c->expr != NULL)
gfc_show_expr (c->expr);
else
gfc_status ("%d", c->ext.stop_code);
break;
case EXEC_ARITHMETIC_IF:
gfc_status ("IF ");
gfc_show_expr (c->expr);
gfc_status (" %d, %d, %d",
c->label->value, c->label2->value, c->label3->value);
break;
case EXEC_IF:
d = c->block;
gfc_status ("IF ");
gfc_show_expr (d->expr);
gfc_status_char ('\n');
gfc_show_code (level + 1, d->next);
d = d->block;
for (; d; d = d->block)
{
code_indent (level, 0);
if (d->expr == NULL)
gfc_status ("ELSE\n");
else
{
gfc_status ("ELSE IF ");
gfc_show_expr (d->expr);
gfc_status_char ('\n');
}
gfc_show_code (level + 1, d->next);
}
code_indent (level, c->label);
gfc_status ("ENDIF");
break;
case EXEC_SELECT:
d = c->block;
gfc_status ("SELECT CASE ");
gfc_show_expr (c->expr);
gfc_status_char ('\n');
for (; d; d = d->block)
{
code_indent (level, 0);
gfc_status ("CASE ");
for (cp = d->ext.case_list; cp; cp = cp->next)
{
gfc_status_char ('(');
gfc_show_expr (cp->low);
gfc_status_char (' ');
gfc_show_expr (cp->high);
gfc_status_char (')');
gfc_status_char (' ');
}
gfc_status_char ('\n');
gfc_show_code (level + 1, d->next);
}
code_indent (level, c->label);
gfc_status ("END SELECT");
break;
case EXEC_WHERE:
gfc_status ("WHERE ");
d = c->block;
gfc_show_expr (d->expr);
gfc_status_char ('\n');
gfc_show_code (level + 1, d->next);
for (d = d->block; d; d = d->block)
{
code_indent (level, 0);
gfc_status ("ELSE WHERE ");
gfc_show_expr (d->expr);
gfc_status_char ('\n');
gfc_show_code (level + 1, d->next);
}
code_indent (level, 0);
gfc_status ("END WHERE");
break;
case EXEC_FORALL:
gfc_status ("FORALL ");
for (fa = c->ext.forall_iterator; fa; fa = fa->next)
{
gfc_show_expr (fa->var);
gfc_status_char (' ');
gfc_show_expr (fa->start);
gfc_status_char (':');
gfc_show_expr (fa->end);
gfc_status_char (':');
gfc_show_expr (fa->stride);
if (fa->next != NULL)
gfc_status_char (',');
}
if (c->expr != NULL)
{
gfc_status_char (',');
gfc_show_expr (c->expr);
}
gfc_status_char ('\n');
gfc_show_code (level + 1, c->block->next);
code_indent (level, 0);
gfc_status ("END FORALL");
break;
case EXEC_DO:
gfc_status ("DO ");
gfc_show_expr (c->ext.iterator->var);
gfc_status_char ('=');
gfc_show_expr (c->ext.iterator->start);
gfc_status_char (' ');
gfc_show_expr (c->ext.iterator->end);
gfc_status_char (' ');
gfc_show_expr (c->ext.iterator->step);
gfc_status_char ('\n');
gfc_show_code (level + 1, c->block->next);
code_indent (level, 0);
gfc_status ("END DO");
break;
case EXEC_DO_WHILE:
gfc_status ("DO WHILE ");
gfc_show_expr (c->expr);
gfc_status_char ('\n');
gfc_show_code (level + 1, c->block->next);
code_indent (level, c->label);
gfc_status ("END DO");
break;
case EXEC_CYCLE:
gfc_status ("CYCLE");
if (c->symtree)
gfc_status (" %s", c->symtree->n.sym->name);
break;
case EXEC_EXIT:
gfc_status ("EXIT");
if (c->symtree)
gfc_status (" %s", c->symtree->n.sym->name);
break;
case EXEC_ALLOCATE:
gfc_status ("ALLOCATE ");
if (c->expr)
{
gfc_status (" STAT=");
gfc_show_expr (c->expr);
}
for (a = c->ext.alloc_list; a; a = a->next)
{
gfc_status_char (' ');
gfc_show_expr (a->expr);
}
break;
case EXEC_DEALLOCATE:
gfc_status ("DEALLOCATE ");
if (c->expr)
{
gfc_status (" STAT=");
gfc_show_expr (c->expr);
}
for (a = c->ext.alloc_list; a; a = a->next)
{
gfc_status_char (' ');
gfc_show_expr (a->expr);
}
break;
case EXEC_OPEN:
gfc_status ("OPEN");
open = c->ext.open;
if (open->unit)
{
gfc_status (" UNIT=");
gfc_show_expr (open->unit);
}
if (open->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (open->iomsg);
}
if (open->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (open->iostat);
}
if (open->file)
{
gfc_status (" FILE=");
gfc_show_expr (open->file);
}
if (open->status)
{
gfc_status (" STATUS=");
gfc_show_expr (open->status);
}
if (open->access)
{
gfc_status (" ACCESS=");
gfc_show_expr (open->access);
}
if (open->form)
{
gfc_status (" FORM=");
gfc_show_expr (open->form);
}
if (open->recl)
{
gfc_status (" RECL=");
gfc_show_expr (open->recl);
}
if (open->blank)
{
gfc_status (" BLANK=");
gfc_show_expr (open->blank);
}
if (open->position)
{
gfc_status (" POSITION=");
gfc_show_expr (open->position);
}
if (open->action)
{
gfc_status (" ACTION=");
gfc_show_expr (open->action);
}
if (open->delim)
{
gfc_status (" DELIM=");
gfc_show_expr (open->delim);
}
if (open->pad)
{
gfc_status (" PAD=");
gfc_show_expr (open->pad);
}
if (open->convert)
{
gfc_status (" CONVERT=");
gfc_show_expr (open->convert);
}
if (open->err != NULL)
gfc_status (" ERR=%d", open->err->value);
break;
case EXEC_CLOSE:
gfc_status ("CLOSE");
close = c->ext.close;
if (close->unit)
{
gfc_status (" UNIT=");
gfc_show_expr (close->unit);
}
if (close->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (close->iomsg);
}
if (close->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (close->iostat);
}
if (close->status)
{
gfc_status (" STATUS=");
gfc_show_expr (close->status);
}
if (close->err != NULL)
gfc_status (" ERR=%d", close->err->value);
break;
case EXEC_BACKSPACE:
gfc_status ("BACKSPACE");
goto show_filepos;
case EXEC_ENDFILE:
gfc_status ("ENDFILE");
goto show_filepos;
case EXEC_REWIND:
gfc_status ("REWIND");
goto show_filepos;
case EXEC_FLUSH:
gfc_status ("FLUSH");
show_filepos:
fp = c->ext.filepos;
if (fp->unit)
{
gfc_status (" UNIT=");
gfc_show_expr (fp->unit);
}
if (fp->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (fp->iomsg);
}
if (fp->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (fp->iostat);
}
if (fp->err != NULL)
gfc_status (" ERR=%d", fp->err->value);
break;
case EXEC_INQUIRE:
gfc_status ("INQUIRE");
i = c->ext.inquire;
if (i->unit)
{
gfc_status (" UNIT=");
gfc_show_expr (i->unit);
}
if (i->file)
{
gfc_status (" FILE=");
gfc_show_expr (i->file);
}
if (i->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (i->iomsg);
}
if (i->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (i->iostat);
}
if (i->exist)
{
gfc_status (" EXIST=");
gfc_show_expr (i->exist);
}
if (i->opened)
{
gfc_status (" OPENED=");
gfc_show_expr (i->opened);
}
if (i->number)
{
gfc_status (" NUMBER=");
gfc_show_expr (i->number);
}
if (i->named)
{
gfc_status (" NAMED=");
gfc_show_expr (i->named);
}
if (i->name)
{
gfc_status (" NAME=");
gfc_show_expr (i->name);
}
if (i->access)
{
gfc_status (" ACCESS=");
gfc_show_expr (i->access);
}
if (i->sequential)
{
gfc_status (" SEQUENTIAL=");
gfc_show_expr (i->sequential);
}
if (i->direct)
{
gfc_status (" DIRECT=");
gfc_show_expr (i->direct);
}
if (i->form)
{
gfc_status (" FORM=");
gfc_show_expr (i->form);
}
if (i->formatted)
{
gfc_status (" FORMATTED");
gfc_show_expr (i->formatted);
}
if (i->unformatted)
{
gfc_status (" UNFORMATTED=");
gfc_show_expr (i->unformatted);
}
if (i->recl)
{
gfc_status (" RECL=");
gfc_show_expr (i->recl);
}
if (i->nextrec)
{
gfc_status (" NEXTREC=");
gfc_show_expr (i->nextrec);
}
if (i->blank)
{
gfc_status (" BLANK=");
gfc_show_expr (i->blank);
}
if (i->position)
{
gfc_status (" POSITION=");
gfc_show_expr (i->position);
}
if (i->action)
{
gfc_status (" ACTION=");
gfc_show_expr (i->action);
}
if (i->read)
{
gfc_status (" READ=");
gfc_show_expr (i->read);
}
if (i->write)
{
gfc_status (" WRITE=");
gfc_show_expr (i->write);
}
if (i->readwrite)
{
gfc_status (" READWRITE=");
gfc_show_expr (i->readwrite);
}
if (i->delim)
{
gfc_status (" DELIM=");
gfc_show_expr (i->delim);
}
if (i->pad)
{
gfc_status (" PAD=");
gfc_show_expr (i->pad);
}
if (i->convert)
{
gfc_status (" CONVERT=");
gfc_show_expr (i->convert);
}
if (i->err != NULL)
gfc_status (" ERR=%d", i->err->value);
break;
case EXEC_IOLENGTH:
gfc_status ("IOLENGTH ");
gfc_show_expr (c->expr);
goto show_dt_code;
break;
case EXEC_READ:
gfc_status ("READ");
goto show_dt;
case EXEC_WRITE:
gfc_status ("WRITE");
show_dt:
dt = c->ext.dt;
if (dt->io_unit)
{
gfc_status (" UNIT=");
gfc_show_expr (dt->io_unit);
}
if (dt->format_expr)
{
gfc_status (" FMT=");
gfc_show_expr (dt->format_expr);
}
if (dt->format_label != NULL)
gfc_status (" FMT=%d", dt->format_label->value);
if (dt->namelist)
gfc_status (" NML=%s", dt->namelist->name);
if (dt->iomsg)
{
gfc_status (" IOMSG=");
gfc_show_expr (dt->iomsg);
}
if (dt->iostat)
{
gfc_status (" IOSTAT=");
gfc_show_expr (dt->iostat);
}
if (dt->size)
{
gfc_status (" SIZE=");
gfc_show_expr (dt->size);
}
if (dt->rec)
{
gfc_status (" REC=");
gfc_show_expr (dt->rec);
}
if (dt->advance)
{
gfc_status (" ADVANCE=");
gfc_show_expr (dt->advance);
}
show_dt_code:
gfc_status_char ('\n');
for (c = c->block->next; c; c = c->next)
gfc_show_code_node (level + (c->next != NULL), c);
return;
case EXEC_TRANSFER:
gfc_status ("TRANSFER ");
gfc_show_expr (c->expr);
break;
case EXEC_DT_END:
gfc_status ("DT_END");
dt = c->ext.dt;
if (dt->err != NULL)
gfc_status (" ERR=%d", dt->err->value);
if (dt->end != NULL)
gfc_status (" END=%d", dt->end->value);
if (dt->eor != NULL)
gfc_status (" EOR=%d", dt->eor->value);
break;
default:
gfc_internal_error ("gfc_show_code_node(): Bad statement code");
}
gfc_status_char ('\n');
}
static void
check_operator_interface (gfc_interface * intr, gfc_intrinsic_op operator)
{
gfc_formal_arglist *formal;
sym_intent i1, i2;
gfc_symbol *sym;
bt t1, t2;
int args;
if (intr == NULL)
return;
args = 0;
t1 = t2 = BT_UNKNOWN;
i1 = i2 = INTENT_UNKNOWN;
for (formal = intr->sym->formal; formal; formal = formal->next)
{
sym = formal->sym;
if (args == 0)
{
t1 = sym->ts.type;
i1 = sym->attr.intent;
}
if (args == 1)
{
t2 = sym->ts.type;
i2 = sym->attr.intent;
}
args++;
}
if (args == 0 || args > 2)
goto num_args;
sym = intr->sym;
if (operator == INTRINSIC_ASSIGN)
{
if (!sym->attr.subroutine)
{
gfc_error
("Assignment operator interface at %L must be a SUBROUTINE",
&intr->where);
return;
}
}
else
{
if (!sym->attr.function)
{
gfc_error ("Intrinsic operator interface at %L must be a FUNCTION",
&intr->where);
return;
}
}
switch (operator)
{
case INTRINSIC_PLUS: /* Numeric unary or binary */
case INTRINSIC_MINUS:
if ((args == 1)
&& (t1 == BT_INTEGER
|| t1 == BT_REAL
|| t1 == BT_COMPLEX))
goto bad_repl;
if ((args == 2)
&& (t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
&& (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
goto bad_repl;
break;
case INTRINSIC_POWER: /* Binary numeric */
case INTRINSIC_TIMES:
case INTRINSIC_DIVIDE:
case INTRINSIC_EQ:
case INTRINSIC_NE:
if (args == 1)
goto num_args;
if ((t1 == BT_INTEGER || t1 == BT_REAL || t1 == BT_COMPLEX)
&& (t2 == BT_INTEGER || t2 == BT_REAL || t2 == BT_COMPLEX))
goto bad_repl;
break;
case INTRINSIC_GE: /* Binary numeric operators that do not support */
case INTRINSIC_LE: /* complex numbers */
case INTRINSIC_LT:
case INTRINSIC_GT:
if (args == 1)
goto num_args;
if ((t1 == BT_INTEGER || t1 == BT_REAL)
&& (t2 == BT_INTEGER || t2 == BT_REAL))
goto bad_repl;
break;
case INTRINSIC_OR: /* Binary logical */
case INTRINSIC_AND:
case INTRINSIC_EQV:
case INTRINSIC_NEQV:
if (args == 1)
goto num_args;
if (t1 == BT_LOGICAL && t2 == BT_LOGICAL)
goto bad_repl;
break;
case INTRINSIC_NOT: /* Unary logical */
if (args != 1)
goto num_args;
if (t1 == BT_LOGICAL)
goto bad_repl;
break;
case INTRINSIC_CONCAT: /* Binary string */
if (args != 2)
goto num_args;
if (t1 == BT_CHARACTER && t2 == BT_CHARACTER)
goto bad_repl;
break;
case INTRINSIC_ASSIGN: /* Class by itself */
if (args != 2)
goto num_args;
break;
default:
gfc_internal_error ("check_operator_interface(): Bad operator");
}
/* Check intents on operator interfaces. */
if (operator == INTRINSIC_ASSIGN)
{
if (i1 != INTENT_OUT && i1 != INTENT_INOUT)
gfc_error ("First argument of defined assignment at %L must be "
"INTENT(IN) or INTENT(INOUT)", &intr->where);
if (i2 != INTENT_IN)
gfc_error ("Second argument of defined assignment at %L must be "
"INTENT(IN)", &intr->where);
}
else
{
if (i1 != INTENT_IN)
gfc_error ("First argument of operator interface at %L must be "
"INTENT(IN)", &intr->where);
if (args == 2 && i2 != INTENT_IN)
gfc_error ("Second argument of operator interface at %L must be "
"INTENT(IN)", &intr->where);
}
return;
bad_repl:
gfc_error ("Operator interface at %L conflicts with intrinsic interface",
&intr->where);
return;
num_args:
gfc_error ("Operator interface at %L has the wrong number of arguments",
&intr->where);
return;
}
