d/freebsd-dev
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
a3d8f94bd4
freebsd-dev/contrib/gcc/f/target.c

2565 lines
61 KiB
C
Raw Normal View History

Virgin import of gcc from EGCS 1.1.2
1999-08-26 09:30:50 +00:00
/* target.c -- Implementation File (module.c template V1.0)
Copyright (C) 1995-1998 Free Software Foundation, Inc.
Virgin import of the GCC 2.95.1 compilers
1999-10-16 06:09:09 +00:00
Contributed by James Craig Burley.
Virgin import of gcc from EGCS 1.1.2
1999-08-26 09:30:50 +00:00
This file is part of GNU Fortran.
GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING. If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.
Related Modules:
None
Description:
Implements conversion of lexer tokens to machine-dependent numerical
form and accordingly issues diagnostic messages when necessary.
Also, this module, especially its .h file, provides nearly all of the
information on the target machine's data type, kind type, and length
type capabilities. The idea is that by carefully going through
target.h and changing things properly, one can accomplish much
towards the porting of the FFE to a new machine. There are limits
to how much this can accomplish towards that end, however. For one
thing, the ffeexpr_collapse_convert function doesn't contain all the
conversion cases necessary, because the text file would be
enormous (even though most of the function would be cut during the
cpp phase because of the absence of the types), so when adding to
the number of supported kind types for a given type, one must look
to see if ffeexpr_collapse_convert needs modification in this area,
in addition to providing the appropriate macros and functions in
ffetarget. Note that if combinatorial explosion actually becomes a
problem for a given machine, one might have to modify the way conversion
expressions are built so that instead of just one conversion expr, a
series of conversion exprs are built to make a path from one type to
another that is not a "near neighbor". For now, however, with a handful
of each of the numeric types and only one character type, things appear
manageable.
A nonobvious change to ffetarget would be if the target machine was
not a 2's-complement machine. Any item with the word "magical" (case-
insensitive) in the FFE's source code (at least) indicates an assumption
that a 2's-complement machine is the target, and thus that there exists
a magnitude that can be represented as a negative number but not as
a positive number. It is possible that this situation can be dealt
with by changing only ffetarget, for example, on a 1's-complement
machine, perhaps #defineing ffetarget_constant_is_magical to simply
FALSE along with making the appropriate changes in ffetarget's number
parsing functions would be sufficient to effectively "comment out" code
in places like ffeexpr that do certain magical checks. But it is
possible there are other 2's-complement dependencies lurking in the
FFE (as possibly is true of any large program); if you find any, please
report them so we can replace them with dependencies on ffetarget
instead.
Modifications:
*/
/* Include files. */
#include "proj.h"
#include "glimits.j"
#include "target.h"
#include "bad.h"
#include "info.h"
#include "lex.h"
#include "malloc.h"
/* Externals defined here. */
char ffetarget_string_[40]; /* Temp for ascii-to-double (atof). */
HOST_WIDE_INT ffetarget_long_val_;
HOST_WIDE_INT ffetarget_long_junk_;
/* Simple definitions and enumerations. */
/* Internal typedefs. */
/* Private include files. */
/* Internal structure definitions. */
/* Static objects accessed by functions in this module. */
/* Static functions (internal). */
static void ffetarget_print_char_ (FILE *f, unsigned char c);
/* Internal macros. */
#ifdef REAL_VALUE_ATOF
#define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m))
#else
#define FFETARGET_ATOF_(p,m) atof ((p))
#endif
/* ffetarget_print_char_ -- Print a single character (in apostrophe context)
See prototype.
Outputs char so it prints or is escaped C style. */
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;
}
}
/* ffetarget_aggregate_info -- Determine type for aggregate storage area
See prototype.
If aggregate type is distinct, just return it. Else return a type
representing a common denominator for the nondistinct type (for now,
just return default character, since that'll work on almost all target
machines).
The rules for abt/akt are (as implemented by ffestorag_update):
abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by
definition): CHARACTER and non-CHARACTER types mixed.
abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by
definition): More than one non-CHARACTER type mixed, but no CHARACTER
types mixed in.
abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the
only basic type mixed in, but more than one kind type is mixed in.
abt some other value, akt some other value: abt and akt indicate the
only type represented in the aggregation. */
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);
}
/* ffetarget_align -- Align one storage area to superordinate, update super
See prototype.
updated_alignment/updated_modulo contain the already existing
alignment requirements for the storage area at whose offset the
object with alignment requirements alignment/modulo is to be placed.
Find the smallest pad such that the requirements are maintained and
return it, but only after updating the updated_alignment/_modulo
requirements as necessary to indicate the placement of the new object. */
ffetargetAlign
ffetarget_align (ffetargetAlign *updated_alignment,
ffetargetAlign *updated_modulo, ffetargetOffset offset,
ffetargetAlign alignment, ffetargetAlign modulo)
{
ffetargetAlign pad;
ffetargetAlign min_pad; /* Minimum amount of padding needed. */
ffetargetAlign min_m = 0; /* Minimum-padding m. */
ffetargetAlign ua; /* Updated alignment. */
ffetargetAlign um; /* Updated modulo. */
ffetargetAlign ucnt; /* Multiplier applied to ua. */
ffetargetAlign m; /* Copy of modulo. */
ffetargetAlign cnt; /* Multiplier applied to alignment. */
ffetargetAlign i;
ffetargetAlign j;
assert (alignment > 0);
assert (*updated_alignment > 0);
assert (*updated_modulo < *updated_alignment);
assert (modulo < alignment);
/* The easy case: similar alignment requirements. */
if (*updated_alignment == alignment)
{
if (modulo > *updated_modulo)
pad = alignment - (modulo - *updated_modulo);
else
pad = *updated_modulo - modulo;
if (offset < 0)
/* De-negatize offset, since % wouldn't do the expected thing. */
offset = alignment - ((- offset) % alignment);
pad = (offset + pad) % alignment;
if (pad != 0)
pad = alignment - pad;
return pad;
}
/* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */
for (ua = *updated_alignment, ucnt = 1;
ua % alignment != 0;
ua += *updated_alignment)
++ucnt;
cnt = ua / alignment;
if (offset < 0)
/* De-negatize offset, since % wouldn't do the expected thing. */
offset = ua - ((- offset) % ua);
/* Set to largest value. */
min_pad = ~(ffetargetAlign) 0;
/* Find all combinations of modulo values the two alignment requirements
have; pick the combination that results in the smallest padding
requirement. Of course, if a zero-pad requirement is encountered, just
use that one. */
for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i)
{
for (m = modulo, j = 0; j < cnt; m += alignment, ++j)
{
/* This code is similar to the "easy case" code above. */
if (m > um)
pad = ua - (m - um);
else
pad = um - m;
pad = (offset + pad) % ua;
if (pad == 0)
{
/* A zero pad means we've got something useful. */
*updated_alignment = ua;
*updated_modulo = um;
return 0;
}
pad = ua - pad;
if (pad < min_pad)
{ /* New minimum padding value. */
min_pad = pad;
min_m = um;
}
}
}
*updated_alignment = ua;
*updated_modulo = min_m;
return min_pad;
}
/* Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
#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
/* Produce orderable comparison between two constants
Compare lengths, if equal then use memcmp. */
#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
/* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants
Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
#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
/* ffetarget_eq_character1 -- Perform relational comparison on char constants
Compare lengths, if equal then use memcmp. */
#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
/* ffetarget_le_character1 -- Perform relational comparison on char constants
Compare lengths, if equal then use memcmp. */
#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
/* ffetarget_lt_character1 -- Perform relational comparison on char constants
Compare lengths, if equal then use memcmp. */
#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
/* ffetarget_ge_character1 -- Perform relational comparison on char constants
Compare lengths, if equal then use memcmp. */
#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
/* ffetarget_gt_character1 -- Perform relational comparison on char constants
Compare lengths, if equal then use memcmp. */
#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;
}
/* ffetarget_layout -- Do storage requirement analysis for entity
Return the alignment/modulo requirements along with the size, given the
data type info and the number of elements an array (1 for a scalar). */
void
Virgin import of the GCC 2.95.1 compilers
1999-10-16 06:09:09 +00:00
ffetarget_layout (const char *error_text UNUSED, ffetargetAlign *alignment,
Virgin import of gcc from EGCS 1.1.2
1999-08-26 09:30:50 +00:00
ffetargetAlign *modulo, ffetargetOffset *size,
ffeinfoBasictype bt, ffeinfoKindtype kt,
ffetargetCharacterSize charsize,
ffetargetIntegerDefault num_elements)
{
bool ok; /* For character type. */
ffetargetOffset numele; /* Converted from num_elements. */
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;
}
}
/* ffetarget_ne_character1 -- Perform relational comparison on char constants
Compare lengths, if equal then use memcmp. */
#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
/* ffetarget_substr_character1 -- Perform SUBSTR op on three constants
Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
#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
/* ffetarget_cmp_hollerith -- Produce orderable comparison between two
constants
Compare lengths, if equal then use memcmp. */
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;
}
/* Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
#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
/* Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
#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
/* ffetarget_convert_character1_integer4 -- Raw conversion.
Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
#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
/* ffetarget_convert_character1_logical4 -- Raw conversion.
Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
#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
/* ffetarget_convert_character1_typeless -- Raw conversion.
Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
#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
/* ffetarget_divide_complex1 -- Divide function
See prototype. */
#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
/* ffetarget_divide_complex2 -- Divide function
See prototype. */
#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
/* ffetarget_hollerith -- Convert token to a hollerith constant
Always append a null byte to the end, in case this is wanted in
a special case such as passing a string as a FORMAT or %REF.
Done to save a bit of hassle, nothing more, but it's a kludge anyway,
because it isn't a "feature" that is self-documenting. Use the
string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
in the code. */
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;
}
/* ffetarget_integer_bad_magical -- Complain about a magical number
Just calls ffebad with the arguments. */
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 ();
}
/* ffetarget_integer_bad_magical_binary -- Complain about a magical number
Just calls ffebad with the arguments. */
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 ();
}
/* ffetarget_integer_bad_magical_precedence -- Complain about a magical
number
Just calls ffebad with the arguments. */
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 ();
}
/* ffetarget_integer_bad_magical_precedence_binary -- Complain...
Just calls ffebad with the arguments. */
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 ();
}
/* ffetarget_integer1 -- Convert token to an integer
See prototype.
Token use count not affected overall. */
#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;
/* Skip past leading zeros. */
while (((c = *p) != '\0') && (c == '0'))
++p;
/* Interpret rest of number. */
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
/* ffetarget_integerbinary -- Convert token to a binary integer
ffetarget_integerbinary x;
if (ffetarget_integerdefault_8(&x,integer_token))
// conversion ok.
Token use count not affected overall. */
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;
/* Skip past leading zeros. */
while (((c = *p) != '\0') && (c == '0'))
++p;
/* Interpret rest of number. */
bad_digit = FALSE;
while (c != '\0')
{
if ((c >= '0') && (c <= '1'))
c -= '0';
else
{
bad_digit = TRUE;
c = 0;
}
#if 0 /* Don't complain about signed overflow; just
unsigned overflow. */
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;
}
/* ffetarget_integerhex -- Convert token to a hex integer
ffetarget_integerhex x;
if (ffetarget_integerdefault_8(&x,integer_token))
// conversion ok.
Token use count not affected overall. */
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;
/* Skip past leading zeros. */
while (((c = *p) != '\0') && (c == '0'))
++p;
/* Interpret rest of number. */
bad_digit = FALSE;
while (c != '\0')
{
if ((c >= 'A') && (c <= 'F'))
c = c - 'A' + 10;
else if ((c >= 'a') && (c <= 'f'))
c = c - 'a' + 10;
else if ((c >= '0') && (c <= '9'))
c -= '0';
else
{
bad_digit = TRUE;
c = 0;
}
#if 0 /* Don't complain about signed overflow; just
unsigned overflow. */
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;
}
/* ffetarget_integeroctal -- Convert token to an octal integer
ffetarget_integeroctal x;
if (ffetarget_integerdefault_8(&x,integer_token))
// conversion ok.
Token use count not affected overall. */
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;
/* Skip past leading zeros. */
while (((c = *p) != '\0') && (c == '0'))
++p;
/* Interpret rest of number. */
bad_digit = FALSE;
while (c != '\0')
{
if ((c >= '0') && (c <= '7'))
c -= '0';
else
{
bad_digit = TRUE;
c = 0;
}
#if 0 /* Don't complain about signed overflow; just
unsigned overflow. */
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;
}
/* ffetarget_multiply_complex1 -- Multiply function
See prototype. */
#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
/* ffetarget_multiply_complex2 -- Multiply function
See prototype. */
#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
/* ffetarget_power_complexdefault_integerdefault -- Power function
See prototype. */
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;
}
/* ffetarget_power_complexdouble_integerdefault -- Power function
See prototype. */
#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
/* ffetarget_power_integerdefault_integerdefault -- Power function
See prototype. */
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;
}
/* ffetarget_power_realdefault_integerdefault -- Power function
See prototype. */
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;
}
/* ffetarget_power_realdouble_integerdefault -- Power function
See prototype. */
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;
}
/* ffetarget_print_binary -- Output typeless binary integer
ffetargetTypeless val;
ffetarget_typeless_binary(dmpout,val); */
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);
}
/* ffetarget_print_character1 -- Output character string
ffetargetCharacter1 val;
ffetarget_print_character1(dmpout,val); */
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);
}
/* ffetarget_print_hollerith -- Output hollerith string
ffetargetHollerith val;
ffetarget_print_hollerith(dmpout,val); */
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);
}
/* ffetarget_print_octal -- Output typeless octal integer
ffetargetTypeless val;
ffetarget_print_octal(dmpout,val); */
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);
}
/* ffetarget_print_hex -- Output typeless hex integer
ffetargetTypeless val;
ffetarget_print_hex(dmpout,val); */
void
ffetarget_print_hex (FILE *f, ffetargetTypeless value)
{
char *p;
char digits[sizeof (value) * CHAR_BIT / 4 + 1];
static 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);
}
/* ffetarget_real1 -- Convert token to a single-precision real number
See prototype.
Pass NULL for any token not provided by the user, but a valid Fortran
real number must be provided somehow. For example, it is ok for
exponent_sign_token and exponent_digits_token to be NULL as long as
exponent_token not only starts with "E" or "e" but also contains at least
one digit following it. Token use counts not affected overall. */
#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; /* Allow room for '\0' byte at end. */
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';
ffetarget_make_real1 (value,
FFETARGET_ATOF_ (ptr,
SFmode));
if (sz > ARRAY_SIZE (ffetarget_string_))
malloc_kill_ks (malloc_pool_image (), ptr, sz);
return TRUE;
}
#endif
/* ffetarget_real2 -- Convert token to a single-precision real number
See prototype.
Pass NULL for any token not provided by the user, but a valid Fortran
real number must be provided somehow. For example, it is ok for
exponent_sign_token and exponent_digits_token to be NULL as long as
exponent_token not only starts with "E" or "e" but also contains at least
one digit following it. Token use counts not affected overall. */
#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; /* Allow room for '\0' byte at end. */
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';
ffetarget_make_real2 (value,
FFETARGET_ATOF_ (ptr,
DFmode));
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 (ISDIGIT (c))
new_value += c - '0';
else if ((c >= 'A') && (c <= 'F'))
new_value += c - 'A' + 10;
else if ((c >= 'a') && (c <= 'f'))
new_value += c - 'a' + 10;
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);
}
/* This is like memcpy. It is needed because some systems' header files
don't declare memcpy as a function but instead
"#define memcpy(to,from,len) something". */
void *
ffetarget_memcpy_ (void *dst, void *src, size_t len)
{
return (void *) memcpy (dst, src, len);
}
/* ffetarget_num_digits_ -- Determine number of non-space characters in token
ffetarget_num_digits_(token);
All non-spaces are assumed to be binary, octal, or hex digits. */
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;
}
}
Reference in New Issue Copy Permalink