Skip to content

R
riscv-gcc-1
Commit 20585ad6 by Brooks Moses Committed by Brooks Moses
Options

gfortran.h (gfc_expr): Remove from_H, add "representation" struct. 

* gfortran.h (gfc_expr): Remove from_H, add "representation"
struct.
* primary.c (match_hollerith_constant): Store the representation
of the Hollerith in representation, not in value.character.
* arith.c: Add dependency on target-memory.h.
(eval_intrinsic): Remove check for from_H.
(hollerith2representation): New function.
(gfc_hollerith2int): Determine value of the new constant.
(gfc_hollerith2real): Likewise.
(gfc_hollerith2complex): Likewise.
(gfc_hollerith2logical): Likewise.
(gfc_hollerith2character): Point both representation.string and
value.character.string at the value string.
* data.c (create_character_initializer): For BT_HOLLERITH
rvalues, get the value from the representation rather than
value.character.
* expr.c (free_expr0): Update handling of BT_HOLLERITH values
and values with representation.string.
(gfc_copy_expr): Likewise.
* intrinsic.c (do_simplify): Remove special treatement of
variables resulting from Hollerith constants.
* dump-parse-trees.c (gfc_show_expr): Update handling of
Holleriths.
* trans-const.c (gfc_conv_constant_to_tree): Replace from_H
check with check for representation.string; get Hollerith
representation from representation.string, not value.character.
* trans-expr.c (is_zero_initializer_p): Replace from_H check
with check for representation.string.
* trans-stmt.c (gfc_trans_integer_select): Use
gfc_conv_mpz_to_tree for case values, so as to avoid picking up
the memory representation if the case is given by a transfer
expression.
* target-memory.c (gfc_target_encode_expr): Use the known memory
representation rather than the value, if it exists.
(gfc_target_interpret_expr): Store the memory representation of
the interpreted expression as well as its value.
(interpret_integer): Move to gfc_interpret_integer, make
non-static.
(interpret_float): Move to gfc_interpret_float, make non-static.
(interpret_complex): Move to gfc_interpret_complex, make
non-static.
(interpret_logical): Move to gfc_interpret_logical, make
non-static.
(interpret_character): Move to gfc_interpret_character, make
non-static.
(interpret_derived): Move to gfc_interpret_derived, make
non-static.
* target-memory.h: Add prototypes for newly-exported
gfc_interpret_* functions.

