#include "proj.h"
#include "target.h"
#include "diagnostic.h"
#include "bad.h"
#include "info.h"
#include "lex.h"
#include "malloc.h"
#include "real.h"
char ffetarget_string_[40];
HOST_WIDE_INT ffetarget_long_val_;
HOST_WIDE_INT ffetarget_long_junk_;
static void ffetarget_print_char_ (FILE *f, unsigned char c);
#ifdef REAL_VALUE_ATOF
#define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m))
#else
#define FFETARGET_ATOF_(p,m) atof ((p))
#endif
static void
ffetarget_print_char_ (FILE *f, unsigned char c)
{
switch (c)
{
case '\\':
fputs ("\\\\", f);
break;
case '\'':
fputs ("\\\'", f);
break;
default:
if (ISPRINT (c))
fputc (c, f);
else
fprintf (f, "\\%03o", (unsigned int) c);
break;
}
}
void
ffetarget_aggregate_info (ffeinfoBasictype *ebt, ffeinfoKindtype *ekt,
ffetargetAlign *units, ffeinfoBasictype abt,
ffeinfoKindtype akt)
{
ffetype type;
if ((abt == FFEINFO_basictypeNONE) || (abt == FFEINFO_basictypeANY)
|| (akt == FFEINFO_kindtypeNONE))
{
*ebt = FFEINFO_basictypeCHARACTER;
*ekt = FFEINFO_kindtypeCHARACTERDEFAULT;
}
else
{
*ebt = abt;
*ekt = akt;
}
type = ffeinfo_type (*ebt, *ekt);
assert (type != NULL);
*units = ffetype_size (type);
}
ffetargetAlign
ffetarget_align (ffetargetAlign *updated_alignment,
ffetargetAlign *updated_modulo, ffetargetOffset offset,
ffetargetAlign alignment, ffetargetAlign modulo)
{
ffetargetAlign pad;
ffetargetAlign min_pad;
ffetargetAlign min_m = 0;
ffetargetAlign ua;
ffetargetAlign um;
ffetargetAlign ucnt;
ffetargetAlign m;
ffetargetAlign cnt;
ffetargetAlign i;
ffetargetAlign j;
assert (alignment > 0);
assert (*updated_alignment > 0);
assert (*updated_modulo < *updated_alignment);
assert (modulo < alignment);
if (*updated_alignment == alignment)
{
if (modulo > *updated_modulo)
pad = alignment - (modulo - *updated_modulo);
else
pad = *updated_modulo - modulo;
if (offset < 0)
offset = alignment - ((- offset) % alignment);
pad = (offset + pad) % alignment;
if (pad != 0)
pad = alignment - pad;
return pad;
}
for (ua = *updated_alignment, ucnt = 1;
ua % alignment != 0;
ua += *updated_alignment)
++ucnt;
cnt = ua / alignment;
if (offset < 0)
offset = ua - ((- offset) % ua);
min_pad = ~(ffetargetAlign) 0;
for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i)
{
for (m = modulo, j = 0; j < cnt; m += alignment, ++j)
{
if (m > um)
pad = ua - (m - um);
else
pad = um - m;
pad = (offset + pad) % ua;
if (pad == 0)
{
*updated_alignment = ua;
*updated_modulo = um;
return 0;
}
pad = ua - pad;
if (pad < min_pad)
{
min_pad = pad;
min_m = um;
}
}
}
*updated_alignment = ua;
*updated_modulo = min_m;
return min_pad;
}
#if FFETARGET_okCHARACTER1
bool
ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
mallocPool pool)
{
val->length = ffelex_token_length (character);
if (val->length == 0)
val->text = NULL;
else
{
val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length + 1);
memcpy (val->text, ffelex_token_text (character), val->length);
val->text[val->length] = '\0';
}
return TRUE;
}
#endif
#if FFETARGET_okCHARACTER1
int
ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r)
{
if (l.length < r.length)
return -1;
if (l.length > r.length)
return 1;
if (l.length == 0)
return 0;
return memcmp (l.text, r.text, l.length);
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_concatenate_character1 (ffetargetCharacter1 *res,
ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool,
ffetargetCharacterSize *len)
{
res->length = *len = l.length + r.length;
if (*len == 0)
res->text = NULL;
else
{
res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len + 1);
if (l.length != 0)
memcpy (res->text, l.text, l.length);
if (r.length != 0)
memcpy (res->text + l.length, r.text, r.length);
res->text[*len] = '\0';
}
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_eq_character1 (bool *res, ffetargetCharacter1 l,
ffetargetCharacter1 r)
{
assert (l.length == r.length);
*res = (memcmp (l.text, r.text, l.length) == 0);
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_le_character1 (bool *res, ffetargetCharacter1 l,
ffetargetCharacter1 r)
{
assert (l.length == r.length);
*res = (memcmp (l.text, r.text, l.length) <= 0);
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_lt_character1 (bool *res, ffetargetCharacter1 l,
ffetargetCharacter1 r)
{
assert (l.length == r.length);
*res = (memcmp (l.text, r.text, l.length) < 0);
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_ge_character1 (bool *res, ffetargetCharacter1 l,
ffetargetCharacter1 r)
{
assert (l.length == r.length);
*res = (memcmp (l.text, r.text, l.length) >= 0);
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_gt_character1 (bool *res, ffetargetCharacter1 l,
ffetargetCharacter1 r)
{
assert (l.length == r.length);
*res = (memcmp (l.text, r.text, l.length) > 0);
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
bool
ffetarget_iszero_character1 (ffetargetCharacter1 constant)
{
ffetargetCharacterSize i;
for (i = 0; i < constant.length; ++i)
if (constant.text[i] != 0)
return FALSE;
return TRUE;
}
#endif
bool
ffetarget_iszero_hollerith (ffetargetHollerith constant)
{
ffetargetHollerithSize i;
for (i = 0; i < constant.length; ++i)
if (constant.text[i] != 0)
return FALSE;
return TRUE;
}
void
ffetarget_layout (const char *error_text UNUSED, ffetargetAlign *alignment,
ffetargetAlign *modulo, ffetargetOffset *size,
ffeinfoBasictype bt, ffeinfoKindtype kt,
ffetargetCharacterSize charsize,
ffetargetIntegerDefault num_elements)
{
bool ok;
ffetargetOffset numele;
ffetype type;
type = ffeinfo_type (bt, kt);
assert (type != NULL);
*alignment = ffetype_alignment (type);
*modulo = ffetype_modulo (type);
if (bt == FFEINFO_basictypeCHARACTER)
{
ok = ffetarget_offset_charsize (size, charsize, ffetype_size (type));
#ifdef ffetarget_offset_overflow
if (!ok)
ffetarget_offset_overflow (error_text);
#endif
}
else
*size = ffetype_size (type);
if ((num_elements < 0)
|| !ffetarget_offset (&numele, num_elements)
|| !ffetarget_offset_multiply (size, *size, numele))
{
ffetarget_offset_overflow (error_text);
*alignment = 1;
*modulo = 0;
*size = 0;
}
}
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_ne_character1 (bool *res, ffetargetCharacter1 l,
ffetargetCharacter1 r)
{
assert (l.length == r.length);
*res = (memcmp (l.text, r.text, l.length) != 0);
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_substr_character1 (ffetargetCharacter1 *res,
ffetargetCharacter1 l,
ffetargetCharacterSize first,
ffetargetCharacterSize last, mallocPool pool,
ffetargetCharacterSize *len)
{
if (last < first)
{
res->length = *len = 0;
res->text = NULL;
}
else
{
res->length = *len = last - first + 1;
res->text = malloc_new_kp (pool, "ffetargetCharacter1(SUBSTR)", *len + 1);
memcpy (res->text, l.text + first - 1, *len);
res->text[*len] = '\0';
}
return FFEBAD;
}
#endif
int
ffetarget_cmp_hollerith (ffetargetHollerith l, ffetargetHollerith r)
{
if (l.length < r.length)
return -1;
if (l.length > r.length)
return 1;
return memcmp (l.text, r.text, l.length);
}
ffebad
ffetarget_convert_any_character1_ (char *res, size_t size,
ffetargetCharacter1 l)
{
if (size <= (size_t) l.length)
{
char *p;
ffetargetCharacterSize i;
memcpy (res, l.text, size);
for (p = &l.text[0] + size, i = l.length - size;
i > 0;
++p, --i)
if (*p != ' ')
return FFEBAD_TRUNCATING_CHARACTER;
}
else
{
memcpy (res, l.text, size);
memset (res + l.length, ' ', size - l.length);
}
return FFEBAD;
}
ffebad
ffetarget_convert_any_hollerith_ (char *res, size_t size,
ffetargetHollerith l)
{
if (size <= (size_t) l.length)
{
char *p;
ffetargetCharacterSize i;
memcpy (res, l.text, size);
for (p = &l.text[0] + size, i = l.length - size;
i > 0;
++p, --i)
if (*p != ' ')
return FFEBAD_TRUNCATING_HOLLERITH;
}
else
{
memcpy (res, l.text, size);
memset (res + l.length, ' ', size - l.length);
}
return FFEBAD;
}
ffebad
ffetarget_convert_any_typeless_ (char *res, size_t size,
ffetargetTypeless l)
{
unsigned long long int l1;
unsigned long int l2;
unsigned int l3;
unsigned short int l4;
unsigned char l5;
size_t size_of;
char *p;
if (size >= sizeof (l1))
{
l1 = l;
p = (char *) &l1;
size_of = sizeof (l1);
}
else if (size >= sizeof (l2))
{
l2 = l;
p = (char *) &l2;
size_of = sizeof (l2);
l1 = l2;
}
else if (size >= sizeof (l3))
{
l3 = l;
p = (char *) &l3;
size_of = sizeof (l3);
l1 = l3;
}
else if (size >= sizeof (l4))
{
l4 = l;
p = (char *) &l4;
size_of = sizeof (l4);
l1 = l4;
}
else if (size >= sizeof (l5))
{
l5 = l;
p = (char *) &l5;
size_of = sizeof (l5);
l1 = l5;
}
else
{
assert ("stumped by conversion from typeless!" == NULL);
abort ();
}
if (size <= size_of)
{
int i = size_of - size;
memcpy (res, p + i, size);
for (; i > 0; ++p, --i)
if (*p != '\0')
return FFEBAD_TRUNCATING_TYPELESS;
}
else
{
int i = size - size_of;
memset (res, 0, i);
memcpy (res + i, p, size_of);
}
if (l1 != l)
return FFEBAD_TRUNCATING_TYPELESS;
return FFEBAD;
}
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_convert_character1_character1 (ffetargetCharacter1 *res,
ffetargetCharacterSize size,
ffetargetCharacter1 l,
mallocPool pool)
{
res->length = size;
if (size == 0)
res->text = NULL;
else
{
res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
if (size <= l.length)
memcpy (res->text, l.text, size);
else
{
memcpy (res->text, l.text, l.length);
memset (res->text + l.length, ' ', size - l.length);
}
res->text[size] = '\0';
}
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
ffetargetCharacterSize size,
ffetargetHollerith l, mallocPool pool)
{
res->length = size;
if (size == 0)
res->text = NULL;
else
{
res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
res->text[size] = '\0';
if (size <= l.length)
{
char *p;
ffetargetCharacterSize i;
memcpy (res->text, l.text, size);
for (p = &l.text[0] + size, i = l.length - size;
i > 0;
++p, --i)
if (*p != ' ')
return FFEBAD_TRUNCATING_HOLLERITH;
}
else
{
memcpy (res->text, l.text, l.length);
memset (res->text + l.length, ' ', size - l.length);
}
}
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_convert_character1_integer4 (ffetargetCharacter1 *res,
ffetargetCharacterSize size,
ffetargetInteger4 l, mallocPool pool)
{
long long int l1;
long int l2;
int l3;
short int l4;
char l5;
size_t size_of;
char *p;
if (((size_t) size) >= sizeof (l1))
{
l1 = l;
p = (char *) &l1;
size_of = sizeof (l1);
}
else if (((size_t) size) >= sizeof (l2))
{
l2 = l;
p = (char *) &l2;
size_of = sizeof (l2);
l1 = l2;
}
else if (((size_t) size) >= sizeof (l3))
{
l3 = l;
p = (char *) &l3;
size_of = sizeof (l3);
l1 = l3;
}
else if (((size_t) size) >= sizeof (l4))
{
l4 = l;
p = (char *) &l4;
size_of = sizeof (l4);
l1 = l4;
}
else if (((size_t) size) >= sizeof (l5))
{
l5 = l;
p = (char *) &l5;
size_of = sizeof (l5);
l1 = l5;
}
else
{
assert ("stumped by conversion from integer1!" == NULL);
abort ();
}
res->length = size;
if (size == 0)
res->text = NULL;
else
{
res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
res->text[size] = '\0';
if (((size_t) size) <= size_of)
{
int i = size_of - size;
memcpy (res->text, p + i, size);
for (; i > 0; ++p, --i)
if (*p != 0)
return FFEBAD_TRUNCATING_NUMERIC;
}
else
{
int i = size - size_of;
memset (res->text, 0, i);
memcpy (res->text + i, p, size_of);
}
}
if (l1 != l)
return FFEBAD_TRUNCATING_NUMERIC;
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_convert_character1_logical4 (ffetargetCharacter1 *res,
ffetargetCharacterSize size,
ffetargetLogical4 l, mallocPool pool)
{
long long int l1;
long int l2;
int l3;
short int l4;
char l5;
size_t size_of;
char *p;
if (((size_t) size) >= sizeof (l1))
{
l1 = l;
p = (char *) &l1;
size_of = sizeof (l1);
}
else if (((size_t) size) >= sizeof (l2))
{
l2 = l;
p = (char *) &l2;
size_of = sizeof (l2);
l1 = l2;
}
else if (((size_t) size) >= sizeof (l3))
{
l3 = l;
p = (char *) &l3;
size_of = sizeof (l3);
l1 = l3;
}
else if (((size_t) size) >= sizeof (l4))
{
l4 = l;
p = (char *) &l4;
size_of = sizeof (l4);
l1 = l4;
}
else if (((size_t) size) >= sizeof (l5))
{
l5 = l;
p = (char *) &l5;
size_of = sizeof (l5);
l1 = l5;
}
else
{
assert ("stumped by conversion from logical1!" == NULL);
abort ();
}
res->length = size;
if (size == 0)
res->text = NULL;
else
{
res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
res->text[size] = '\0';
if (((size_t) size) <= size_of)
{
int i = size_of - size;
memcpy (res->text, p + i, size);
for (; i > 0; ++p, --i)
if (*p != 0)
return FFEBAD_TRUNCATING_NUMERIC;
}
else
{
int i = size - size_of;
memset (res->text, 0, i);
memcpy (res->text + i, p, size_of);
}
}
if (l1 != l)
return FFEBAD_TRUNCATING_NUMERIC;
return FFEBAD;
}
#endif
#if FFETARGET_okCHARACTER1
ffebad
ffetarget_convert_character1_typeless (ffetargetCharacter1 *res,
ffetargetCharacterSize size,
ffetargetTypeless l, mallocPool pool)
{
unsigned long long int l1;
unsigned long int l2;
unsigned int l3;
unsigned short int l4;
unsigned char l5;
size_t size_of;
char *p;
if (((size_t) size) >= sizeof (l1))
{
l1 = l;
p = (char *) &l1;
size_of = sizeof (l1);
}
else if (((size_t) size) >= sizeof (l2))
{
l2 = l;
p = (char *) &l2;
size_of = sizeof (l2);
l1 = l2;
}
else if (((size_t) size) >= sizeof (l3))
{
l3 = l;
p = (char *) &l3;
size_of = sizeof (l3);
l1 = l3;
}
else if (((size_t) size) >= sizeof (l4))
{
l4 = l;
p = (char *) &l4;
size_of = sizeof (l4);
l1 = l4;
}
else if (((size_t) size) >= sizeof (l5))
{
l5 = l;
p = (char *) &l5;
size_of = sizeof (l5);
l1 = l5;
}
else
{
assert ("stumped by conversion from typeless!" == NULL);
abort ();
}
res->length = size;
if (size == 0)
res->text = NULL;
else
{
res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size + 1);
res->text[size] = '\0';
if (((size_t) size) <= size_of)
{
int i = size_of - size;
memcpy (res->text, p + i, size);
for (; i > 0; ++p, --i)
if (*p != 0)
return FFEBAD_TRUNCATING_TYPELESS;
}
else
{
int i = size - size_of;
memset (res->text, 0, i);
memcpy (res->text + i, p, size_of);
}
}
if (l1 != l)
return FFEBAD_TRUNCATING_TYPELESS;
return FFEBAD;
}
#endif
#if FFETARGET_okCOMPLEX1
ffebad
ffetarget_divide_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
ffetargetComplex1 r)
{
ffebad bad;
ffetargetReal1 tmp1, tmp2, tmp3, tmp4;
bad = ffetarget_multiply_real1 (&tmp1, r.real, r.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, r.imaginary, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real1 (&tmp3, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
if (ffetarget_iszero_real1 (tmp3))
{
ffetarget_real1_zero (&(res)->real);
ffetarget_real1_zero (&(res)->imaginary);
return FFEBAD_DIV_BY_ZERO;
}
bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real1 (&tmp4, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_divide_real1 (&res->real, tmp4, tmp3);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp1, r.real, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real1 (&tmp4, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_divide_real1 (&res->imaginary, tmp4, tmp3);
return FFEBAD;
}
#endif
#if FFETARGET_okCOMPLEX2
ffebad
ffetarget_divide_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
ffetargetComplex2 r)
{
ffebad bad;
ffetargetReal2 tmp1, tmp2, tmp3, tmp4;
bad = ffetarget_multiply_real2 (&tmp1, r.real, r.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, r.imaginary, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real2 (&tmp3, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
if (ffetarget_iszero_real2 (tmp3))
{
ffetarget_real2_zero (&(res)->real);
ffetarget_real2_zero (&(res)->imaginary);
return FFEBAD_DIV_BY_ZERO;
}
bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real2 (&tmp4, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_divide_real2 (&res->real, tmp4, tmp3);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp1, r.real, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real2 (&tmp4, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_divide_real2 (&res->imaginary, tmp4, tmp3);
return FFEBAD;
}
#endif
bool
ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer,
mallocPool pool)
{
val->length = ffelex_token_length (integer);
val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length + 1);
memcpy (val->text, ffelex_token_text (integer), val->length);
val->text[val->length] = '\0';
return TRUE;
}
void
ffetarget_integer_bad_magical (ffelexToken t)
{
ffebad_start (FFEBAD_BAD_MAGICAL);
ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
ffebad_finish ();
}
void
ffetarget_integer_bad_magical_binary (ffelexToken integer,
ffelexToken minus)
{
ffebad_start (FFEBAD_BAD_MAGICAL_BINARY);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_here (1, ffelex_token_where_line (minus),
ffelex_token_where_column (minus));
ffebad_finish ();
}
void
ffetarget_integer_bad_magical_precedence (ffelexToken integer,
ffelexToken uminus,
ffelexToken higher_op)
{
ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_here (1, ffelex_token_where_line (uminus),
ffelex_token_where_column (uminus));
ffebad_here (2, ffelex_token_where_line (higher_op),
ffelex_token_where_column (higher_op));
ffebad_finish ();
}
void
ffetarget_integer_bad_magical_precedence_binary (ffelexToken integer,
ffelexToken minus,
ffelexToken higher_op)
{
ffebad_start (FFEBAD_BAD_MAGICAL_PRECEDENCE_BINARY);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_here (1, ffelex_token_where_line (minus),
ffelex_token_where_column (minus));
ffebad_here (2, ffelex_token_where_line (higher_op),
ffelex_token_where_column (higher_op));
ffebad_finish ();
}
#if FFETARGET_okINTEGER1
bool
ffetarget_integer1 (ffetargetInteger1 *val, ffelexToken integer)
{
ffetargetInteger1 x;
char *p;
char c;
assert (ffelex_token_type (integer) == FFELEX_typeNUMBER);
p = ffelex_token_text (integer);
x = 0;
while (((c = *p) != '\0') && (c == '0'))
++p;
while (c != '\0')
{
if ((x == FFETARGET_integerALMOST_BIG_MAGICAL)
&& (c == '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
&& (*(p + 1) == '\0'))
{
*val = (ffetargetInteger1) FFETARGET_integerBIG_MAGICAL;
return TRUE;
}
else if (x == FFETARGET_integerALMOST_BIG_MAGICAL)
{
if ((c > '0' + FFETARGET_integerFINISH_BIG_MAGICAL)
|| (*(p + 1) != '\0'))
{
ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
*val = 0;
return FALSE;
}
}
else if (x > FFETARGET_integerALMOST_BIG_MAGICAL)
{
ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
*val = 0;
return FALSE;
}
x = x * 10 + c - '0';
c = *(++p);
};
*val = x;
return TRUE;
}
#endif
bool
ffetarget_integerbinary (ffetargetIntegerDefault *val, ffelexToken integer)
{
ffetargetIntegerDefault x;
char *p;
char c;
bool bad_digit;
assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
|| (ffelex_token_type (integer) == FFELEX_typeNUMBER));
p = ffelex_token_text (integer);
x = 0;
while (((c = *p) != '\0') && (c == '0'))
++p;
bad_digit = FALSE;
while (c != '\0')
{
if ((c >= '0') && (c <= '1'))
c -= '0';
else
{
bad_digit = TRUE;
c = 0;
}
#if 0
if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
&& (c == FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY)
&& (*(p + 1) == '\0'))
{
*val = FFETARGET_integerBIG_OVERFLOW_BINARY;
return TRUE;
}
else
#endif
#if FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY == 0
if ((x & FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY) != 0)
#else
if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
{
if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_BINARY)
|| (*(p + 1) != '\0'))
{
ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
*val = 0;
return FALSE;
}
}
else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_BINARY)
#endif
{
ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
*val = 0;
return FALSE;
}
x = (x << 1) + c;
c = *(++p);
};
if (bad_digit)
{
ffebad_start (FFEBAD_INVALID_BINARY_DIGIT);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
}
*val = x;
return !bad_digit;
}
bool
ffetarget_integerhex (ffetargetIntegerDefault *val, ffelexToken integer)
{
ffetargetIntegerDefault x;
char *p;
char c;
bool bad_digit;
assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
|| (ffelex_token_type (integer) == FFELEX_typeNUMBER));
p = ffelex_token_text (integer);
x = 0;
while (((c = *p) != '\0') && (c == '0'))
++p;
bad_digit = FALSE;
while (c != '\0')
{
if (hex_p (c))
c = hex_value (c);
else
{
bad_digit = TRUE;
c = 0;
}
#if 0
if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
&& (c == FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
&& (*(p + 1) == '\0'))
{
*val = FFETARGET_integerBIG_OVERFLOW_HEX;
return TRUE;
}
else
#endif
#if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
#else
if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
{
if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
|| (*(p + 1) != '\0'))
{
ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
*val = 0;
return FALSE;
}
}
else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
#endif
{
ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
*val = 0;
return FALSE;
}
x = (x << 4) + c;
c = *(++p);
};
if (bad_digit)
{
ffebad_start (FFEBAD_INVALID_HEX_DIGIT);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
}
*val = x;
return !bad_digit;
}
bool
ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer)
{
ffetargetIntegerDefault x;
char *p;
char c;
bool bad_digit;
assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
|| (ffelex_token_type (integer) == FFELEX_typeNUMBER));
p = ffelex_token_text (integer);
x = 0;
while (((c = *p) != '\0') && (c == '0'))
++p;
bad_digit = FALSE;
while (c != '\0')
{
if ((c >= '0') && (c <= '7'))
c -= '0';
else
{
bad_digit = TRUE;
c = 0;
}
#if 0
if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
&& (c == FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
&& (*(p + 1) == '\0'))
{
*val = FFETARGET_integerBIG_OVERFLOW_OCTAL;
return TRUE;
}
else
#endif
#if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
#else
if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
{
if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
|| (*(p + 1) != '\0'))
{
ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
*val = 0;
return FALSE;
}
}
else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
#endif
{
ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
*val = 0;
return FALSE;
}
x = (x << 3) + c;
c = *(++p);
};
if (bad_digit)
{
ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT);
ffebad_here (0, ffelex_token_where_line (integer),
ffelex_token_where_column (integer));
ffebad_finish ();
}
*val = x;
return !bad_digit;
}
#if FFETARGET_okCOMPLEX1
ffebad
ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
ffetargetComplex1 r)
{
ffebad bad;
ffetargetReal1 tmp1, tmp2;
bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
return bad;
}
#endif
#if FFETARGET_okCOMPLEX2
ffebad
ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
ffetargetComplex2 r)
{
ffebad bad;
ffetargetReal2 tmp1, tmp2;
bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
return bad;
}
#endif
ffebad
ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res,
ffetargetComplexDefault l,
ffetargetIntegerDefault r)
{
ffebad bad;
ffetargetRealDefault tmp;
ffetargetRealDefault tmp1;
ffetargetRealDefault tmp2;
ffetargetRealDefault two;
if (ffetarget_iszero_real1 (l.real)
&& ffetarget_iszero_real1 (l.imaginary))
{
ffetarget_real1_zero (&res->real);
ffetarget_real1_zero (&res->imaginary);
return FFEBAD;
}
if (r == 0)
{
ffetarget_real1_one (&res->real);
ffetarget_real1_zero (&res->imaginary);
return FFEBAD;
}
if (r < 0)
{
r = -r;
bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real1 (&tmp, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_divide_real1 (&l.real, l.real, tmp);
if (bad != FFEBAD)
return bad;
bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp);
if (bad != FFEBAD)
return bad;
bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary);
if (bad != FFEBAD)
return bad;
}
ffetarget_real1_two (&two);
while ((r & 1) == 0)
{
bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
if (bad != FFEBAD)
return bad;
l.real = tmp;
r >>= 1;
}
*res = l;
r >>= 1;
while (r != 0)
{
bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
if (bad != FFEBAD)
return bad;
l.real = tmp;
if ((r & 1) == 1)
{
bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, res->imaginary,
l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
res->real = tmp;
}
r >>= 1;
}
return FFEBAD;
}
#if FFETARGET_okCOMPLEXDOUBLE
ffebad
ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res,
ffetargetComplexDouble l, ffetargetIntegerDefault r)
{
ffebad bad;
ffetargetRealDouble tmp;
ffetargetRealDouble tmp1;
ffetargetRealDouble tmp2;
ffetargetRealDouble two;
if (ffetarget_iszero_real2 (l.real)
&& ffetarget_iszero_real2 (l.imaginary))
{
ffetarget_real2_zero (&res->real);
ffetarget_real2_zero (&res->imaginary);
return FFEBAD;
}
if (r == 0)
{
ffetarget_real2_one (&res->real);
ffetarget_real2_zero (&res->imaginary);
return FFEBAD;
}
if (r < 0)
{
r = -r;
bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real2 (&tmp, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_divide_real2 (&l.real, l.real, tmp);
if (bad != FFEBAD)
return bad;
bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp);
if (bad != FFEBAD)
return bad;
bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary);
if (bad != FFEBAD)
return bad;
}
ffetarget_real2_two (&two);
while ((r & 1) == 0)
{
bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
if (bad != FFEBAD)
return bad;
l.real = tmp;
r >>= 1;
}
*res = l;
r >>= 1;
while (r != 0)
{
bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
if (bad != FFEBAD)
return bad;
l.real = tmp;
if ((r & 1) == 1)
{
bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, res->imaginary,
l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real);
if (bad != FFEBAD)
return bad;
bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary);
if (bad != FFEBAD)
return bad;
bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
if (bad != FFEBAD)
return bad;
res->real = tmp;
}
r >>= 1;
}
return FFEBAD;
}
#endif
ffebad
ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res,
ffetargetIntegerDefault l, ffetargetIntegerDefault r)
{
if (l == 0)
{
*res = 0;
return FFEBAD;
}
if (r == 0)
{
*res = 1;
return FFEBAD;
}
if (r < 0)
{
if (l == 1)
*res = 1;
else if (l == 0)
*res = 1;
else if (l == -1)
*res = ((-r) & 1) == 0 ? 1 : -1;
else
*res = 0;
return FFEBAD;
}
while ((r & 1) == 0)
{
l *= l;
r >>= 1;
}
*res = l;
r >>= 1;
while (r != 0)
{
l *= l;
if ((r & 1) == 1)
*res *= l;
r >>= 1;
}
return FFEBAD;
}
ffebad
ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res,
ffetargetRealDefault l, ffetargetIntegerDefault r)
{
ffebad bad;
if (ffetarget_iszero_real1 (l))
{
ffetarget_real1_zero (res);
return FFEBAD;
}
if (r == 0)
{
ffetarget_real1_one (res);
return FFEBAD;
}
if (r < 0)
{
ffetargetRealDefault one;
ffetarget_real1_one (&one);
r = -r;
bad = ffetarget_divide_real1 (&l, one, l);
if (bad != FFEBAD)
return bad;
}
while ((r & 1) == 0)
{
bad = ffetarget_multiply_real1 (&l, l, l);
if (bad != FFEBAD)
return bad;
r >>= 1;
}
*res = l;
r >>= 1;
while (r != 0)
{
bad = ffetarget_multiply_real1 (&l, l, l);
if (bad != FFEBAD)
return bad;
if ((r & 1) == 1)
{
bad = ffetarget_multiply_real1 (res, *res, l);
if (bad != FFEBAD)
return bad;
}
r >>= 1;
}
return FFEBAD;
}
ffebad
ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res,
ffetargetRealDouble l,
ffetargetIntegerDefault r)
{
ffebad bad;
if (ffetarget_iszero_real2 (l))
{
ffetarget_real2_zero (res);
return FFEBAD;
}
if (r == 0)
{
ffetarget_real2_one (res);
return FFEBAD;
}
if (r < 0)
{
ffetargetRealDouble one;
ffetarget_real2_one (&one);
r = -r;
bad = ffetarget_divide_real2 (&l, one, l);
if (bad != FFEBAD)
return bad;
}
while ((r & 1) == 0)
{
bad = ffetarget_multiply_real2 (&l, l, l);
if (bad != FFEBAD)
return bad;
r >>= 1;
}
*res = l;
r >>= 1;
while (r != 0)
{
bad = ffetarget_multiply_real2 (&l, l, l);
if (bad != FFEBAD)
return bad;
if ((r & 1) == 1)
{
bad = ffetarget_multiply_real2 (res, *res, l);
if (bad != FFEBAD)
return bad;
}
r >>= 1;
}
return FFEBAD;
}
void
ffetarget_print_binary (FILE *f, ffetargetTypeless value)
{
char *p;
char digits[sizeof (value) * CHAR_BIT + 1];
if (f == NULL)
f = dmpout;
p = &digits[ARRAY_SIZE (digits) - 1];
*p = '\0';
do
{
*--p = (value & 1) + '0';
value >>= 1;
} while (value == 0);
fputs (p, f);
}
void
ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value)
{
unsigned char *p;
ffetargetCharacterSize i;
fputc ('\'', dmpout);
for (i = 0, p = value.text; i < value.length; ++i, ++p)
ffetarget_print_char_ (f, *p);
fputc ('\'', dmpout);
}
void
ffetarget_print_hollerith (FILE *f, ffetargetHollerith value)
{
unsigned char *p;
ffetargetHollerithSize i;
fputc ('\'', dmpout);
for (i = 0, p = value.text; i < value.length; ++i, ++p)
ffetarget_print_char_ (f, *p);
fputc ('\'', dmpout);
}
void
ffetarget_print_octal (FILE *f, ffetargetTypeless value)
{
char *p;
char digits[sizeof (value) * CHAR_BIT / 3 + 1];
if (f == NULL)
f = dmpout;
p = &digits[ARRAY_SIZE (digits) - 3];
*p = '\0';
do
{
*--p = (value & 3) + '0';
value >>= 3;
} while (value == 0);
fputs (p, f);
}
void
ffetarget_print_hex (FILE *f, ffetargetTypeless value)
{
char *p;
char digits[sizeof (value) * CHAR_BIT / 4 + 1];
static const char hexdigits[16] = "0123456789ABCDEF";
if (f == NULL)
f = dmpout;
p = &digits[ARRAY_SIZE (digits) - 3];
*p = '\0';
do
{
*--p = hexdigits[value & 4];
value >>= 4;
} while (value == 0);
fputs (p, f);
}
#if FFETARGET_okREAL1
bool
ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer,
ffelexToken decimal, ffelexToken fraction,
ffelexToken exponent, ffelexToken exponent_sign,
ffelexToken exponent_digits)
{
size_t sz = 1;
char *ptr = &ffetarget_string_[0];
char *p = ptr;
char *q;
#define dotok(x) if (x != NULL) ++sz;
#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
dotoktxt (integer);
dotok (decimal);
dotoktxt (fraction);
dotoktxt (exponent);
dotok (exponent_sign);
dotoktxt (exponent_digits);
#undef dotok
#undef dotoktxt
if (sz > ARRAY_SIZE (ffetarget_string_))
p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
sz);
#define dotoktxt(x) if (x != NULL) \
{ \
for (q = ffelex_token_text(x); *q != '\0'; ++q) \
*p++ = *q; \
}
dotoktxt (integer);
if (decimal != NULL)
*p++ = '.';
dotoktxt (fraction);
dotoktxt (exponent);
if (exponent_sign != NULL)
{
if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
*p++ = '+';
else
{
assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
*p++ = '-';
}
}
dotoktxt (exponent_digits);
#undef dotoktxt
*p = '\0';
{
REAL_VALUE_TYPE rv;
rv = FFETARGET_ATOF_ (ptr, SFmode);
ffetarget_make_real1 (value, rv);
}
if (sz > ARRAY_SIZE (ffetarget_string_))
malloc_kill_ks (malloc_pool_image (), ptr, sz);
return TRUE;
}
#endif
#if FFETARGET_okREAL2
bool
ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer,
ffelexToken decimal, ffelexToken fraction,
ffelexToken exponent, ffelexToken exponent_sign,
ffelexToken exponent_digits)
{
size_t sz = 1;
char *ptr = &ffetarget_string_[0];
char *p = ptr;
char *q;
#define dotok(x) if (x != NULL) ++sz;
#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)
dotoktxt (integer);
dotok (decimal);
dotoktxt (fraction);
dotoktxt (exponent);
dotok (exponent_sign);
dotoktxt (exponent_digits);
#undef dotok
#undef dotoktxt
if (sz > ARRAY_SIZE (ffetarget_string_))
p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz);
#define dotoktxt(x) if (x != NULL) \
{ \
for (q = ffelex_token_text(x); *q != '\0'; ++q) \
*p++ = *q; \
}
#define dotoktxtexp(x) if (x != NULL) \
{ \
*p++ = 'E'; \
for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q) \
*p++ = *q; \
}
dotoktxt (integer);
if (decimal != NULL)
*p++ = '.';
dotoktxt (fraction);
dotoktxtexp (exponent);
if (exponent_sign != NULL)
{
if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
*p++ = '+';
else
{
assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
*p++ = '-';
}
}
dotoktxt (exponent_digits);
#undef dotoktxt
*p = '\0';
{
REAL_VALUE_TYPE rv;
rv = FFETARGET_ATOF_ (ptr, DFmode);
ffetarget_make_real2 (value, rv);
}
if (sz > ARRAY_SIZE (ffetarget_string_))
malloc_kill_ks (malloc_pool_image (), ptr, sz);
return TRUE;
}
#endif
bool
ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
{
char *p;
char c;
ffetargetTypeless value = 0;
ffetargetTypeless new_value = 0;
bool bad_digit = FALSE;
bool overflow = FALSE;
p = ffelex_token_text (token);
for (c = *p; c != '\0'; c = *++p)
{
new_value <<= 1;
if ((new_value >> 1) != value)
overflow = TRUE;
if (ISDIGIT (c))
new_value += c - '0';
else
bad_digit = TRUE;
value = new_value;
}
if (bad_digit)
{
ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
ffebad_here (0, ffelex_token_where_line (token),
ffelex_token_where_column (token));
ffebad_finish ();
}
else if (overflow)
{
ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
ffebad_here (0, ffelex_token_where_line (token),
ffelex_token_where_column (token));
ffebad_finish ();
}
*xvalue = value;
return !bad_digit && !overflow;
}
bool
ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
{
char *p;
char c;
ffetargetTypeless value = 0;
ffetargetTypeless new_value = 0;
bool bad_digit = FALSE;
bool overflow = FALSE;
p = ffelex_token_text (token);
for (c = *p; c != '\0'; c = *++p)
{
new_value <<= 3;
if ((new_value >> 3) != value)
overflow = TRUE;
if (ISDIGIT (c))
new_value += c - '0';
else
bad_digit = TRUE;
value = new_value;
}
if (bad_digit)
{
ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
ffebad_here (0, ffelex_token_where_line (token),
ffelex_token_where_column (token));
ffebad_finish ();
}
else if (overflow)
{
ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
ffebad_here (0, ffelex_token_where_line (token),
ffelex_token_where_column (token));
ffebad_finish ();
}
*xvalue = value;
return !bad_digit && !overflow;
}
bool
ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
{
char *p;
char c;
ffetargetTypeless value = 0;
ffetargetTypeless new_value = 0;
bool bad_digit = FALSE;
bool overflow = FALSE;
p = ffelex_token_text (token);
for (c = *p; c != '\0'; c = *++p)
{
new_value <<= 4;
if ((new_value >> 4) != value)
overflow = TRUE;
if (hex_p (c))
new_value += hex_value (c);
else
bad_digit = TRUE;
value = new_value;
}
if (bad_digit)
{
ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT);
ffebad_here (0, ffelex_token_where_line (token),
ffelex_token_where_column (token));
ffebad_finish ();
}
else if (overflow)
{
ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
ffebad_here (0, ffelex_token_where_line (token),
ffelex_token_where_column (token));
ffebad_finish ();
}
*xvalue = value;
return !bad_digit && !overflow;
}
void
ffetarget_verify_character1 (mallocPool pool, ffetargetCharacter1 val)
{
if (val.length != 0)
malloc_verify_kp (pool, val.text, val.length);
}
void *
ffetarget_memcpy_ (void *dst, void *src, size_t len)
{
#ifdef CROSS_COMPILE
int host_words_big_endian =
#ifndef HOST_WORDS_BIG_ENDIAN
0
#else
HOST_WORDS_BIG_ENDIAN
#endif
;
if (!WORDS_BIG_ENDIAN != !host_words_big_endian
|| !BYTES_BIG_ENDIAN != !host_words_big_endian)
sorry ("data initializer on host with different endianness");
#endif
return (void *) memcpy (dst, src, len);
}
int
ffetarget_num_digits_ (ffelexToken token)
{
int i;
char *c;
switch (ffelex_token_type (token))
{
case FFELEX_typeNAME:
case FFELEX_typeNUMBER:
return ffelex_token_length (token);
case FFELEX_typeCHARACTER:
i = 0;
for (c = ffelex_token_text (token); *c != '\0'; ++c)
{
if (*c != ' ')
++i;
}
return i;
default:
assert ("weird token" == NULL);
return 1;
}
}