* expr.c (expand_expr) [MULT_EXPR]: Do not apply distributive law

[official-gcc.git] / gcc / f / target.c

/* target.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995, 1996, 1997, 1998 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 "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)
{
  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;
    }
}