From-SVN: r125135
parent 0258dc3a
Showing with 287 additions and 172 deletions
gcc/fortran/ChangeLog
2007-05-27 Brooks Moses <brooks.moses@codesourcery.com>
* gfortran.h (gfc_expr): Remove from_H, add "representation"
struct.
* primary.c (match_hollerith_constant): Store the representation
of the Hollerith in representation, not in value.character.
* arith.c: Add dependency on target-memory.h.
(eval_intrinsic): Remove check for from_H.
(hollerith2representation): New function.
(gfc_hollerith2int): Determine value of the new constant.
(gfc_hollerith2real): Likewise.
(gfc_hollerith2complex): Likewise.
(gfc_hollerith2logical): Likewise.
(gfc_hollerith2character): Point both representation.string and
value.character.string at the value string.
* data.c (create_character_initializer): For BT_HOLLERITH
rvalues, get the value from the representation rather than
value.character.
* expr.c (free_expr0): Update handling of BT_HOLLERITH values
and values with representation.string.
(gfc_copy_expr): Likewise.
* intrinsic.c (do_simplify): Remove special treatement of
variables resulting from Hollerith constants.
* dump-parse-trees.c (gfc_show_expr): Update handling of
Holleriths.
* trans-const.c (gfc_conv_constant_to_tree): Replace from_H
check with check for representation.string; get Hollerith
representation from representation.string, not value.character.
* trans-expr.c (is_zero_initializer_p): Replace from_H check
with check for representation.string.
* trans-stmt.c (gfc_trans_integer_select): Use
gfc_conv_mpz_to_tree for case values, so as to avoid picking up
the memory representation if the case is given by a transfer
expression.
* target-memory.c (gfc_target_encode_expr): Use the known memory
representation rather than the value, if it exists.
(gfc_target_interpret_expr): Store the memory representation of
the interpreted expression as well as its value.
(interpret_integer): Move to gfc_interpret_integer, make
non-static.
(interpret_float): Move to gfc_interpret_float, make non-static.
(interpret_complex): Move to gfc_interpret_complex, make
non-static.
(interpret_logical): Move to gfc_interpret_logical, make
non-static.
(interpret_character): Move to gfc_interpret_character, make
non-static.
(interpret_derived): Move to gfc_interpret_derived, make
non-static.
* target-memory.h: Add prototypes for newly-exported
gfc_interpret_* functions.
2007-05-27 Jerry DeLisle <jvdelisle@gcc.gnu.org> 2007-05-27 Jerry DeLisle <jvdelisle@gcc.gnu.org>
PR fortran/31812 PR fortran/31812
......
gcc/fortran/arith.c
...@@ -30,6 +30,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA ...@@ -30,6 +30,7 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
#include "flags.h" #include "flags.h"
#include "gfortran.h" #include "gfortran.h"
#include "arith.h" #include "arith.h"
#include "target-memory.h"
/* MPFR does not have a direct replacement for mpz_set_f() from GMP. /* MPFR does not have a direct replacement for mpz_set_f() from GMP.
It's easily implemented with a few calls though. */ It's easily implemented with a few calls though. */
...@@ -1613,17 +1614,15 @@ eval_intrinsic (gfc_intrinsic_op operator, ...@@ -1613,17 +1614,15 @@ eval_intrinsic (gfc_intrinsic_op operator,
if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER) if (operator == INTRINSIC_POWER && op2->ts.type != BT_INTEGER)
goto runtime; goto runtime;
if (op1->from_H if (op1->expr_type != EXPR_CONSTANT
|| (op1->expr_type != EXPR_CONSTANT && (op1->expr_type != EXPR_ARRAY
&& (op1->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1)))
|| !gfc_is_constant_expr (op1) || !gfc_expanded_ac (op1))))
goto runtime; goto runtime;
if (op2 != NULL if (op2 != NULL
&& (op2->from_H && op2->expr_type != EXPR_CONSTANT
|| (op2->expr_type != EXPR_CONSTANT && (op2->expr_type != EXPR_ARRAY
&& (op2->expr_type != EXPR_ARRAY || !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))
|| !gfc_is_constant_expr (op2) || !gfc_expanded_ac (op2)))))
goto runtime; goto runtime;
if (unary) if (unary)
...@@ -2307,37 +2306,52 @@ gfc_int2log (gfc_expr *src, int kind) ...@@ -2307,37 +2306,52 @@ gfc_int2log (gfc_expr *src, int kind)
} }
/* Helper function to set the representation in a Hollerith conversion.
This assumes that the ts.type and ts.kind of the result have already
been set. */
static void
hollerith2representation (gfc_expr *result, gfc_expr *src)
{
int src_len, result_len;
src_len = src->representation.length;
result_len = gfc_target_expr_size (result);
if (src_len > result_len)
{
gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
&src->where, gfc_typename(&result->ts));
}
result->representation.string = gfc_getmem (result_len + 1);
memcpy (result->representation.string, src->representation.string,
MIN (result_len, src_len));
if (src_len < result_len)
memset (&result->representation.string[src_len], ' ', result_len - src_len);
result->representation.string[result_len] = '\0'; /* For debugger */
result->representation.length = result_len;
}
/* Convert Hollerith to integer. The constant will be padded or truncated. */ /* Convert Hollerith to integer. The constant will be padded or truncated. */
gfc_expr * gfc_expr *
gfc_hollerith2int (gfc_expr *src, int kind) gfc_hollerith2int (gfc_expr *src, int kind)
{ {
gfc_expr *result; gfc_expr *result;
int len;
len = src->value.character.length;
result = gfc_get_expr (); result = gfc_get_expr ();
result->expr_type = EXPR_CONSTANT; result->expr_type = EXPR_CONSTANT;
result->ts.type = BT_INTEGER; result->ts.type = BT_INTEGER;
result->ts.kind = kind; result->ts.kind = kind;
result->where = src->where; result->where = src->where;
result->from_H = 1;
if (len > kind)
{
gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
&src->where, gfc_typename(&result->ts));
}
result->value.character.string = gfc_getmem (kind + 1);
memcpy (result->value.character.string, src->value.character.string,
MIN (kind, len));
if (len < kind)
memset (&result->value.character.string[len], ' ', kind - len);
result->value.character.string[kind] = '\0'; /* For debugger */ hollerith2representation (result, src);
result->value.character.length = kind; gfc_interpret_integer(kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.integer);
return result; return result;
} }
...@@ -2358,22 +2372,10 @@ gfc_hollerith2real (gfc_expr *src, int kind) ...@@ -2358,22 +2372,10 @@ gfc_hollerith2real (gfc_expr *src, int kind)
result->ts.type = BT_REAL; result->ts.type = BT_REAL;
result->ts.kind = kind; result->ts.kind = kind;
result->where = src->where; result->where = src->where;
result->from_H = 1;
if (len > kind) hollerith2representation (result, src);
{ gfc_interpret_float(kind, (unsigned char *) result->representation.string,
gfc_warning ("The Hollerith constant at %L is too long to convert to %s", result->representation.length, result->value.real);
&src->where, gfc_typename(&result->ts));
}
result->value.character.string = gfc_getmem (kind + 1);
memcpy (result->value.character.string, src->value.character.string,
MIN (kind, len));
if (len < kind)
memset (&result->value.character.string[len], ' ', kind - len);
result->value.character.string[kind] = '\0'; /* For debugger. */
result->value.character.length = kind;
return result; return result;
} }
...@@ -2394,24 +2396,11 @@ gfc_hollerith2complex (gfc_expr *src, int kind) ...@@ -2394,24 +2396,11 @@ gfc_hollerith2complex (gfc_expr *src, int kind)
result->ts.type = BT_COMPLEX; result->ts.type = BT_COMPLEX;
result->ts.kind = kind; result->ts.kind = kind;
result->where = src->where; result->where = src->where;
result->from_H = 1;
kind = kind * 2;
if (len > kind)
{
gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
&src->where, gfc_typename(&result->ts));
}
result->value.character.string = gfc_getmem (kind + 1);
memcpy (result->value.character.string, src->value.character.string,
MIN (kind, len));
if (len < kind) hollerith2representation (result, src);
memset (&result->value.character.string[len], ' ', kind - len); gfc_interpret_complex(kind, (unsigned char *) result->representation.string,
result->representation.length, result->value.complex.r,
result->value.character.string[kind] = '\0'; /* For debugger */ result->value.complex.i);
result->value.character.length = kind;
return result; return result;
} }
...@@ -2427,7 +2416,9 @@ gfc_hollerith2character (gfc_expr *src, int kind) ...@@ -2427,7 +2416,9 @@ gfc_hollerith2character (gfc_expr *src, int kind)
result = gfc_copy_expr (src); result = gfc_copy_expr (src);
result->ts.type = BT_CHARACTER; result->ts.type = BT_CHARACTER;
result->ts.kind = kind; result->ts.kind = kind;
result->from_H = 1;
result->value.character.string = result->representation.string;
result->value.character.length = result->representation.length;
return result; return result;
} }
...@@ -2448,22 +2439,10 @@ gfc_hollerith2logical (gfc_expr *src, int kind) ...@@ -2448,22 +2439,10 @@ gfc_hollerith2logical (gfc_expr *src, int kind)
result->ts.type = BT_LOGICAL; result->ts.type = BT_LOGICAL;
result->ts.kind = kind; result->ts.kind = kind;
result->where = src->where; result->where = src->where;
result->from_H = 1;
if (len > kind)
{
gfc_warning ("The Hollerith constant at %L is too long to convert to %s",
&src->where, gfc_typename(&result->ts));
}
result->value.character.string = gfc_getmem (kind + 1);
memcpy (result->value.character.string, src->value.character.string,
MIN (kind, len));
if (len < kind)
memset (&result->value.character.string[len], ' ', kind - len);
result->value.character.string[kind] = '\0'; /* For debugger */ hollerith2representation (result, src);
result->value.character.length = kind; gfc_interpret_logical(kind, (unsigned char *) result->representation.string,
result->representation.length, &result->value.logical);
return result; return result;
} }
......
gcc/fortran/data.c
...@@ -154,7 +154,7 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts, ...@@ -154,7 +154,7 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts,
int len; int len;
int start; int start;
int end; int end;
char *dest; char *dest, *rvalue_string;
gfc_extract_int (ts->cl->length, &len); gfc_extract_int (ts->cl->length, &len);
...@@ -207,7 +207,17 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts, ...@@ -207,7 +207,17 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts,
} }
/* Copy the initial value. */ /* Copy the initial value. */
len = rvalue->value.character.length; if (rvalue->ts.type == BT_HOLLERITH)
{
len = rvalue->representation.length;
rvalue_string = rvalue->representation.string;
}
else
{
len = rvalue->value.character.length;
rvalue_string = rvalue->value.character.string;
}
if (len > end - start) if (len > end - start)
{ {
len = end - start; len = end - start;
...@@ -215,14 +225,17 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts, ...@@ -215,14 +225,17 @@ create_character_intializer (gfc_expr *init, gfc_typespec *ts,
"at %L", &rvalue->where); "at %L", &rvalue->where);
} }
memcpy (&dest[start], rvalue->value.character.string, len); memcpy (&dest[start], rvalue_string, len);
/* Pad with spaces. Substrings will already be blanked. */ /* Pad with spaces. Substrings will already be blanked. */
if (len < end - start && ref == NULL) if (len < end - start && ref == NULL)
memset (&dest[start + len], ' ', end - (start + len)); memset (&dest[start + len], ' ', end - (start + len));
if (rvalue->ts.type == BT_HOLLERITH) if (rvalue->ts.type == BT_HOLLERITH)
init->from_H = 1; {
init->representation.length = init->value.character.length;
init->representation.string = init->value.character.string;
}
return init; return init;
} }
......
gcc/fortran/dump-parse-tree.c
...@@ -340,16 +340,6 @@ gfc_show_expr (gfc_expr *p) ...@@ -340,16 +340,6 @@ gfc_show_expr (gfc_expr *p)
break; break;
case EXPR_CONSTANT: 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) switch (p->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
...@@ -405,11 +395,33 @@ gfc_show_expr (gfc_expr *p) ...@@ -405,11 +395,33 @@ gfc_show_expr (gfc_expr *p)
gfc_status (")"); gfc_status (")");
break; break;
case BT_HOLLERITH:
gfc_status ("%dH", p->representation.length);
c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++)
{
gfc_status_char (*c);
}
break;
default: default:
gfc_status ("???"); gfc_status ("???");
break; break;
} }
if (p->representation.string)
{
gfc_status (" {");
c = p->representation.string;
for (i = 0; i < p->representation.length; i++, c++)
{
gfc_status ("%.2x", (unsigned int) *c);
if (i < p->representation.length - 1)
gfc_status_char (',');
}
gfc_status_char ('}');
}
break; break;
case EXPR_VARIABLE: case EXPR_VARIABLE:
......
gcc/fortran/expr.c
...@@ -140,12 +140,7 @@ free_expr0 (gfc_expr *e) ...@@ -140,12 +140,7 @@ free_expr0 (gfc_expr *e)
switch (e->expr_type) switch (e->expr_type)
{ {
case EXPR_CONSTANT: case EXPR_CONSTANT:
if (e->from_H) /* Free any parts of the value that need freeing. */
{
gfc_free (e->value.character.string);
break;
}
switch (e->ts.type) switch (e->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
...@@ -157,7 +152,6 @@ free_expr0 (gfc_expr *e) ...@@ -157,7 +152,6 @@ free_expr0 (gfc_expr *e)
break; break;
case BT_CHARACTER: case BT_CHARACTER:
case BT_HOLLERITH:
gfc_free (e->value.character.string); gfc_free (e->value.character.string);
break; break;
...@@ -170,6 +164,11 @@ free_expr0 (gfc_expr *e) ...@@ -170,6 +164,11 @@ free_expr0 (gfc_expr *e)
break; break;
} }
/* Free the representation, except in character constants where it
is the same as value.character.string and thus already freed. */
if (e->representation.string && e->ts.type != BT_CHARACTER)
gfc_free (e->representation.string);
break; break;
case EXPR_OP: case EXPR_OP:
...@@ -413,14 +412,16 @@ gfc_copy_expr (gfc_expr *p) ...@@ -413,14 +412,16 @@ gfc_copy_expr (gfc_expr *p)
break; break;
case EXPR_CONSTANT: case EXPR_CONSTANT:
if (p->from_H) /* Copy target representation, if it exists. */
if (p->representation.string)
{ {
s = gfc_getmem (p->value.character.length + 1); s = gfc_getmem (p->representation.length + 1);
q->value.character.string = s; q->representation.string = s;
memcpy (s, p->value.character.string, p->value.character.length + 1); memcpy (s, p->representation.string, p->representation.length + 1);
break;
} }
/* Copy the values of any pointer components of p->value. */
switch (q->ts.type) switch (q->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
...@@ -442,13 +443,18 @@ gfc_copy_expr (gfc_expr *p) ...@@ -442,13 +443,18 @@ gfc_copy_expr (gfc_expr *p)
break; break;
case BT_CHARACTER: case BT_CHARACTER:
case BT_HOLLERITH: if (p->representation.string)
s = gfc_getmem (p->value.character.length + 1); q->value.character.string = q->representation.string;
q->value.character.string = s; else
{
s = gfc_getmem (p->value.character.length + 1);
q->value.character.string = s;
memcpy (s, p->value.character.string, p->value.character.length + 1); memcpy (s, p->value.character.string, p->value.character.length + 1);
}
break; break;
case BT_HOLLERITH:
case BT_LOGICAL: case BT_LOGICAL:
case BT_DERIVED: case BT_DERIVED:
break; /* Already done */ break; /* Already done */
......
gcc/fortran/gfortran.h
...@@ -1290,17 +1290,28 @@ typedef struct gfc_expr ...@@ -1290,17 +1290,28 @@ typedef struct gfc_expr
locus where; locus where;
/* True if it is converted from Hollerith constant. */
unsigned int from_H : 1;
/* True if the expression is a call to a function that returns an array, /* True if the expression is a call to a function that returns an array,
and if we have decided not to allocate temporary data for that array. */ and if we have decided not to allocate temporary data for that array. */
unsigned int inline_noncopying_intrinsic : 1; unsigned int inline_noncopying_intrinsic : 1;
/* Used to quickly find a given constructor by it's offset. */
/* Used to quickly find a given constructor by its offset. */
splay_tree con_by_offset; splay_tree con_by_offset;
/* If an expression comes from a Hollerith constant or compile-time
evaluation of a transfer statement, it may have a prescribed target-
memory representation, and these cannot always be backformed from
the value. */
struct
{
int length;
char *string;
}
representation;
union union
{ {
int logical; int logical;
mpz_t integer; mpz_t integer;
mpfr_t real; mpfr_t real;
......
gcc/fortran/intrinsic.c
...@@ -3065,16 +3065,6 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) ...@@ -3065,16 +3065,6 @@ do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
gfc_expr *result, *a1, *a2, *a3, *a4, *a5; gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
gfc_actual_arglist *arg; gfc_actual_arglist *arg;
/* Check the arguments if there are Hollerith constants. We deal with
them at run-time. */
for (arg = e->value.function.actual; arg != NULL; arg = arg->next)
{
if (arg->expr && arg->expr->from_H)
{
result = NULL;
goto finish;
}
}
/* Max and min require special handling due to the variable number /* Max and min require special handling due to the variable number
of args. */ of args. */
if (specific->simplify.f1 == gfc_simplify_min) if (specific->simplify.f1 == gfc_simplify_min)
......
gcc/fortran/primary.c
...@@ -236,7 +236,6 @@ match_hollerith_constant (gfc_expr **result) ...@@ -236,7 +236,6 @@ match_hollerith_constant (gfc_expr **result)
locus old_loc; locus old_loc;
gfc_expr *e = NULL; gfc_expr *e = NULL;
const char *msg; const char *msg;
char *buffer;
int num; int num;
int i; int i;
...@@ -270,18 +269,18 @@ match_hollerith_constant (gfc_expr **result) ...@@ -270,18 +269,18 @@ match_hollerith_constant (gfc_expr **result)
} }
else else
{ {
buffer = (char *) gfc_getmem (sizeof(char) * num + 1);
for (i = 0; i < num; i++)
{
buffer[i] = gfc_next_char_literal (1);
}
gfc_free_expr (e); gfc_free_expr (e);
e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind, e = gfc_constant_result (BT_HOLLERITH, gfc_default_character_kind,
&gfc_current_locus); &gfc_current_locus);
e->value.character.string = gfc_getmem (num + 1);
memcpy (e->value.character.string, buffer, num); e->representation.string = gfc_getmem (num + 1);
e->value.character.string[num] = '\0'; for (i = 0; i < num; i++)
e->value.character.length = num; {
e->representation.string[i] = gfc_next_char_literal (1);
}
e->representation.string[num] = '\0';
e->representation.length = num;
*result = e; *result = e;
return MATCH_YES; return MATCH_YES;
} }
......
gcc/fortran/target-memory.c
...@@ -220,6 +220,15 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer, ...@@ -220,6 +220,15 @@ gfc_target_encode_expr (gfc_expr *source, unsigned char *buffer,
gcc_assert (source->expr_type == EXPR_CONSTANT gcc_assert (source->expr_type == EXPR_CONSTANT
|| source->expr_type == EXPR_STRUCTURE); || source->expr_type == EXPR_STRUCTURE);
/* 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) switch (source->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
...@@ -289,8 +298,8 @@ interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result) ...@@ -289,8 +298,8 @@ interpret_array (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
} }
static int int
interpret_integer (int kind, unsigned char *buffer, size_t buffer_size, gfc_interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
mpz_t integer) mpz_t integer)
{ {
mpz_init (integer); mpz_init (integer);
...@@ -301,8 +310,8 @@ interpret_integer (int kind, unsigned char *buffer, size_t buffer_size, ...@@ -301,8 +310,8 @@ interpret_integer (int kind, unsigned char *buffer, size_t buffer_size,
} }
static int int
interpret_float (int kind, unsigned char *buffer, size_t buffer_size, gfc_interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
mpfr_t real) mpfr_t real)
{ {
mpfr_init (real); mpfr_init (real);
...@@ -314,19 +323,19 @@ interpret_float (int kind, unsigned char *buffer, size_t buffer_size, ...@@ -314,19 +323,19 @@ interpret_float (int kind, unsigned char *buffer, size_t buffer_size,
} }
static int int
interpret_complex (int kind, unsigned char *buffer, size_t buffer_size, gfc_interpret_complex (int kind, unsigned char *buffer, size_t buffer_size,
mpfr_t real, mpfr_t imaginary) mpfr_t real, mpfr_t imaginary)
{ {
int size; int size;
size = interpret_float (kind, &buffer[0], buffer_size, real); size = gfc_interpret_float (kind, &buffer[0], buffer_size, real);
size += interpret_float (kind, &buffer[size], buffer_size - size, imaginary); size += gfc_interpret_float (kind, &buffer[size], buffer_size - size, imaginary);
return size; return size;
} }
static int int
interpret_logical (int kind, unsigned char *buffer, size_t buffer_size, gfc_interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
int *logical) int *logical)
{ {
tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer, tree t = native_interpret_expr (gfc_get_logical_type (kind), buffer,
...@@ -337,8 +346,8 @@ interpret_logical (int kind, unsigned char *buffer, size_t buffer_size, ...@@ -337,8 +346,8 @@ interpret_logical (int kind, unsigned char *buffer, size_t buffer_size,
} }
static int int
interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result) gfc_interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{ {
if (result->ts.cl && result->ts.cl->length) if (result->ts.cl && result->ts.cl->length)
result->value.character.length = result->value.character.length =
...@@ -355,8 +364,8 @@ interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result ...@@ -355,8 +364,8 @@ interpret_character (unsigned char *buffer, size_t buffer_size, gfc_expr *result
} }
static int int
interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result) gfc_interpret_derived (unsigned char *buffer, size_t buffer_size, gfc_expr *result)
{ {
gfc_component *cmp; gfc_component *cmp;
gfc_constructor *head = NULL, *tail = NULL; gfc_constructor *head = NULL, *tail = NULL;
...@@ -428,24 +437,55 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size, ...@@ -428,24 +437,55 @@ gfc_target_interpret_expr (unsigned char *buffer, size_t buffer_size,
switch (result->ts.type) switch (result->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
return interpret_integer (result->ts.kind, buffer, buffer_size, result->representation.length =
result->value.integer); gfc_interpret_integer (result->ts.kind, buffer, buffer_size,
result->value.integer);
break;
case BT_REAL: case BT_REAL:
return interpret_float (result->ts.kind, buffer, buffer_size, result->representation.length =
result->value.real); gfc_interpret_float (result->ts.kind, buffer, buffer_size,
result->value.real);
break;
case BT_COMPLEX: case BT_COMPLEX:
return interpret_complex (result->ts.kind, buffer, buffer_size, result->representation.length =
result->value.complex.r, gfc_interpret_complex (result->ts.kind, buffer, buffer_size,
result->value.complex.i); result->value.complex.r,
result->value.complex.i);
break;
case BT_LOGICAL: case BT_LOGICAL:
return interpret_logical (result->ts.kind, buffer, buffer_size, result->representation.length =
&result->value.logical); gfc_interpret_logical (result->ts.kind, buffer, buffer_size,
&result->value.logical);
break;
case BT_CHARACTER: case BT_CHARACTER:
return interpret_character (buffer, buffer_size, result); result->representation.length =
gfc_interpret_character (buffer, buffer_size, result);
break;
case BT_DERIVED: case BT_DERIVED:
return interpret_derived (buffer, buffer_size, result); result->representation.length =
gfc_interpret_derived (buffer, buffer_size, result);
break;
default: default:
gfc_internal_error ("Invalid expression in gfc_target_interpret_expr."); gfc_internal_error ("Invalid expression in gfc_target_interpret_expr.");
break;
}
if (result->ts.type == BT_CHARACTER)
result->representation.string = result->value.character.string;
else
{
result->representation.string =
gfc_getmem (result->representation.length + 1);
memcpy (result->representation.string, buffer,
result->representation.length);
result->representation.string[result->representation.length] = '\0';
} }
return 0;
return result->representation.length;
} }
gcc/fortran/target-memory.h
...@@ -32,6 +32,13 @@ size_t gfc_target_expr_size (gfc_expr *); ...@@ -32,6 +32,13 @@ size_t gfc_target_expr_size (gfc_expr *);
int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t); int gfc_target_encode_expr (gfc_expr *, unsigned char *, size_t);
/* Read a target buffer into a constant expression. */ /* Read a target buffer into a constant expression. */
int gfc_interpret_integer (int, unsigned char *, size_t, mpz_t);
int gfc_interpret_float (int, unsigned char *, size_t, mpfr_t);
int gfc_interpret_complex (int, unsigned char *, size_t, mpfr_t, mpfr_t);
int gfc_interpret_logical (int, unsigned char *, size_t, int *);
int gfc_interpret_character (unsigned char *, size_t, gfc_expr *);
int gfc_interpret_derived (unsigned char *, size_t, gfc_expr *);
int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *); int gfc_target_interpret_expr (unsigned char *, size_t, gfc_expr *);
#endif /* GFC_TARGET_MEMORY_H */ #endif /* GFC_TARGET_MEMORY_H */
gcc/fortran/trans-const.c
...@@ -209,45 +209,45 @@ gfc_conv_constant_to_tree (gfc_expr * expr) ...@@ -209,45 +209,45 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
{ {
gcc_assert (expr->expr_type == EXPR_CONSTANT); gcc_assert (expr->expr_type == EXPR_CONSTANT);
/* If it is converted from Hollerith constant, we build string constant /* If it is has a prescribed memory representation, we build a string
and VIEW_CONVERT to its type. */ constant and VIEW_CONVERT to its type. */
switch (expr->ts.type) switch (expr->ts.type)
{ {
case BT_INTEGER: case BT_INTEGER:
if (expr->from_H) if (expr->representation.string)
return build1 (VIEW_CONVERT_EXPR, return build1 (VIEW_CONVERT_EXPR,
gfc_get_int_type (expr->ts.kind), gfc_get_int_type (expr->ts.kind),
gfc_build_string_const (expr->value.character.length, gfc_build_string_const (expr->representation.length,
expr->value.character.string)); expr->representation.string));
else else
return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind); return gfc_conv_mpz_to_tree (expr->value.integer, expr->ts.kind);
case BT_REAL: case BT_REAL:
if (expr->from_H) if (expr->representation.string)
return build1 (VIEW_CONVERT_EXPR, return build1 (VIEW_CONVERT_EXPR,
gfc_get_real_type (expr->ts.kind), gfc_get_real_type (expr->ts.kind),
gfc_build_string_const (expr->value.character.length, gfc_build_string_const (expr->representation.length,
expr->value.character.string)); expr->representation.string));
else else
return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind); return gfc_conv_mpfr_to_tree (expr->value.real, expr->ts.kind);
case BT_LOGICAL: case BT_LOGICAL:
if (expr->from_H) if (expr->representation.string)
return build1 (VIEW_CONVERT_EXPR, return build1 (VIEW_CONVERT_EXPR,
gfc_get_logical_type (expr->ts.kind), gfc_get_logical_type (expr->ts.kind),
gfc_build_string_const (expr->value.character.length, gfc_build_string_const (expr->representation.length,
expr->value.character.string)); expr->representation.string));
else else
return build_int_cst (gfc_get_logical_type (expr->ts.kind), return build_int_cst (gfc_get_logical_type (expr->ts.kind),
expr->value.logical); expr->value.logical);
case BT_COMPLEX: case BT_COMPLEX:
if (expr->from_H) if (expr->representation.string)
return build1 (VIEW_CONVERT_EXPR, return build1 (VIEW_CONVERT_EXPR,
gfc_get_complex_type (expr->ts.kind), gfc_get_complex_type (expr->ts.kind),
gfc_build_string_const (expr->value.character.length, gfc_build_string_const (expr->representation.length,
expr->value.character.string)); expr->representation.string));
else else
{ {
tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r, tree real = gfc_conv_mpfr_to_tree (expr->value.complex.r,
...@@ -260,10 +260,13 @@ gfc_conv_constant_to_tree (gfc_expr * expr) ...@@ -260,10 +260,13 @@ gfc_conv_constant_to_tree (gfc_expr * expr)
} }
case BT_CHARACTER: case BT_CHARACTER:
case BT_HOLLERITH:
return gfc_build_string_const (expr->value.character.length, return gfc_build_string_const (expr->value.character.length,
expr->value.character.string); expr->value.character.string);
case BT_HOLLERITH:
return gfc_build_string_const (expr->representation.length,
expr->representation.string);
default: default:
fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s", fatal_error ("gfc_conv_constant_to_tree(): invalid type: %s",
gfc_typename (&expr->ts)); gfc_typename (&expr->ts));
......
gcc/fortran/trans-expr.c
...@@ -3567,8 +3567,9 @@ is_zero_initializer_p (gfc_expr * expr) ...@@ -3567,8 +3567,9 @@ is_zero_initializer_p (gfc_expr * expr)
{ {
if (expr->expr_type != EXPR_CONSTANT) if (expr->expr_type != EXPR_CONSTANT)
return false; return false;
/* We ignore Hollerith constants for the time being. */
if (expr->from_H) /* We ignore constants with prescribed memory representations for now. */
if (expr->representation.string)
return false; return false;
switch (expr->ts.type) switch (expr->ts.type)
......
gcc/fortran/trans-stmt.c
...@@ -1139,7 +1139,8 @@ gfc_trans_integer_select (gfc_code * code) ...@@ -1139,7 +1139,8 @@ gfc_trans_integer_select (gfc_code * code)
if (cp->low) if (cp->low)
{ {
low = gfc_conv_constant_to_tree (cp->low); low = gfc_conv_mpz_to_tree (cp->low->value.integer,
cp->low->ts.kind);
/* If there's only a lower bound, set the high bound to the /* If there's only a lower bound, set the high bound to the
maximum value of the case expression. */ maximum value of the case expression. */
...@@ -1169,7 +1170,8 @@ gfc_trans_integer_select (gfc_code * code) ...@@ -1169,7 +1170,8 @@ gfc_trans_integer_select (gfc_code * code)
|| (cp->low || (cp->low
&& mpz_cmp (cp->low->value.integer, && mpz_cmp (cp->low->value.integer,
cp->high->value.integer) != 0)) cp->high->value.integer) != 0))
high = gfc_conv_constant_to_tree (cp->high); high = gfc_conv_mpz_to_tree (cp->high->value.integer,
cp->high->ts.kind);
/* Unbounded case. */ /* Unbounded case. */
if (!cp->low) if (!cp->low)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment