static int
is_hfa (ffi_type *ty)
{
if (ty->type == FFI_TYPE_STRUCT
&& ty->elements[0]
&& is_floating_type (get_homogeneous_type (ty)))
{
unsigned n = element_count (ty);
return n >= 1 && n <= 4;
}
return 0;
}
/**
* Check that the buffer pointed to by \c readback contains the
* expected transform feedback output data.
*/
static bool
check_outputs(const void *readback)
{
const float *readback_f = readback;
const int *readback_i = readback;
unsigned num_good_varyings = count_strings(test->good_varyings);
unsigned i;
unsigned output_component = 0;
unsigned float_index = 0;
unsigned int_index = 0;
bool pass = true;
for (i = 0; i < num_good_varyings; i++) {
const char *varying_name = test->good_varyings[i];
unsigned varying_size = test->expected_sizes[i]
* size_of_type(test->expected_types[i]);
if (is_floating_type(test->expected_types[i])) {
unsigned j;
for (j = 0; j < varying_size; j++) {
float actual = readback_f[output_component];
float expected
= test->expected_floats[float_index];
if (actual != expected) {
printf("Output %s element %u: "
"expected %f, got %f\n",
varying_name, j, expected,
actual);
pass = false;
}
output_component++;
float_index++;
}
} else {
unsigned j;
for (j = 0; j < varying_size; j++) {
int actual = readback_i[output_component];
int expected = test->expected_ints[int_index];
if (actual != expected) {
printf("Output %s element %u: "
"expected %i, got %i\n",
varying_name, j, expected,
actual);
pass = false;
}
output_component++;
int_index++;
}
}
}
return pass;
}
char fortran_is_intrinsic_type(type_t* t)
{
t = no_ref(t);
if (is_pointer_type(t))
t = pointer_type_get_pointee_type(t);
return (is_integer_type(t)
|| is_floating_type(t)
|| is_complex_type(t)
|| is_bool_type(t)
|| fortran_is_character_type(t));
}
/* Obtain argument values for binary operation, converting from
other types if one of them is not floating point. */
static void
value_args_as_target_float (struct value *arg1, struct value *arg2,
gdb_byte *x, struct type **eff_type_x,
gdb_byte *y, struct type **eff_type_y)
{
struct type *type1, *type2;
type1 = check_typedef (value_type (arg1));
type2 = check_typedef (value_type (arg2));
/* At least one of the arguments must be of floating-point type. */
gdb_assert (is_floating_type (type1) || is_floating_type (type2));
if (is_floating_type (type1) && is_floating_type (type2)
&& TYPE_CODE (type1) != TYPE_CODE (type2))
/* The DFP extension to the C language does not allow mixing of
* decimal float types with other float types in expressions
* (see WDTR 24732, page 12). */
error (_("Mixing decimal floating types with "
"other floating types is not allowed."));
/* Obtain value of arg1, converting from other types if necessary. */
if (is_floating_type (type1))
{
*eff_type_x = type1;
memcpy (x, value_contents (arg1), TYPE_LENGTH (type1));
}
else if (is_integral_type (type1))
{
*eff_type_x = type2;
if (TYPE_UNSIGNED (type1))
target_float_from_ulongest (x, *eff_type_x, value_as_long (arg1));
else
target_float_from_longest (x, *eff_type_x, value_as_long (arg1));
}
else
error (_("Don't know how to convert from %s to %s."), TYPE_NAME (type1),
TYPE_NAME (type2));
/* Obtain value of arg2, converting from other types if necessary. */
if (is_floating_type (type2))
{
*eff_type_y = type2;
memcpy (y, value_contents (arg2), TYPE_LENGTH (type2));
}
else if (is_integral_type (type2))
{
*eff_type_y = type1;
if (TYPE_UNSIGNED (type2))
target_float_from_ulongest (y, *eff_type_y, value_as_long (arg2));
else
target_float_from_longest (y, *eff_type_y, value_as_long (arg2));
}
else
error (_("Don't know how to convert from %s to %s."), TYPE_NAME (type1),
TYPE_NAME (type2));
}
static int
is_v_register_candidate (ffi_type *ty)
{
return is_floating_type (ty->type)
|| (ty->type == FFI_TYPE_STRUCT && is_hfa (ty));
}
const char* fortran_print_type_str(type_t* t)
{
t = no_ref(t);
if (is_error_type(t))
{
return "<error-type>";
}
if (is_hollerith_type(t))
{
return "HOLLERITH";
}
const char* result = "";
char is_pointer = 0;
if (is_pointer_type(t))
{
is_pointer = 1;
t = pointer_type_get_pointee_type(t);
}
struct array_spec_tag {
nodecl_t lower;
nodecl_t upper;
char is_undefined;
} array_spec_list[MCXX_MAX_ARRAY_SPECIFIER] = { { nodecl_null(), nodecl_null(), 0 } };
int array_spec_idx;
for (array_spec_idx = MCXX_MAX_ARRAY_SPECIFIER - 1;
fortran_is_array_type(t);
array_spec_idx--)
{
if (array_spec_idx < 0)
{
internal_error("too many array dimensions %d\n", MCXX_MAX_ARRAY_SPECIFIER);
}
if (!array_type_is_unknown_size(t))
{
array_spec_list[array_spec_idx].lower = array_type_get_array_lower_bound(t);
array_spec_list[array_spec_idx].upper = array_type_get_array_upper_bound(t);
}
else
{
array_spec_list[array_spec_idx].is_undefined = 1;
}
t = array_type_get_element_type(t);
}
char is_array = (array_spec_idx != (MCXX_MAX_ARRAY_SPECIFIER - 1));
if (is_bool_type(t)
|| is_integer_type(t)
|| is_floating_type(t)
|| is_double_type(t)
|| is_complex_type(t))
{
const char* type_name = NULL;
char c[128] = { 0 };
if (is_bool_type(t))
{
type_name = "LOGICAL";
}
else if (is_integer_type(t))
{
type_name = "INTEGER";
}
else if (is_floating_type(t))
{
type_name = "REAL";
}
else if (is_complex_type(t))
{
type_name = "COMPLEX";
}
else
{
internal_error("unreachable code", 0);
}
size_t size = type_get_size(t);
if (is_floating_type(t))
{
// KIND of floats is their size in byes (using the bits as in IEEE754)
size = (floating_type_get_info(t)->bits) / 8;
}
else if (is_complex_type(t))
{
// KIND of a complex is the KIND of its component type
type_t* f = complex_type_get_base_type(t);
size = (floating_type_get_info(f)->bits) / 8;
}
snprintf(c, 127, "%s(%zd)", type_name, size);
c[127] = '\0';
result = uniquestr(c);
}
else if (is_class_type(t))
{
scope_entry_t* entry = named_type_get_symbol(t);
char c[128] = { 0 };
snprintf(c, 127, "TYPE(%s)",
entry->symbol_name);
c[127] = '\0';
result = uniquestr(c);
}
else if (fortran_is_character_type(t))
{
nodecl_t length = array_type_get_array_size_expr(t);
char c[128] = { 0 };
snprintf(c, 127, "CHARACTER(LEN=%s)",
nodecl_is_null(length) ? "*" : codegen_to_str(length, nodecl_retrieve_context(length)));
c[127] = '\0';
result = uniquestr(c);
}
else if (is_function_type(t))
{
result = "PROCEDURE";
}
else
{
const char* non_printable = NULL;
uniquestr_sprintf(&non_printable, "non-fortran type '%s'", print_declarator(t));
return non_printable;
}
if (is_pointer)
{
result = strappend(result, ", POINTER");
}
if (is_array)
{
array_spec_idx++;
result = strappend(result, ", DIMENSION(");
while (array_spec_idx <= (MCXX_MAX_ARRAY_SPECIFIER - 1))
{
if (!array_spec_list[array_spec_idx].is_undefined)
{
result = strappend(result, codegen_to_str(array_spec_list[array_spec_idx].lower,
nodecl_retrieve_context(array_spec_list[array_spec_idx].lower)));
result = strappend(result, ":");
result = strappend(result, codegen_to_str(array_spec_list[array_spec_idx].upper,
nodecl_retrieve_context(array_spec_list[array_spec_idx].upper)));
}
else
{
result = strappend(result, ":");
}
if ((array_spec_idx + 1) <= (MCXX_MAX_ARRAY_SPECIFIER - 1))
{
result = strappend(result, ", ");
}
array_spec_idx++;
}
result = strappend(result, ")");
}
return result;
}
void
check_format_string(struct token *tok,
struct type *fty,
struct ty_func *fdecl,
struct vreg **args,
struct token **from_consts,
int nargs) {
struct attrib *a;
struct ty_string *ts;
int i;
int fmtidx;
int checkidx;
int cur_checkidx;
a = lookup_attr(fty->attributes, ATTRF_FORMAT);
assert(a != NULL);
fmtidx = a->iarg2;
checkidx = a->iarg3;
if (fdecl->nargs == -1) {
/* Function takes no parameters?! */
return;
}
if (fmtidx + 1 > nargs) {
/* No format string passed?! */
return;
}
if (checkidx + 1 > nargs) {
/* No arguments to check */
return;
}
cur_checkidx = checkidx;
if (from_consts[fmtidx] == NULL) {
/*
* Format string isn't a string constant so we can't
* check it
*/
return;
}
ts = from_consts[fmtidx]->data;
for (i = 0; i < (int)ts->size; ++i) {
if (ts->str[i] == '%') {
if (i + 1 == (int)ts->size) {
warningfl(tok, "Invalid trailing `%%' char "
"without conversion specifier");
} else if (ts->str[i + 1] == '%') {
/* % char */
++i;
} else {
struct type *passed_ty;
int ch = 0;
char *p = NULL;
if (cur_checkidx + 1 > nargs) {
warningfl(tok, "Format specifier "
"%d has no corresponding "
"argument!",
cur_checkidx - checkidx);
++cur_checkidx;
continue;
}
passed_ty = args[cur_checkidx]->type;
/*
* We only handle simple obvious cases for
* now, i.e. %s vs int argument, %d vs
* string argument, etc.
*/
if (ts->str[i + 1] == 'l') {
if (i + 2 == (int)ts->size) {
warningfl(tok, "Incomplete "
"conversion specifier "
"`%%l'");
} else if (ts->str[i + 2] == 'l') {
if (i + 3 == (int)ts->size) {
warningfl(tok, "Incomplete "
"conversion specifier "
"`%%ll'");
} else {
ch = get_type_by_fmt(
ts->str[i+1],
ts->str[i+2],
ts->str[i+3]);
}
} else {
ch = get_type_by_fmt(
ts->str[i+1],
ts->str[i+2],
0);
}
} else {
ch = get_type_by_fmt(ts->str[i+1], 0, 0);
}
switch (ch) {
case TY_INT:
case TY_UINT:
case TY_LONG:
case TY_ULONG:
case TY_LLONG:
case TY_ULLONG:
if (!is_integral_type(passed_ty)) {
p = type_to_text(passed_ty);
warningfl(tok, "Format "
"specifier %d expects integral "
"type, but received argument "
"of type `%s'",
cur_checkidx-checkidx+1,
p);
} else {
static struct type dummy;
char *p2;
/* OK, both are integral */
if ( (IS_INT(ch)
&& IS_LONG(passed_ty->code))
|| (IS_LONG(ch)
&& IS_INT(passed_ty->code))) {
static int warned;
dummy.code = ch;
p = type_to_text(passed_ty);
p2 = type_to_text(&dummy);
/*
* Keep the number of
* warnings down because
* this can happen lots
* of times with %d vs
* size_t; That will
* work on all supported
* systems, and a user
* who cares will pay
* attention to 1 warning
* just as well
*/
if (!warned) {
warningfl(tok,
"Format specifier %d expects argument of type `%s', but received `%s'",
cur_checkidx-checkidx+1,
p2, p);
warned = 1;
}
free(p2);
} else if (IS_LLONG(ch)
!= IS_LLONG(passed_ty->code)) {
dummy.code = ch;
p = type_to_text(passed_ty);
p2 = type_to_text(&dummy);
warningfl(tok, "Format specifier %d expects argument of type `%s', but received `%s'",
cur_checkidx-checkidx+1,
p2, p);
free(p2);
}
}
break;
case TY_DOUBLE:
case TY_LDOUBLE:
if (!is_floating_type(passed_ty)) {
p = type_to_text(passed_ty);
warningfl(tok, "Format "
"specifier %d expects floating "
"point type, but received "
"argument of type `%s'",
cur_checkidx-checkidx+1,
p);
} else if (passed_ty->code != ch) {
p = type_to_text(passed_ty);
warningfl(tok, "Format "
"specifier %d expects type "
"`%s', but received argument "
"of type `%s'",
cur_checkidx-checkidx+1,
ch == TY_DOUBLE? "double":
"long double",
p);
}
break;
default:
if (ts->str[i+1] == 's') {
if (passed_ty->tlist == NULL
|| (passed_ty->tlist->type != TN_ARRAY_OF
&& passed_ty->tlist->type != TN_POINTER_TO)
|| passed_ty->tlist->next != NULL
|| passed_ty->code != TY_CHAR
|| passed_ty->code != TY_VOID) {
p = type_to_text(passed_ty);
warningfl(tok, "Format "
"specifier %d expects string, "
"but received argument of type "
"`%s'",
cur_checkidx-checkidx+1,
p);
}
}
break;
}
if (p != NULL) {
free(p);
}
++cur_checkidx;
}
}
}
}
static struct value *
scalar_binop (struct value *arg1, struct value *arg2, enum exp_opcode op)
{
struct value *val;
struct type *type1, *type2, *result_type;
arg1 = coerce_ref (arg1);
arg2 = coerce_ref (arg2);
type1 = check_typedef (value_type (arg1));
type2 = check_typedef (value_type (arg2));
if ((!is_floating_value (arg1) && !is_integral_type (type1))
|| (!is_floating_value (arg2) && !is_integral_type (type2)))
error (_("Argument to arithmetic operation not a number or boolean."));
if (is_floating_type (type1) || is_floating_type (type2))
{
/* If only one type is floating-point, use its type.
Otherwise use the bigger type. */
if (!is_floating_type (type1))
result_type = type2;
else if (!is_floating_type (type2))
result_type = type1;
else if (TYPE_LENGTH (type2) > TYPE_LENGTH (type1))
result_type = type2;
else
result_type = type1;
val = allocate_value (result_type);
struct type *eff_type_v1, *eff_type_v2;
gdb::byte_vector v1, v2;
v1.resize (TYPE_LENGTH (result_type));
v2.resize (TYPE_LENGTH (result_type));
value_args_as_target_float (arg1, arg2,
v1.data (), &eff_type_v1,
v2.data (), &eff_type_v2);
target_float_binop (op, v1.data (), eff_type_v1,
v2.data (), eff_type_v2,
value_contents_raw (val), result_type);
}
else if (TYPE_CODE (type1) == TYPE_CODE_BOOL
|| TYPE_CODE (type2) == TYPE_CODE_BOOL)
{
LONGEST v1, v2, v = 0;
v1 = value_as_long (arg1);
v2 = value_as_long (arg2);
switch (op)
{
case BINOP_BITWISE_AND:
v = v1 & v2;
break;
case BINOP_BITWISE_IOR:
v = v1 | v2;
break;
case BINOP_BITWISE_XOR:
v = v1 ^ v2;
break;
case BINOP_EQUAL:
v = v1 == v2;
break;
case BINOP_NOTEQUAL:
v = v1 != v2;
break;
default:
error (_("Invalid operation on booleans."));
}
result_type = type1;
val = allocate_value (result_type);
store_signed_integer (value_contents_raw (val),
TYPE_LENGTH (result_type),
gdbarch_byte_order (get_type_arch (result_type)),
v);
}
else
/* Integral operations here. */
{
/* Determine type length of the result, and if the operation should
be done unsigned. For exponentiation and shift operators,
use the length and type of the left operand. Otherwise,
use the signedness of the operand with the greater length.
If both operands are of equal length, use unsigned operation
if one of the operands is unsigned. */
if (op == BINOP_RSH || op == BINOP_LSH || op == BINOP_EXP)
result_type = type1;
else if (TYPE_LENGTH (type1) > TYPE_LENGTH (type2))
result_type = type1;
else if (TYPE_LENGTH (type2) > TYPE_LENGTH (type1))
result_type = type2;
else if (TYPE_UNSIGNED (type1))
result_type = type1;
else if (TYPE_UNSIGNED (type2))
result_type = type2;
else
result_type = type1;
if (TYPE_UNSIGNED (result_type))
{
LONGEST v2_signed = value_as_long (arg2);
ULONGEST v1, v2, v = 0;
v1 = (ULONGEST) value_as_long (arg1);
v2 = (ULONGEST) v2_signed;
switch (op)
{
case BINOP_ADD:
v = v1 + v2;
break;
case BINOP_SUB:
v = v1 - v2;
break;
case BINOP_MUL:
v = v1 * v2;
break;
case BINOP_DIV:
case BINOP_INTDIV:
if (v2 != 0)
v = v1 / v2;
else
error (_("Division by zero"));
break;
case BINOP_EXP:
v = uinteger_pow (v1, v2_signed);
break;
case BINOP_REM:
if (v2 != 0)
v = v1 % v2;
else
error (_("Division by zero"));
break;
case BINOP_MOD:
/* Knuth 1.2.4, integer only. Note that unlike the C '%' op,
v1 mod 0 has a defined value, v1. */
if (v2 == 0)
{
v = v1;
}
else
{
v = v1 / v2;
/* Note floor(v1/v2) == v1/v2 for unsigned. */
v = v1 - (v2 * v);
}
break;
case BINOP_LSH:
v = v1 << v2;
break;
case BINOP_RSH:
v = v1 >> v2;
break;
case BINOP_BITWISE_AND:
v = v1 & v2;
break;
case BINOP_BITWISE_IOR:
v = v1 | v2;
break;
case BINOP_BITWISE_XOR:
v = v1 ^ v2;
break;
case BINOP_LOGICAL_AND:
v = v1 && v2;
break;
case BINOP_LOGICAL_OR:
v = v1 || v2;
break;
case BINOP_MIN:
v = v1 < v2 ? v1 : v2;
break;
case BINOP_MAX:
v = v1 > v2 ? v1 : v2;
break;
case BINOP_EQUAL:
v = v1 == v2;
break;
case BINOP_NOTEQUAL:
v = v1 != v2;
break;
case BINOP_LESS:
v = v1 < v2;
break;
case BINOP_GTR:
v = v1 > v2;
break;
case BINOP_LEQ:
v = v1 <= v2;
break;
case BINOP_GEQ:
v = v1 >= v2;
break;
default:
error (_("Invalid binary operation on numbers."));
}
val = allocate_value (result_type);
store_unsigned_integer (value_contents_raw (val),
TYPE_LENGTH (value_type (val)),
gdbarch_byte_order
(get_type_arch (result_type)),
v);
}
else
{
LONGEST v1, v2, v = 0;
v1 = value_as_long (arg1);
v2 = value_as_long (arg2);
switch (op)
{
case BINOP_ADD:
v = v1 + v2;
break;
case BINOP_SUB:
v = v1 - v2;
break;
case BINOP_MUL:
v = v1 * v2;
break;
case BINOP_DIV:
case BINOP_INTDIV:
if (v2 != 0)
v = v1 / v2;
else
error (_("Division by zero"));
break;
case BINOP_EXP:
v = integer_pow (v1, v2);
break;
case BINOP_REM:
if (v2 != 0)
v = v1 % v2;
else
error (_("Division by zero"));
break;
case BINOP_MOD:
/* Knuth 1.2.4, integer only. Note that unlike the C '%' op,
X mod 0 has a defined value, X. */
if (v2 == 0)
{
v = v1;
}
else
{
v = v1 / v2;
/* Compute floor. */
if (TRUNCATION_TOWARDS_ZERO && (v < 0) && ((v1 % v2) != 0))
{
v--;
}
v = v1 - (v2 * v);
}
break;
case BINOP_LSH:
v = v1 << v2;
break;
case BINOP_RSH:
v = v1 >> v2;
break;
case BINOP_BITWISE_AND:
v = v1 & v2;
break;
case BINOP_BITWISE_IOR:
v = v1 | v2;
break;
case BINOP_BITWISE_XOR:
v = v1 ^ v2;
break;
case BINOP_LOGICAL_AND:
v = v1 && v2;
break;
case BINOP_LOGICAL_OR:
v = v1 || v2;
break;
case BINOP_MIN:
v = v1 < v2 ? v1 : v2;
break;
case BINOP_MAX:
v = v1 > v2 ? v1 : v2;
break;
case BINOP_EQUAL:
v = v1 == v2;
break;
case BINOP_NOTEQUAL:
v = v1 != v2;
break;
case BINOP_LESS:
v = v1 < v2;
break;
case BINOP_GTR:
v = v1 > v2;
break;
case BINOP_LEQ:
v = v1 <= v2;
break;
case BINOP_GEQ:
v = v1 >= v2;
break;
default:
error (_("Invalid binary operation on numbers."));
}
val = allocate_value (result_type);
store_signed_integer (value_contents_raw (val),
TYPE_LENGTH (value_type (val)),
gdbarch_byte_order
(get_type_arch (result_type)),
v);
}
}
