+++ /dev/null
-/* target.c -- Implementation File (module.c template V1.0)
- Copyright (C) 1995, 1996, 1997, 1998, 2002 Free Software Foundation, Inc.
- Contributed by James Craig Burley.
-
-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.h"
-#include "target.h"
-#include "diagnostic.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
-\f
-
-/* 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
-ffetarget_layout (const char *error_text UNUSED, ffetargetAlign *alignment,
- 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 (hex_p (c))
- c = hex_value (c);
- 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 (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);
-}
-
-/* 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)
-{
-#ifdef CROSS_COMPILE
- /* HOST_WORDS_BIG_ENDIAN corresponds to both WORDS_BIG_ENDIAN and
- BYTES_BIG_ENDIAN (i.e. there are no HOST_ macros to represent a
- difference in the two latter). */
- int host_words_big_endian =
-#ifndef HOST_WORDS_BIG_ENDIAN
- 0
-#else
- HOST_WORDS_BIG_ENDIAN
-#endif
- ;
-
- /* This is just hands thrown up in the air over bits coming through this
- function representing a number being memcpy:d as-is from host to
- target. We can't generally adjust endianness here since we don't
- know whether it's an integer or floating point number; they're passed
- differently. Better to not emit code at all than to emit wrong code.
- We will get some false hits because some data coming through here
- seems to be just character vectors, but often enough it's numbers,
- for instance in g77.f-torture/execute/980628-[4-6].f and alpha2.f.
- Still, we compile *some* code. FIXME: Rewrite handling of numbers. */
- if (!WORDS_BIG_ENDIAN != !host_words_big_endian
- || !BYTES_BIG_ENDIAN != !host_words_big_endian)
- sorry ("data initializer on host with different endianness");
-
-#endif /* CROSS_COMPILE */
-
- 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;
- }
-}
projects / msp430-gcc.git / blobdiff