/* target.c -- Implementation File (module.c template V1.0)
   Copyright (C) 1995-1998 Free Software Foundation, Inc.
   Contributed by James Craig Burley (burley@gnu.org).

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 <ctype.h>
#include "glimits.j"
#include "target.h"
#include "bad.h"
#include "info.h"
#include "lex.h"
#include "malloc.h"

/* Externals defined here. */

char ffetarget_string_[40];	/* Temp for ascii-to-double (atof). */
HOST_WIDE_INT ffetarget_long_val_;
HOST_WIDE_INT ffetarget_long_junk_;

/* Simple definitions and enumerations. */


/* Internal typedefs. */


/* Private include files. */


/* Internal structure definitions. */


/* Static objects accessed by functions in this module. */


/* Static functions (internal). */

static void ffetarget_print_char_ (FILE *f, unsigned char c);

/* Internal macros. */

#ifdef REAL_VALUE_ATOF
#define FFETARGET_ATOF_(p,m) REAL_VALUE_ATOF ((p),(m))
#else
#define FFETARGET_ATOF_(p,m) atof ((p))
#endif


/* ffetarget_print_char_ -- Print a single character (in apostrophe context)

   See prototype.

   Outputs char so it prints or is escaped C style.  */

static void
ffetarget_print_char_ (FILE *f, unsigned char c)
{
  switch (c)
    {
    case '\\':
      fputs ("\\\\", f);
      break;

    case '\'':
      fputs ("\\\'", f);
      break;

    default:
      if (isprint (c) && isascii (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 (*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;
      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;

  min_pad = ~(ffetargetAlign) 0;/* Set to largest value. */

  /* 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)
	{
	  if (m > um)		/* This code is similar to the "easy case"
				   code above. */
	    pad = ua - (m - um);
	  else
	    pad = um - m;
	  pad = (offset + pad) % ua;
	  if (pad != 0)
	    pad = ua - pad;
	  else
	    {			/* A zero pad means we've got something
				   useful. */
	      *updated_alignment = ua;
	      *updated_modulo = um;
	      return 0;
	    }
	  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 (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 ((c >= 'A') && (c <= 'F'))
	c = c - 'A' + 10;
      else if ((c >= 'a') && (c <= 'f'))
	c = c - 'a' + 10;
      else if ((c >= '0') && (c <= '9'))
	c -= '0';
      else
	{
	  bad_digit = TRUE;
	  c = 0;
	}

#if 0				/* Don't complain about signed overflow; just
				   unsigned overflow. */
      if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
	  && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
	  && (*(p + 1) == '\0'))
	{
	  *val = FFETARGET_integerBIG_OVERFLOW_HEX;
	  return TRUE;
	}
      else
#endif
#if FFETARGET_integerFINISH_BIG_OVERFLOW_HEX == 0
      if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
#else
      if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
	{
	  if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_HEX)
	      || (*(p + 1) != '\0'))
	    {
	      ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
	      ffebad_here (0, ffelex_token_where_line (integer),
			   ffelex_token_where_column (integer));
	      ffebad_finish ();
	      *val = 0;
	      return FALSE;
	    }
	}
      else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_HEX)
#endif
	{
	  ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
	  ffebad_here (0, ffelex_token_where_line (integer),
		       ffelex_token_where_column (integer));
	  ffebad_finish ();
	  *val = 0;
	  return FALSE;
	}
      x = (x << 4) + c;
      c = *(++p);
    };

  if (bad_digit)
    {
      ffebad_start (FFEBAD_INVALID_HEX_DIGIT);
      ffebad_here (0, ffelex_token_where_line (integer),
		   ffelex_token_where_column (integer));
      ffebad_finish ();
    }

  *val = x;
  return !bad_digit;
}

/* ffetarget_integeroctal -- Convert token to an octal integer

   ffetarget_integeroctal x;
   if (ffetarget_integerdefault_8(&x,integer_token))
       // conversion ok.

   Token use count not affected overall.  */

bool
ffetarget_integeroctal (ffetargetIntegerDefault *val, ffelexToken integer)
{
  ffetargetIntegerDefault x;
  char *p;
  char c;
  bool bad_digit;

  assert ((ffelex_token_type (integer) == FFELEX_typeNAME)
	  || (ffelex_token_type (integer) == FFELEX_typeNUMBER));

  p = ffelex_token_text (integer);
  x = 0;

  /* Skip past leading zeros. */

  while (((c = *p) != '\0') && (c == '0'))
    ++p;

  /* Interpret rest of number. */

  bad_digit = FALSE;
  while (c != '\0')
    {
      if ((c >= '0') && (c <= '7'))
	c -= '0';
      else
	{
	  bad_digit = TRUE;
	  c = 0;
	}

#if 0				/* Don't complain about signed overflow; just
				   unsigned overflow. */
      if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
	  && (c == FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
	  && (*(p + 1) == '\0'))
	{
	  *val = FFETARGET_integerBIG_OVERFLOW_OCTAL;
	  return TRUE;
	}
      else
#endif
#if FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL == 0
      if (x >= FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
#else
      if (x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
	{
	  if ((c > FFETARGET_integerFINISH_BIG_OVERFLOW_OCTAL)
	      || (*(p + 1) != '\0'))
	    {
	      ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
	      ffebad_here (0, ffelex_token_where_line (integer),
			   ffelex_token_where_column (integer));
	      ffebad_finish ();
	      *val = 0;
	      return FALSE;
	    }
	}
      else if (x > FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
#endif
	{
	  ffebad_start (FFEBAD_INTEGER_TOO_LARGE);
	  ffebad_here (0, ffelex_token_where_line (integer),
		       ffelex_token_where_column (integer));
	  ffebad_finish ();
	  *val = 0;
	  return FALSE;
	}
      x = (x << 3) + c;
      c = *(++p);
    };

  if (bad_digit)
    {
      ffebad_start (FFEBAD_INVALID_OCTAL_DIGIT);
      ffebad_here (0, ffelex_token_where_line (integer),
		   ffelex_token_where_column (integer));
      ffebad_finish ();
    }

  *val = x;
  return !bad_digit;
}

/* ffetarget_multiply_complex1 -- Multiply function

   See prototype.  */

#if FFETARGET_okCOMPLEX1
ffebad
ffetarget_multiply_complex1 (ffetargetComplex1 *res, ffetargetComplex1 l,
			     ffetargetComplex1 r)
{
  ffebad bad;
  ffetargetReal1 tmp1, tmp2;

  bad = ffetarget_multiply_real1 (&tmp1, l.real, r.real);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, r.imaginary);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_subtract_real1 (&res->real, tmp1, tmp2);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_multiply_real1 (&tmp1, l.imaginary, r.real);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_multiply_real1 (&tmp2, l.real, r.imaginary);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);

  return bad;
}

#endif
/* ffetarget_multiply_complex2 -- Multiply function

   See prototype.  */

#if FFETARGET_okCOMPLEX2
ffebad
ffetarget_multiply_complex2 (ffetargetComplex2 *res, ffetargetComplex2 l,
			     ffetargetComplex2 r)
{
  ffebad bad;
  ffetargetReal2 tmp1, tmp2;

  bad = ffetarget_multiply_real2 (&tmp1, l.real, r.real);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, r.imaginary);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_subtract_real2 (&res->real, tmp1, tmp2);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_multiply_real2 (&tmp1, l.imaginary, r.real);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_multiply_real2 (&tmp2, l.real, r.imaginary);
  if (bad != FFEBAD)
    return bad;
  bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);

  return bad;
}

#endif
/* ffetarget_power_complexdefault_integerdefault -- Power function

   See prototype.  */

ffebad
ffetarget_power_complexdefault_integerdefault (ffetargetComplexDefault *res,
					       ffetargetComplexDefault l,
					       ffetargetIntegerDefault r)
{
  ffebad bad;
  ffetargetRealDefault tmp;
  ffetargetRealDefault tmp1;
  ffetargetRealDefault tmp2;
  ffetargetRealDefault two;

  if (ffetarget_iszero_real1 (l.real)
      && ffetarget_iszero_real1 (l.imaginary))
    {
      ffetarget_real1_zero (&res->real);
      ffetarget_real1_zero (&res->imaginary);
      return FFEBAD;
    }

  if (r == 0)
    {
      ffetarget_real1_one (&res->real);
      ffetarget_real1_zero (&res->imaginary);
      return FFEBAD;
    }

  if (r < 0)
    {
      r = -r;
      bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_add_real1 (&tmp, tmp1, tmp2);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_divide_real1 (&l.real, l.real, tmp);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_divide_real1 (&l.imaginary, l.imaginary, tmp);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_uminus_real1 (&l.imaginary, l.imaginary);
      if (bad != FFEBAD)
	return bad;
    }

  ffetarget_real1_two (&two);

  while ((r & 1) == 0)
    {
      bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
      if (bad != FFEBAD)
	return bad;
      l.real = tmp;
      r >>= 1;
    }

  *res = l;
  r >>= 1;

  while (r != 0)
    {
      bad = ffetarget_multiply_real1 (&tmp1, l.real, l.real);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real1 (&tmp2, l.imaginary, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real1 (&l.imaginary, l.real, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real1 (&l.imaginary, l.imaginary, two);
      if (bad != FFEBAD)
	return bad;
      l.real = tmp;
      if ((r & 1) == 1)
	{
	  bad = ffetarget_multiply_real1 (&tmp1, res->real, l.real);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_multiply_real1 (&tmp2, res->imaginary,
					  l.imaginary);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_subtract_real1 (&tmp, tmp1, tmp2);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_multiply_real1 (&tmp1, res->imaginary, l.real);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_multiply_real1 (&tmp2, res->real, l.imaginary);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_add_real1 (&res->imaginary, tmp1, tmp2);
	  if (bad != FFEBAD)
	    return bad;
	  res->real = tmp;
	}
      r >>= 1;
    }

  return FFEBAD;
}

/* ffetarget_power_complexdouble_integerdefault -- Power function

   See prototype.  */

#if FFETARGET_okCOMPLEXDOUBLE
ffebad
ffetarget_power_complexdouble_integerdefault (ffetargetComplexDouble *res,
			ffetargetComplexDouble l, ffetargetIntegerDefault r)
{
  ffebad bad;
  ffetargetRealDouble tmp;
  ffetargetRealDouble tmp1;
  ffetargetRealDouble tmp2;
  ffetargetRealDouble two;

  if (ffetarget_iszero_real2 (l.real)
      && ffetarget_iszero_real2 (l.imaginary))
    {
      ffetarget_real2_zero (&res->real);
      ffetarget_real2_zero (&res->imaginary);
      return FFEBAD;
    }

  if (r == 0)
    {
      ffetarget_real2_one (&res->real);
      ffetarget_real2_zero (&res->imaginary);
      return FFEBAD;
    }

  if (r < 0)
    {
      r = -r;
      bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_add_real2 (&tmp, tmp1, tmp2);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_divide_real2 (&l.real, l.real, tmp);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_divide_real2 (&l.imaginary, l.imaginary, tmp);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_uminus_real2 (&l.imaginary, l.imaginary);
      if (bad != FFEBAD)
	return bad;
    }

  ffetarget_real2_two (&two);

  while ((r & 1) == 0)
    {
      bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
      if (bad != FFEBAD)
	return bad;
      l.real = tmp;
      r >>= 1;
    }

  *res = l;
  r >>= 1;

  while (r != 0)
    {
      bad = ffetarget_multiply_real2 (&tmp1, l.real, l.real);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real2 (&tmp2, l.imaginary, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real2 (&l.imaginary, l.real, l.imaginary);
      if (bad != FFEBAD)
	return bad;
      bad = ffetarget_multiply_real2 (&l.imaginary, l.imaginary, two);
      if (bad != FFEBAD)
	return bad;
      l.real = tmp;
      if ((r & 1) == 1)
	{
	  bad = ffetarget_multiply_real2 (&tmp1, res->real, l.real);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_multiply_real2 (&tmp2, res->imaginary,
					  l.imaginary);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_subtract_real2 (&tmp, tmp1, tmp2);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_multiply_real2 (&tmp1, res->imaginary, l.real);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_multiply_real2 (&tmp2, res->real, l.imaginary);
	  if (bad != FFEBAD)
	    return bad;
	  bad = ffetarget_add_real2 (&res->imaginary, tmp1, tmp2);
	  if (bad != FFEBAD)
	    return bad;
	  res->real = tmp;
	}
      r >>= 1;
    }

  return FFEBAD;
}

#endif
/* ffetarget_power_integerdefault_integerdefault -- Power function

   See prototype.  */

ffebad
ffetarget_power_integerdefault_integerdefault (ffetargetIntegerDefault *res,
		       ffetargetIntegerDefault l, ffetargetIntegerDefault r)
{
  if (l == 0)
    {
      *res = 0;
      return FFEBAD;
    }

  if (r == 0)
    {
      *res = 1;
      return FFEBAD;
    }

  if (r < 0)
    {
      if (l == 1)
	*res = 1;
      else if (l == 0)
	*res = 1;
      else if (l == -1)
	*res = ((-r) & 1) == 0 ? 1 : -1;
      else
	*res = 0;
      return FFEBAD;
    }

  while ((r & 1) == 0)
    {
      l *= l;
      r >>= 1;
    }

  *res = l;
  r >>= 1;

  while (r != 0)
    {
      l *= l;
      if ((r & 1) == 1)
	*res *= l;
      r >>= 1;
    }

  return FFEBAD;
}

/* ffetarget_power_realdefault_integerdefault -- Power function

   See prototype.  */

ffebad
ffetarget_power_realdefault_integerdefault (ffetargetRealDefault *res,
			  ffetargetRealDefault l, ffetargetIntegerDefault r)
{
  ffebad bad;

  if (ffetarget_iszero_real1 (l))
    {
      ffetarget_real1_zero (res);
      return FFEBAD;
    }

  if (r == 0)
    {
      ffetarget_real1_one (res);
      return FFEBAD;
    }

  if (r < 0)
    {
      ffetargetRealDefault one;

      ffetarget_real1_one (&one);
      r = -r;
      bad = ffetarget_divide_real1 (&l, one, l);
      if (bad != FFEBAD)
	return bad;
    }

  while ((r & 1) == 0)
    {
      bad = ffetarget_multiply_real1 (&l, l, l);
      if (bad != FFEBAD)
	return bad;
      r >>= 1;
    }

  *res = l;
  r >>= 1;

  while (r != 0)
    {
      bad = ffetarget_multiply_real1 (&l, l, l);
      if (bad != FFEBAD)
	return bad;
      if ((r & 1) == 1)
	{
	  bad = ffetarget_multiply_real1 (res, *res, l);
	  if (bad != FFEBAD)
	    return bad;
	}
      r >>= 1;
    }

  return FFEBAD;
}

/* ffetarget_power_realdouble_integerdefault -- Power function

   See prototype.  */

ffebad
ffetarget_power_realdouble_integerdefault (ffetargetRealDouble *res,
					   ffetargetRealDouble l,
					   ffetargetIntegerDefault r)
{
  ffebad bad;

  if (ffetarget_iszero_real2 (l))
    {
      ffetarget_real2_zero (res);
      return FFEBAD;
    }

  if (r == 0)
    {
      ffetarget_real2_one (res);
      return FFEBAD;
    }

  if (r < 0)
    {
      ffetargetRealDouble one;

      ffetarget_real2_one (&one);
      r = -r;
      bad = ffetarget_divide_real2 (&l, one, l);
      if (bad != FFEBAD)
	return bad;
    }

  while ((r & 1) == 0)
    {
      bad = ffetarget_multiply_real2 (&l, l, l);
      if (bad != FFEBAD)
	return bad;
      r >>= 1;
    }

  *res = l;
  r >>= 1;

  while (r != 0)
    {
      bad = ffetarget_multiply_real2 (&l, l, l);
      if (bad != FFEBAD)
	return bad;
      if ((r & 1) == 1)
	{
	  bad = ffetarget_multiply_real2 (res, *res, l);
	  if (bad != FFEBAD)
	    return bad;
	}
      r >>= 1;
    }

  return FFEBAD;
}

/* ffetarget_print_binary -- Output typeless binary integer

   ffetargetTypeless val;
   ffetarget_typeless_binary(dmpout,val);  */

void
ffetarget_print_binary (FILE *f, ffetargetTypeless value)
{
  char *p;
  char digits[sizeof (value) * CHAR_BIT + 1];

  if (f == NULL)
    f = dmpout;

  p = &digits[ARRAY_SIZE (digits) - 1];
  *p = '\0';
  do
    {
      *--p = (value & 1) + '0';
      value >>= 1;
    } while (value == 0);

  fputs (p, f);
}

/* ffetarget_print_character1 -- Output character string

   ffetargetCharacter1 val;
   ffetarget_print_character1(dmpout,val);  */

void
ffetarget_print_character1 (FILE *f, ffetargetCharacter1 value)
{
  unsigned char *p;
  ffetargetCharacterSize i;

  fputc ('\'', dmpout);
  for (i = 0, p = value.text; i < value.length; ++i, ++p)
    ffetarget_print_char_ (f, *p);
  fputc ('\'', dmpout);
}

/* ffetarget_print_hollerith -- Output hollerith string

   ffetargetHollerith val;
   ffetarget_print_hollerith(dmpout,val);  */

void
ffetarget_print_hollerith (FILE *f, ffetargetHollerith value)
{
  unsigned char *p;
  ffetargetHollerithSize i;

  fputc ('\'', dmpout);
  for (i = 0, p = value.text; i < value.length; ++i, ++p)
    ffetarget_print_char_ (f, *p);
  fputc ('\'', dmpout);
}

/* ffetarget_print_octal -- Output typeless octal integer

   ffetargetTypeless val;
   ffetarget_print_octal(dmpout,val);  */

void
ffetarget_print_octal (FILE *f, ffetargetTypeless value)
{
  char *p;
  char digits[sizeof (value) * CHAR_BIT / 3 + 1];

  if (f == NULL)
    f = dmpout;

  p = &digits[ARRAY_SIZE (digits) - 3];
  *p = '\0';
  do
    {
      *--p = (value & 3) + '0';
      value >>= 3;
    } while (value == 0);

  fputs (p, f);
}

/* ffetarget_print_hex -- Output typeless hex integer

   ffetargetTypeless val;
   ffetarget_print_hex(dmpout,val);  */

void
ffetarget_print_hex (FILE *f, ffetargetTypeless value)
{
  char *p;
  char digits[sizeof (value) * CHAR_BIT / 4 + 1];
  static char hexdigits[16] = "0123456789ABCDEF";

  if (f == NULL)
    f = dmpout;

  p = &digits[ARRAY_SIZE (digits) - 3];
  *p = '\0';
  do
    {
      *--p = hexdigits[value & 4];
      value >>= 4;
    } while (value == 0);

  fputs (p, f);
}

/* ffetarget_real1 -- Convert token to a single-precision real number

   See prototype.

   Pass NULL for any token not provided by the user, but a valid Fortran
   real number must be provided somehow.  For example, it is ok for
   exponent_sign_token and exponent_digits_token to be NULL as long as
   exponent_token not only starts with "E" or "e" but also contains at least
   one digit following it.  Token use counts not affected overall.  */

#if FFETARGET_okREAL1
bool
ffetarget_real1 (ffetargetReal1 *value, ffelexToken integer,
		 ffelexToken decimal, ffelexToken fraction,
		 ffelexToken exponent, ffelexToken exponent_sign,
		 ffelexToken exponent_digits)
{
  size_t sz = 1;		/* Allow room for '\0' byte at end. */
  char *ptr = &ffetarget_string_[0];
  char *p = ptr;
  char *q;

#define dotok(x) if (x != NULL) ++sz;
#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)

  dotoktxt (integer);
  dotok (decimal);
  dotoktxt (fraction);
  dotoktxt (exponent);
  dotok (exponent_sign);
  dotoktxt (exponent_digits);

#undef dotok
#undef dotoktxt

  if (sz > ARRAY_SIZE (ffetarget_string_))
    p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1",
				      sz);

#define dotoktxt(x) if (x != NULL)				   \
		  {						   \
		  for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
		    *p++ = *q;					   \
		  }

  dotoktxt (integer);

  if (decimal != NULL)
    *p++ = '.';

  dotoktxt (fraction);
  dotoktxt (exponent);

  if (exponent_sign != NULL)
    {
      if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
	*p++ = '+';
      else
	{
	  assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
	  *p++ = '-';
	}
    }

  dotoktxt (exponent_digits);

#undef dotoktxt

  *p = '\0';

  ffetarget_make_real1 (value,
			FFETARGET_ATOF_ (ptr,
					 SFmode));

  if (sz > ARRAY_SIZE (ffetarget_string_))
    malloc_kill_ks (malloc_pool_image (), ptr, sz);

  return TRUE;
}

#endif
/* ffetarget_real2 -- Convert token to a single-precision real number

   See prototype.

   Pass NULL for any token not provided by the user, but a valid Fortran
   real number must be provided somehow.  For example, it is ok for
   exponent_sign_token and exponent_digits_token to be NULL as long as
   exponent_token not only starts with "E" or "e" but also contains at least
   one digit following it.  Token use counts not affected overall.  */

#if FFETARGET_okREAL2
bool
ffetarget_real2 (ffetargetReal2 *value, ffelexToken integer,
		 ffelexToken decimal, ffelexToken fraction,
		 ffelexToken exponent, ffelexToken exponent_sign,
		 ffelexToken exponent_digits)
{
  size_t sz = 1;		/* Allow room for '\0' byte at end. */
  char *ptr = &ffetarget_string_[0];
  char *p = ptr;
  char *q;

#define dotok(x) if (x != NULL) ++sz;
#define dotoktxt(x) if (x != NULL) sz += ffelex_token_length(x)

  dotoktxt (integer);
  dotok (decimal);
  dotoktxt (fraction);
  dotoktxt (exponent);
  dotok (exponent_sign);
  dotoktxt (exponent_digits);

#undef dotok
#undef dotoktxt

  if (sz > ARRAY_SIZE (ffetarget_string_))
    p = ptr = (char *) malloc_new_ks (malloc_pool_image (), "ffetarget_real1", sz);

#define dotoktxt(x) if (x != NULL)				   \
		  {						   \
		  for (q = ffelex_token_text(x); *q != '\0'; ++q)  \
		    *p++ = *q;					   \
		  }
#define dotoktxtexp(x) if (x != NULL)				       \
		  {						       \
		  *p++ = 'E';					       \
		  for (q = ffelex_token_text(x) + 1; *q != '\0'; ++q)  \
		    *p++ = *q;					       \
		  }

  dotoktxt (integer);

  if (decimal != NULL)
    *p++ = '.';

  dotoktxt (fraction);
  dotoktxtexp (exponent);

  if (exponent_sign != NULL)
    {
      if (ffelex_token_type (exponent_sign) == FFELEX_typePLUS)
	*p++ = '+';
      else
	{
	  assert (ffelex_token_type (exponent_sign) == FFELEX_typeMINUS);
	  *p++ = '-';
	}
    }

  dotoktxt (exponent_digits);

#undef dotoktxt

  *p = '\0';

  ffetarget_make_real2 (value,
			FFETARGET_ATOF_ (ptr,
					 DFmode));

  if (sz > ARRAY_SIZE (ffetarget_string_))
    malloc_kill_ks (malloc_pool_image (), ptr, sz);

  return TRUE;
}

#endif
bool
ffetarget_typeless_binary (ffetargetTypeless *xvalue, ffelexToken token)
{
  char *p;
  char c;
  ffetargetTypeless value = 0;
  ffetargetTypeless new_value = 0;
  bool bad_digit = FALSE;
  bool overflow = FALSE;

  p = ffelex_token_text (token);

  for (c = *p; c != '\0'; c = *++p)
    {
      new_value <<= 1;
      if ((new_value >> 1) != value)
	overflow = TRUE;
      if (isdigit (c))
	new_value += c - '0';
      else
	bad_digit = TRUE;
      value = new_value;
    }

  if (bad_digit)
    {
      ffebad_start (FFEBAD_INVALID_TYPELESS_BINARY_DIGIT);
      ffebad_here (0, ffelex_token_where_line (token),
		   ffelex_token_where_column (token));
      ffebad_finish ();
    }
  else if (overflow)
    {
      ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
      ffebad_here (0, ffelex_token_where_line (token),
		   ffelex_token_where_column (token));
      ffebad_finish ();
    }

  *xvalue = value;

  return !bad_digit && !overflow;
}

bool
ffetarget_typeless_octal (ffetargetTypeless *xvalue, ffelexToken token)
{
  char *p;
  char c;
  ffetargetTypeless value = 0;
  ffetargetTypeless new_value = 0;
  bool bad_digit = FALSE;
  bool overflow = FALSE;

  p = ffelex_token_text (token);

  for (c = *p; c != '\0'; c = *++p)
    {
      new_value <<= 3;
      if ((new_value >> 3) != value)
	overflow = TRUE;
      if (isdigit (c))
	new_value += c - '0';
      else
	bad_digit = TRUE;
      value = new_value;
    }

  if (bad_digit)
    {
      ffebad_start (FFEBAD_INVALID_TYPELESS_OCTAL_DIGIT);
      ffebad_here (0, ffelex_token_where_line (token),
		   ffelex_token_where_column (token));
      ffebad_finish ();
    }
  else if (overflow)
    {
      ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
      ffebad_here (0, ffelex_token_where_line (token),
		   ffelex_token_where_column (token));
      ffebad_finish ();
    }

  *xvalue = value;

  return !bad_digit && !overflow;
}

bool
ffetarget_typeless_hex (ffetargetTypeless *xvalue, ffelexToken token)
{
  char *p;
  char c;
  ffetargetTypeless value = 0;
  ffetargetTypeless new_value = 0;
  bool bad_digit = FALSE;
  bool overflow = FALSE;

  p = ffelex_token_text (token);

  for (c = *p; c != '\0'; c = *++p)
    {
      new_value <<= 4;
      if ((new_value >> 4) != value)
	overflow = TRUE;
      if (isdigit (c))
	new_value += c - '0';
      else if ((c >= 'A') && (c <= 'F'))
	new_value += c - 'A' + 10;
      else if ((c >= 'a') && (c <= 'f'))
	new_value += c - 'a' + 10;
      else
	bad_digit = TRUE;
      value = new_value;
    }

  if (bad_digit)
    {
      ffebad_start (FFEBAD_INVALID_TYPELESS_HEX_DIGIT);
      ffebad_here (0, ffelex_token_where_line (token),
		   ffelex_token_where_column (token));
      ffebad_finish ();
    }
  else if (overflow)
    {
      ffebad_start (FFEBAD_TYPELESS_OVERFLOW);
      ffebad_here (0, ffelex_token_where_line (token),
		   ffelex_token_where_column (token));
      ffebad_finish ();
    }

  *xvalue = value;

  return !bad_digit && !overflow;
}

void
ffetarget_verify_character1 (mallocPool pool, ffetargetCharacter1 val)
{
  if (val.length != 0)
    malloc_verify_kp (pool, val.text, val.length);
}

/* This is like memcpy.	 It is needed because some systems' header files
   don't declare memcpy as a function but instead
   "#define memcpy(to,from,len) something".  */

void *
ffetarget_memcpy_ (void *dst, void *src, size_t len)
{
  return (void *) memcpy (dst, src, len);
}

/* ffetarget_num_digits_ -- Determine number of non-space characters in token

   ffetarget_num_digits_(token);

   All non-spaces are assumed to be binary, octal, or hex digits.  */

int
ffetarget_num_digits_ (ffelexToken token)
{
  int i;
  char *c;

  switch (ffelex_token_type (token))
    {
    case FFELEX_typeNAME:
    case FFELEX_typeNUMBER:
      return ffelex_token_length (token);

    case FFELEX_typeCHARACTER:
      i = 0;
      for (c = ffelex_token_text (token); *c != '\0'; ++c)
	{
	  if (*c != ' ')
	    ++i;
	}
      return i;

    default:
      assert ("weird token" == NULL);
      return 1;
    }
}

/* Begin the cruft g77 used to patch into gcc-2.7/real.c.  */

#include <errno.h>
#include "config.j"
#include "tree.j"

#ifdef REAL_ARITHMETIC
#define NEED_E53TOE	/* Compile e53toe, else avoid compiler warning. */

void warning (char *s, ...);  /* From toplev.c (no .h file). */

#ifndef errno
extern int errno;
#endif

/* To enable support of XFmode extended real floating point, define
LONG_DOUBLE_TYPE_SIZE 96 in the tm.h file (m68k.h or i386.h).

To support cross compilation between IEEE, VAX and IBM floating
point formats, define REAL_ARITHMETIC in the tm.h file.

In either case the machine files (tm.h) must not contain any code
that tries to use host floating point arithmetic to convert
REAL_VALUE_TYPEs from `double' to `float', pass them to fprintf,
etc.  In cross-compile situations a REAL_VALUE_TYPE may not
be intelligible to the host computer's native arithmetic.

The emulator defaults to the host's floating point format so that
its decimal conversion functions can be used if desired (see
real.h).

The first part of this file interfaces gcc to a floating point
arithmetic suite that was not written with gcc in mind.  Avoid
changing the low-level arithmetic routines unless you have suitable
test programs available.  A special version of the PARANOIA floating
point arithmetic tester, modified for this purpose, can be found on
usc.edu: /pub/C-numanal/ieeetest.zoo.  Other tests, and libraries of
XFmode and TFmode transcendental functions, can be obtained by ftp from
netlib.att.com: netlib/cephes.   */

/* Type of computer arithmetic.
   Only one of DEC, IBM, IEEE, or UNK should get defined.

   `IEEE', when REAL_WORDS_BIG_ENDIAN is non-zero, refers generically
   to big-endian IEEE floating-point data structure.  This definition
   should work in SFmode `float' type and DFmode `double' type on
   virtually all big-endian IEEE machines.  If LONG_DOUBLE_TYPE_SIZE
   has been defined to be 96, then IEEE also invokes the particular
   XFmode (`long double' type) data structure used by the Motorola
   680x0 series processors.

   `IEEE', when REAL_WORDS_BIG_ENDIAN is zero, refers generally to
   little-endian IEEE machines. In this case, if LONG_DOUBLE_TYPE_SIZE
   has been defined to be 96, then IEEE also invokes the particular
   XFmode `long double' data structure used by the Intel 80x86 series
   processors.

   `DEC' refers specifically to the Digital Equipment Corp PDP-11
   and VAX floating point data structure.  This model currently
   supports no type wider than DFmode.

   `IBM' refers specifically to the IBM System/370 and compatible
   floating point data structure.  This model currently supports
   no type wider than DFmode.  The IBM conversions were contributed by
   frank@atom.ansto.gov.au (Frank Crawford).

   If LONG_DOUBLE_TYPE_SIZE = 64 (the default, unless tm.h defines it)
   then `long double' and `double' are both implemented, but they
   both mean DFmode.  In this case, the software floating-point
   support available here is activated by writing
      #define REAL_ARITHMETIC
   in tm.h. 

   The case LONG_DOUBLE_TYPE_SIZE = 128 activates TFmode support
   and may deactivate XFmode since `long double' is used to refer
   to both modes.

   The macros FLOAT_WORDS_BIG_ENDIAN, HOST_FLOAT_WORDS_BIG_ENDIAN,
   contributed by Richard Earnshaw <Richard.Earnshaw@cl.cam.ac.uk>,
   separate the floating point unit's endian-ness from that of
   the integer addressing.  This permits one to define a big-endian
   FPU on a little-endian machine (e.g., ARM).  An extension to
   BYTES_BIG_ENDIAN may be required for some machines in the future.
   These optional macros may be defined in tm.h.  In real.h, they
   default to WORDS_BIG_ENDIAN, etc., so there is no need to define
   them for any normal host or target machine on which the floats
   and the integers have the same endian-ness.   */


/* The following converts gcc macros into the ones used by this file.  */

/* REAL_ARITHMETIC defined means that macros in real.h are
   defined to call emulator functions.  */
#ifdef REAL_ARITHMETIC

#if TARGET_FLOAT_FORMAT == VAX_FLOAT_FORMAT
/* PDP-11, Pro350, VAX: */
#define DEC 1
#else /* it's not VAX */
#if TARGET_FLOAT_FORMAT == IBM_FLOAT_FORMAT
/* IBM System/370 style */
#define IBM 1
#else /* it's also not an IBM */
#if TARGET_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
#define IEEE
#else /* it's not IEEE either */
/* UNKnown arithmetic.  We don't support this and can't go on. */
unknown arithmetic type
#define UNK 1
#endif /* not IEEE */
#endif /* not IBM */
#endif /* not VAX */

#define REAL_WORDS_BIG_ENDIAN FLOAT_WORDS_BIG_ENDIAN

#else
/* REAL_ARITHMETIC not defined means that the *host's* data
   structure will be used.  It may differ by endian-ness from the
   target machine's structure and will get its ends swapped
   accordingly (but not here).  Probably only the decimal <-> binary
   functions in this file will actually be used in this case.  */

#if HOST_FLOAT_FORMAT == VAX_FLOAT_FORMAT
#define DEC 1
#else /* it's not VAX */
#if HOST_FLOAT_FORMAT == IBM_FLOAT_FORMAT
/* IBM System/370 style */
#define IBM 1
#else /* it's also not an IBM */
#if HOST_FLOAT_FORMAT == IEEE_FLOAT_FORMAT
#define IEEE
#else /* it's not IEEE either */
unknown arithmetic type
#define UNK 1
#endif /* not IEEE */
#endif /* not IBM */
#endif /* not VAX */

#define REAL_WORDS_BIG_ENDIAN HOST_FLOAT_WORDS_BIG_ENDIAN

#endif /* REAL_ARITHMETIC not defined */

/* Define INFINITY for support of infinity.
   Define NANS for support of Not-a-Number's (NaN's).  */
#if !defined(DEC) && !defined(IBM)
#define INFINITY
#define NANS
#endif

/* Support of NaNs requires support of infinity. */
#ifdef NANS
#ifndef INFINITY
#define INFINITY
#endif
#endif

/* Find a host integer type that is at least 16 bits wide,
   and another type at least twice whatever that size is. */

#if HOST_BITS_PER_CHAR >= 16
#define EMUSHORT char
#define EMUSHORT_SIZE HOST_BITS_PER_CHAR
#define EMULONG_SIZE (2 * HOST_BITS_PER_CHAR)
#else
#if HOST_BITS_PER_SHORT >= 16
#define EMUSHORT short
#define EMUSHORT_SIZE HOST_BITS_PER_SHORT
#define EMULONG_SIZE (2 * HOST_BITS_PER_SHORT)
#else
#if HOST_BITS_PER_INT >= 16
#define EMUSHORT int
#define EMUSHORT_SIZE HOST_BITS_PER_INT
#define EMULONG_SIZE (2 * HOST_BITS_PER_INT)
#else
#if HOST_BITS_PER_LONG >= 16
#define EMUSHORT long
#define EMUSHORT_SIZE HOST_BITS_PER_LONG
#define EMULONG_SIZE (2 * HOST_BITS_PER_LONG)
#else
/*  You will have to modify this program to have a smaller unit size. */
#define EMU_NON_COMPILE
#endif
#endif
#endif
#endif

#if HOST_BITS_PER_SHORT >= EMULONG_SIZE
#define EMULONG short
#else
#if HOST_BITS_PER_INT >= EMULONG_SIZE
#define EMULONG int
#else
#if HOST_BITS_PER_LONG >= EMULONG_SIZE
#define EMULONG long
#else
#if HOST_BITS_PER_LONG_LONG >= EMULONG_SIZE
#define EMULONG long long int
#else
/*  You will have to modify this program to have a smaller unit size. */
#define EMU_NON_COMPILE
#endif
#endif
#endif
#endif


/* The host interface doesn't work if no 16-bit size exists. */
#if EMUSHORT_SIZE != 16
#define EMU_NON_COMPILE
#endif

/* OK to continue compilation. */
#ifndef EMU_NON_COMPILE

/* Construct macros to translate between REAL_VALUE_TYPE and e type.
   In GET_REAL and PUT_REAL, r and e are pointers.
   A REAL_VALUE_TYPE is guaranteed to occupy contiguous locations
   in memory, with no holes.  */

#if LONG_DOUBLE_TYPE_SIZE == 96
/* Number of 16 bit words in external e type format */
#define NE 6
#define MAXDECEXP 4932
#define MINDECEXP -4956
#define GET_REAL(r,e) bcopy ((char *) r, (char *) e, 2*NE)
#define PUT_REAL(e,r) bcopy ((char *) e, (char *) r, 2*NE)
#else /* no XFmode */
#if LONG_DOUBLE_TYPE_SIZE == 128
#define NE 10
#define MAXDECEXP 4932
#define MINDECEXP -4977
#define GET_REAL(r,e) bcopy ((char *) r, (char *) e, 2*NE)
#define PUT_REAL(e,r) bcopy ((char *) e, (char *) r, 2*NE)
#else
#define NE 6
#define MAXDECEXP 4932
#define MINDECEXP -4956

#define NEED_ETOE53	/* Compile etoe53, else avoid compiler warning. */

#ifdef REAL_ARITHMETIC
/* Emulator uses target format internally
   but host stores it in host endian-ness. */

#define GET_REAL(r,e)						\
do {								\
     if (HOST_FLOAT_WORDS_BIG_ENDIAN == REAL_WORDS_BIG_ENDIAN)	\
       e53toe ((unsigned EMUSHORT*) (r), (e));			\
     else							\
       {							\
	 unsigned EMUSHORT w[4];				\
	 w[3] = ((EMUSHORT *) r)[0];				\
	 w[2] = ((EMUSHORT *) r)[1];				\
	 w[1] = ((EMUSHORT *) r)[2];				\
	 w[0] = ((EMUSHORT *) r)[3];				\
	 e53toe (w, (e));					\
       }							\
   } while (0)

#define PUT_REAL(e,r)						\
do {								\
     if (HOST_FLOAT_WORDS_BIG_ENDIAN == REAL_WORDS_BIG_ENDIAN)	\
       etoe53 ((e), (unsigned EMUSHORT *) (r));			\
     else							\
       {							\
	 unsigned EMUSHORT w[4];				\
	 etoe53 ((e), w);					\
	 *((EMUSHORT *) r) = w[3];				\
	 *((EMUSHORT *) r + 1) = w[2];				\
	 *((EMUSHORT *) r + 2) = w[1];				\
	 *((EMUSHORT *) r + 3) = w[0];				\
       }							\
   } while (0)

#else /* not REAL_ARITHMETIC */

/* emulator uses host format */
#define GET_REAL(r,e) e53toe ((unsigned EMUSHORT *) (r), (e))
#define PUT_REAL(e,r) etoe53 ((e), (unsigned EMUSHORT *) (r))

#endif /* not REAL_ARITHMETIC */
#endif /* not TFmode */
#endif /* no XFmode */


/* Number of 16 bit words in internal format */
#define NI (NE+3)

/* Array offset to exponent */
#define E 1

/* Array offset to high guard word */
#define M 2

/* Number of bits of precision */
#define NBITS ((NI-4)*16)

/* Maximum number of decimal digits in ASCII conversion
 * = NBITS*log10(2)
 */
#define NDEC (NBITS*8/27)

/* The exponent of 1.0 */
#define EXONE (0x3fff)

extern int extra_warnings;
extern unsigned EMUSHORT ezero[], ehalf[], eone[], etwo[];
extern unsigned EMUSHORT elog2[], esqrt2[];

static void eclear	PROTO((unsigned EMUSHORT *));
static void eneg	PROTO((unsigned EMUSHORT *));
static int eisneg	PROTO((unsigned EMUSHORT *));
static int eisinf	PROTO((unsigned EMUSHORT *));
static int eisnan	PROTO((unsigned EMUSHORT *));
static void einfin	PROTO((unsigned EMUSHORT *));
static void enan	PROTO((unsigned EMUSHORT *, int));
static void emovi	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static void emovo	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static void ecleaz	PROTO((unsigned EMUSHORT *));
static void ecleazs	PROTO((unsigned EMUSHORT *));
static int eiisnan	PROTO((unsigned EMUSHORT *));
static int eiisneg	PROTO((unsigned EMUSHORT *));
static void eshdn1	PROTO((unsigned EMUSHORT *));
static void eshup1	PROTO((unsigned EMUSHORT *));
static void eshdn8	PROTO((unsigned EMUSHORT *));
static void eshup8	PROTO((unsigned EMUSHORT *));
static void eshup6	PROTO((unsigned EMUSHORT *));
static void eshdn6	PROTO((unsigned EMUSHORT *));
static void eaddm	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static void emdnorm	PROTO((unsigned EMUSHORT *, int, int, EMULONG, int));
static void e53toe	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static void e24toe	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static void etoe53	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static void toe53	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static int eshift	PROTO((unsigned EMUSHORT *, int));
static int enormlz	PROTO((unsigned EMUSHORT *));
static void mtherr	PROTO((char *, int));
#ifdef DEC
static void dectoe	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static void etodec	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
static void todec	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *));
#endif
#if IBM
static void ibmtoe	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *,
			       enum machine_mode));
static void etoibm	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *,
			       enum machine_mode));
static void toibm	PROTO((unsigned EMUSHORT *, unsigned EMUSHORT *,
			       enum machine_mode));
#endif
static void make_nan	PROTO((unsigned EMUSHORT *, int, enum machine_mode));

/*
  Extended precision IEEE binary floating point arithmetic routines

  Numbers are stored in C language as arrays of 16-bit unsigned
  short integers.  The arguments of the routines are pointers to
  the arrays.

  External e type data structure, similar to Intel 8087 chip
  temporary real format but possibly with a larger significand:

	NE-1 significand words	(least significant word first,
				 most significant bit is normally set)
	exponent		(value = EXONE for 1.0,
				top bit is the sign)


  Internal exploded e-type data structure of a number (a "word" is 16 bits):

  ei[0]	sign word	(0 for positive, 0xffff for negative)
  ei[1]	biased exponent	(value = EXONE for the number 1.0)
  ei[2]	high guard word	(always zero after normalization)
  ei[3]
  to ei[NI-2]	significand	(NI-4 significand words,
 				 most significant word first,
 				 most significant bit is set)
  ei[NI-1]	low guard word	(0x8000 bit is rounding place)
 
 
 
 		Routines for external format e-type numbers
 
 	asctoe (string, e)	ASCII string to extended double e type
 	asctoe64 (string, &d)	ASCII string to long double
 	asctoe53 (string, &d)	ASCII string to double
 	asctoe24 (string, &f)	ASCII string to single
 	asctoeg (string, e, prec) ASCII string to specified precision
 	e24toe (&f, e)		IEEE single precision to e type
 	e53toe (&d, e)		IEEE double precision to e type
 	e64toe (&d, e)		IEEE long double precision to e type
 	e113toe (&d, e)		128-bit long double precision to e type
 	eabs (e)			absolute value
 	eadd (a, b, c)		c = b + a
 	eclear (e)		e = 0
 	ecmp (a, b)		Returns 1 if a > b, 0 if a == b,
 				-1 if a < b, -2 if either a or b is a NaN.
 	ediv (a, b, c)		c = b / a
 	efloor (a, b)		truncate to integer, toward -infinity
 	efrexp (a, exp, s)	extract exponent and significand
 	eifrac (e, &l, frac)    e to HOST_WIDE_INT and e type fraction
 	euifrac (e, &l, frac)   e to unsigned HOST_WIDE_INT and e type fraction
 	einfin (e)		set e to infinity, leaving its sign alone
 	eldexp (a, n, b)	multiply by 2**n
 	emov (a, b)		b = a
 	emul (a, b, c)		c = b * a
 	eneg (e)			e = -e
 	eround (a, b)		b = nearest integer value to a
 	esub (a, b, c)		c = b - a
 	e24toasc (&f, str, n)	single to ASCII string, n digits after decimal
 	e53toasc (&d, str, n)	double to ASCII string, n digits after decimal
 	e64toasc (&d, str, n)	80-bit long double to ASCII string
 	e113toasc (&d, str, n)	128-bit long double to ASCII string
 	etoasc (e, str, n)	e to ASCII string, n digits after decimal
 	etoe24 (e, &f)		convert e type to IEEE single precision
 	etoe53 (e, &d)		convert e type to IEEE double precision
 	etoe64 (e, &d)		convert e type to IEEE long double precision
 	ltoe (&l, e)		HOST_WIDE_INT to e type
 	ultoe (&l, e)		unsigned HOST_WIDE_INT to e type
	eisneg (e)              1 if sign bit of e != 0, else 0
	eisinf (e)              1 if e has maximum exponent (non-IEEE)
 				or is infinite (IEEE)
        eisnan (e)              1 if e is a NaN
 

 		Routines for internal format exploded e-type numbers
 
 	eaddm (ai, bi)		add significands, bi = bi + ai
 	ecleaz (ei)		ei = 0
 	ecleazs (ei)		set ei = 0 but leave its sign alone
 	ecmpm (ai, bi)		compare significands, return 1, 0, or -1
 	edivm (ai, bi)		divide  significands, bi = bi / ai
 	emdnorm (ai,l,s,exp)	normalize and round off
 	emovi (a, ai)		convert external a to internal ai
 	emovo (ai, a)		convert internal ai to external a
 	emovz (ai, bi)		bi = ai, low guard word of bi = 0
 	emulm (ai, bi)		multiply significands, bi = bi * ai
 	enormlz (ei)		left-justify the significand
 	eshdn1 (ai)		shift significand and guards down 1 bit
 	eshdn8 (ai)		shift down 8 bits
 	eshdn6 (ai)		shift down 16 bits
 	eshift (ai, n)		shift ai n bits up (or down if n < 0)
 	eshup1 (ai)		shift significand and guards up 1 bit
 	eshup8 (ai)		shift up 8 bits
 	eshup6 (ai)		shift up 16 bits
 	esubm (ai, bi)		subtract significands, bi = bi - ai
        eiisinf (ai)            1 if infinite
        eiisnan (ai)            1 if a NaN
 	eiisneg (ai)		1 if sign bit of ai != 0, else 0
        einan (ai)              set ai = NaN
        eiinfin (ai)            set ai = infinity

  The result is always normalized and rounded to NI-4 word precision
  after each arithmetic operation.

  Exception flags are NOT fully supported.
 
  Signaling NaN's are NOT supported; they are treated the same
  as quiet NaN's.
 
  Define INFINITY for support of infinity; otherwise a
  saturation arithmetic is implemented.
 
  Define NANS for support of Not-a-Number items; otherwise the
  arithmetic will never produce a NaN output, and might be confused
  by a NaN input.
  If NaN's are supported, the output of `ecmp (a,b)' is -2 if
  either a or b is a NaN. This means asking `if (ecmp (a,b) < 0)'
  may not be legitimate. Use `if (ecmp (a,b) == -1)' for `less than'
  if in doubt.
 
  Denormals are always supported here where appropriate (e.g., not
  for conversion to DEC numbers).  */

/* Definitions for error codes that are passed to the common error handling
   routine mtherr.

   For Digital Equipment PDP-11 and VAX computers, certain
  IBM systems, and others that use numbers with a 56-bit
  significand, the symbol DEC should be defined.  In this
  mode, most floating point constants are given as arrays
  of octal integers to eliminate decimal to binary conversion
  errors that might be introduced by the compiler.
 
  For computers, such as IBM PC, that follow the IEEE
  Standard for Binary Floating Point Arithmetic (ANSI/IEEE
  Std 754-1985), the symbol IEEE should be defined.
  These numbers have 53-bit significands.  In this mode, constants
  are provided as arrays of hexadecimal 16 bit integers.
  The endian-ness of generated values is controlled by
  REAL_WORDS_BIG_ENDIAN.
 
  To accommodate other types of computer arithmetic, all
  constants are also provided in a normal decimal radix
  which one can hope are correctly converted to a suitable
  format by the available C language compiler.  To invoke
  this mode, the symbol UNK is defined.
 
  An important difference among these modes is a predefined
  set of machine arithmetic constants for each.  The numbers
  MACHEP (the machine roundoff error), MAXNUM (largest number
  represented), and several other parameters are preset by
  the configuration symbol.  Check the file const.c to
  ensure that these values are correct for your computer.
 
  For ANSI C compatibility, define ANSIC equal to 1.  Currently
  this affects only the atan2 function and others that use it. */

/* Constant definitions for math error conditions.  */

#define DOMAIN		1	/* argument domain error */
#define SING		2	/* argument singularity */
#define OVERFLOW	3	/* overflow range error */
#define UNDERFLOW	4	/* underflow range error */
#define TLOSS		5	/* total loss of precision */
#define PLOSS		6	/* partial loss of precision */
#define INVALID		7	/* NaN-producing operation */

#if 0
extern unsigned EMUSHORT ezero[];
extern unsigned EMUSHORT ehalf[];
extern unsigned EMUSHORT eone[];
extern unsigned EMUSHORT etwo[];
extern unsigned EMUSHORT e32[];
extern unsigned EMUSHORT elog2[];
extern unsigned EMUSHORT esqrt2[];
extern unsigned EMUSHORT epi[];
#endif

/* Control register for rounding precision.
   This can be set to 113 (if NE=10), 80 (if NE=6), 64, 56, 53, or 24 bits.  */

extern int rndprc;

/*  Clear out entire e-type number X.  */

/* KEEP */
static void 
eclear (x)
     register unsigned EMUSHORT *x;
{
  register int i;

  for (i = 0; i < NE; i++)
    *x++ = 0;
}

/* Negate the e-type number X.  */

/* KEEP */
static void 
eneg (x)
     unsigned EMUSHORT x[];
{

  x[NE - 1] ^= 0x8000;		/* Toggle the sign bit */
}

/* Return 1 if sign bit of e-type number X is nonzero, else zero.  */

/* KEEP */
static int 
eisneg (x)
     unsigned EMUSHORT x[];
{

  if (x[NE - 1] & 0x8000)
    return (1);
  else
    return (0);
}

/* Return 1 if e-type number X is infinity, else return zero.  */

/* KEEP */
static int 
eisinf (x)
     unsigned EMUSHORT x[];
{

#ifdef NANS
  if (eisnan (x))
    return (0);
#endif
  if ((x[NE - 1] & 0x7fff) == 0x7fff)
    return (1);
  else
    return (0);
}

/* Check if e-type number is not a number.  The bit pattern is one that we
   defined, so we know for sure how to detect it.  */

/* KEEP */
static int 
eisnan (x)
     unsigned EMUSHORT x[];
{
#ifdef NANS
  int i;

  /* NaN has maximum exponent */
  if ((x[NE - 1] & 0x7fff) != 0x7fff)
    return (0);
  /* ... and non-zero significand field. */
  for (i = 0; i < NE - 1; i++)
    {
      if (*x++ != 0)
        return (1);
    }
#endif

  return (0);
}

/*  Fill e-type number X with infinity pattern (IEEE)
    or largest possible number (non-IEEE). */

/* KEEP */
static void 
einfin (x)
     register unsigned EMUSHORT *x;
{
  register int i;

#ifdef INFINITY
  for (i = 0; i < NE - 1; i++)
    *x++ = 0;
  *x |= 32767;
#else
  for (i = 0; i < NE - 1; i++)
    *x++ = 0xffff;
  *x |= 32766;
  if (rndprc < NBITS)
    {
      if (rndprc == 113)
	{
	  *(x - 9) = 0;
	  *(x - 8) = 0;
	}
      if (rndprc == 64)
	{
	  *(x - 5) = 0;
	}
      if (rndprc == 53)
	{
	  *(x - 4) = 0xf800;
	}
      else
	{
	  *(x - 4) = 0;
	  *(x - 3) = 0;
	  *(x - 2) = 0xff00;
	}
    }
#endif
}

/* Output an e-type NaN.
   This generates Intel's quiet NaN pattern for extended real.
   The exponent is 7fff, the leading mantissa word is c000.  */

/* KEEP */
static void 
enan (x, sign)
     register unsigned EMUSHORT *x;
     int sign;
{
  register int i;

  for (i = 0; i < NE - 2; i++)
    *x++ = 0;
  *x++ = 0xc000;
  *x = (sign << 15) | 0x7fff;
}

/* Move in an e-type number A, converting it to exploded e-type B.  */

/* KEEP */
static void 
emovi (a, b)
     unsigned EMUSHORT *a, *b;
{
  register unsigned EMUSHORT *p, *q;
  int i;

  q = b;
  p = a + (NE - 1);		/* point to last word of external number */
  /* get the sign bit */
  if (*p & 0x8000)
    *q++ = 0xffff;
  else
    *q++ = 0;
  /* get the exponent */
  *q = *p--;
  *q++ &= 0x7fff;		/* delete the sign bit */
#ifdef INFINITY
  if ((*(q - 1) & 0x7fff) == 0x7fff)
    {
#ifdef NANS
      if (eisnan (a))
	{
	  *q++ = 0;
	  for (i = 3; i < NI; i++)
	    *q++ = *p--;
	  return;
	}
#endif

      for (i = 2; i < NI; i++)
	*q++ = 0;
      return;
    }
#endif

  /* clear high guard word */
  *q++ = 0;
  /* move in the significand */
  for (i = 0; i < NE - 1; i++)
    *q++ = *p--;
  /* clear low guard word */
  *q = 0;
}

/* Move out exploded e-type number A, converting it to e type B.  */

/* KEEP */
static void 
emovo (a, b)
     unsigned EMUSHORT *a, *b;
{
  register unsigned EMUSHORT *p, *q;
  unsigned EMUSHORT i;
  int j;

  p = a;
  q = b + (NE - 1);		/* point to output exponent */
  /* combine sign and exponent */
  i = *p++;
  if (i)
    *q-- = *p++ | 0x8000;
  else
    *q-- = *p++;
#ifdef INFINITY
  if (*(p - 1) == 0x7fff)
    {
#ifdef NANS
      if (eiisnan (a))
	{
	  enan (b, eiisneg (a));
	  return;
	}
#endif
      einfin (b);
	return;
    }
#endif
  /* skip over guard word */
  ++p;
  /* move the significand */
  for (j = 0; j < NE - 1; j++)
    *q-- = *p++;
}

/* Clear out exploded e-type number XI.  */

/* KEEP */
static void 
ecleaz (xi)
     register unsigned EMUSHORT *xi;
{
  register int i;

  for (i = 0; i < NI; i++)
    *xi++ = 0;
}

/* Clear out exploded e-type XI, but don't touch the sign. */

/* KEEP */
static void 
ecleazs (xi)
     register unsigned EMUSHORT *xi;
{
  register int i;

  ++xi;
  for (i = 0; i < NI - 1; i++)
    *xi++ = 0;
}

/* Return nonzero if exploded e-type X is a NaN. */

/* KEEP */
static int 
eiisnan (x)
     unsigned EMUSHORT x[];
{
  int i;

  if ((x[E] & 0x7fff) == 0x7fff)
    {
      for (i = M + 1; i < NI; i++)
	{
	  if (x[i] != 0)
	    return (1);
	}
    }
  return (0);
}

/* Return nonzero if sign of exploded e-type X is nonzero.  */

/* KEEP */
static int 
eiisneg (x)
     unsigned EMUSHORT x[];
{

  return x[0] != 0;
}

/* Shift significand of exploded e-type X down by 1 bit.  */

/* KEEP */
static void 
eshdn1 (x)
     register unsigned EMUSHORT *x;
{
  register unsigned EMUSHORT bits;
  int i;

  x += M;			/* point to significand area */

  bits = 0;
  for (i = M; i < NI; i++)
    {
      if (*x & 1)
	bits |= 1;
      *x >>= 1;
      if (bits & 2)
	*x |= 0x8000;
      bits <<= 1;
      ++x;
    }
}

/* Shift significand of exploded e-type X up by 1 bit.  */

/* KEEP */
static void 
eshup1 (x)
     register unsigned EMUSHORT *x;
{
  register unsigned EMUSHORT bits;
  int i;

  x += NI - 1;
  bits = 0;

  for (i = M; i < NI; i++)
    {
      if (*x & 0x8000)
	bits |= 1;
      *x <<= 1;
      if (bits & 2)
	*x |= 1;
      bits <<= 1;
      --x;
    }
}


/* Shift significand of exploded e-type X down by 8 bits.  */

/* KEEP */
static void 
eshdn8 (x)
     register unsigned EMUSHORT *x;
{
  register unsigned EMUSHORT newbyt, oldbyt;
  int i;

  x += M;
  oldbyt = 0;
  for (i = M; i < NI; i++)
    {
      newbyt = *x << 8;
      *x >>= 8;
      *x |= oldbyt;
      oldbyt = newbyt;
      ++x;
    }
}

/* Shift significand of exploded e-type X up by 8 bits.  */

/* KEEP */
static void 
eshup8 (x)
     register unsigned EMUSHORT *x;
{
  int i;
  register unsigned EMUSHORT newbyt, oldbyt;

  x += NI - 1;
  oldbyt = 0;

  for (i = M; i < NI; i++)
    {
      newbyt = *x >> 8;
      *x <<= 8;
      *x |= oldbyt;
      oldbyt = newbyt;
      --x;
    }
}

/* Shift significand of exploded e-type X up by 16 bits.  */

/* KEEP */
static void 
eshup6 (x)
     register unsigned EMUSHORT *x;
{
  int i;
  register unsigned EMUSHORT *p;

  p = x + M;
  x += M + 1;

  for (i = M; i < NI - 1; i++)
    *p++ = *x++;

  *p = 0;
}

/* Shift significand of exploded e-type X down by 16 bits.  */

/* KEEP */
static void 
eshdn6 (x)
     register unsigned EMUSHORT *x;
{
  int i;
  register unsigned EMUSHORT *p;

  x += NI - 1;
  p = x + 1;

  for (i = M; i < NI - 1; i++)
    *(--p) = *(--x);

  *(--p) = 0;
}

/* Add significands of exploded e-type X and Y.  X + Y replaces Y.  */

/* KEEP */
static void 
eaddm (x, y)
     unsigned EMUSHORT *x, *y;
{
  register unsigned EMULONG a;
  int i;
  unsigned int carry;

  x += NI - 1;
  y += NI - 1;
  carry = 0;
  for (i = M; i < NI; i++)
    {
      a = (unsigned EMULONG) (*x) + (unsigned EMULONG) (*y) + carry;
      if (a & 0x10000)
	carry = 1;
      else
	carry = 0;
      *y = (unsigned EMUSHORT) a;
      --x;
      --y;
    }
}

/* Normalize and round off.

  The internal format number to be rounded is S.
  Input LOST is 0 if the value is exact.  This is the so-called sticky bit.
 
  Input SUBFLG indicates whether the number was obtained
  by a subtraction operation.  In that case if LOST is nonzero
  then the number is slightly smaller than indicated.
 
  Input EXP is the biased exponent, which may be negative.
  the exponent field of S is ignored but is replaced by
  EXP as adjusted by normalization and rounding.
 
  Input RCNTRL is the rounding control.  If it is nonzero, the
  returned value will be rounded to RNDPRC bits.

  For future reference:  In order for emdnorm to round off denormal
   significands at the right point, the input exponent must be
   adjusted to be the actual value it would have after conversion to
   the final floating point type.  This adjustment has been
   implemented for all type conversions (etoe53, etc.) and decimal
   conversions, but not for the arithmetic functions (eadd, etc.). 
   Data types having standard 15-bit exponents are not affected by
   this, but SFmode and DFmode are affected. For example, ediv with
   rndprc = 24 will not round correctly to 24-bit precision if the
   result is denormal.   */

static int rlast = -1;
static int rw = 0;
static unsigned EMUSHORT rmsk = 0;
static unsigned EMUSHORT rmbit = 0;
static unsigned EMUSHORT rebit = 0;
static int re = 0;
static unsigned EMUSHORT rbit[NI];

/* KEEP */
static void 
emdnorm (s, lost, subflg, exp, rcntrl)
     unsigned EMUSHORT s[];
     int lost;
     int subflg;
     EMULONG exp;
     int rcntrl;
{
  int i, j;
  unsigned EMUSHORT r;

  /* Normalize */
  j = enormlz (s);

  /* a blank significand could mean either zero or infinity. */
#ifndef INFINITY
  if (j > NBITS)
    {
      ecleazs (s);
      return;
    }
#endif
  exp -= j;
#ifndef INFINITY
  if (exp >= 32767L)
    goto overf;
#else
  if ((j > NBITS) && (exp < 32767))
    {
      ecleazs (s);
      return;
    }
#endif
  if (exp < 0L)
    {
      if (exp > (EMULONG) (-NBITS - 1))
	{
	  j = (int) exp;
	  i = eshift (s, j);
	  if (i)
	    lost = 1;
	}
      else
	{
	  ecleazs (s);
	  return;
	}
    }
  /* Round off, unless told not to by rcntrl. */
  if (rcntrl == 0)
    goto mdfin;
  /* Set up rounding parameters if the control register changed. */
  if (rndprc != rlast)
    {
      ecleaz (rbit);
      switch (rndprc)
	{
	default:
	case NBITS:
	  rw = NI - 1;		/* low guard word */
	  rmsk = 0xffff;
	  rmbit = 0x8000;
	  re = rw - 1;
	  rebit = 1;
	  break;
	case 113:
	  rw = 10;
	  rmsk = 0x7fff;
	  rmbit = 0x4000;
	  rebit = 0x8000;
	  re = rw;
	  break;
	case 64:
	  rw = 7;
	  rmsk = 0xffff;
	  rmbit = 0x8000;
	  re = rw - 1;
	  rebit = 1;
	  break;
	  /* For DEC or IBM arithmetic */
	case 56:
	  rw = 6;
	  rmsk = 0xff;
	  rmbit = 0x80;
	  rebit = 0x100;
	  re = rw;
	  break;
	case 53:
	  rw = 6;
	  rmsk = 0x7ff;
	  rmbit = 0x0400;
	  rebit = 0x800;
	  re = rw;
	  break;
	case 24:
	  rw = 4;
	  rmsk = 0xff;
	  rmbit = 0x80;
	  rebit = 0x100;
	  re = rw;
	  break;
	}
      rbit[re] = rebit;
      rlast = rndprc;
    }

  /* Shift down 1 temporarily if the data structure has an implied
     most significant bit and the number is denormal.
     Intel long double denormals also lose one bit of precision.  */
  if ((exp <= 0) && (rndprc != NBITS)
      && ((rndprc != 64) || ((rndprc == 64) && ! REAL_WORDS_BIG_ENDIAN)))
    {
      lost |= s[NI - 1] & 1;
      eshdn1 (s);
    }
  /* Clear out all bits below the rounding bit,
     remembering in r if any were nonzero.  */
  r = s[rw] & rmsk;
  if (rndprc < NBITS)
    {
      i = rw + 1;
      while (i < NI)
	{
	  if (s[i])
	    r |= 1;
	  s[i] = 0;
	  ++i;
	}
    }
  s[rw] &= ~rmsk;
  if ((r & rmbit) != 0)
    {
      if (r == rmbit)
	{
	  if (lost == 0)
	    {			/* round to even */
	      if ((s[re] & rebit) == 0)
		goto mddone;
	    }
	  else
	    {
	      if (subflg != 0)
		goto mddone;
	    }
	}
      eaddm (rbit, s);
    }
 mddone:
/* Undo the temporary shift for denormal values. */
  if ((exp <= 0) && (rndprc != NBITS)
      && ((rndprc != 64) || ((rndprc == 64) && ! REAL_WORDS_BIG_ENDIAN)))
    {
      eshup1 (s);
    }
  if (s[2] != 0)
    {				/* overflow on roundoff */
      eshdn1 (s);
      exp += 1;
    }
 mdfin:
  s[NI - 1] = 0;
  if (exp >= 32767L)
    {
#ifndef INFINITY
    overf:
#endif
#ifdef INFINITY
      s[1] = 32767;
      for (i = 2; i < NI - 1; i++)
	s[i] = 0;
      if (extra_warnings)
	warning ("floating point overflow");
#else
      s[1] = 32766;
      s[2] = 0;
      for (i = M + 1; i < NI - 1; i++)
	s[i] = 0xffff;
      s[NI - 1] = 0;
      if ((rndprc < 64) || (rndprc == 113))
	{
	  s[rw] &= ~rmsk;
	  if (rndprc == 24)
	    {
	      s[5] = 0;
	      s[6] = 0;
	    }
	}
#endif
      return;
    }
  if (exp < 0)
    s[1] = 0;
  else
    s[1] = (unsigned EMUSHORT) exp;
}

/* Convert double precision PE to e-type Y.  */

#if 1 || defined (NEED_E53TOE)	/* Can't get all this stuff right at the moment. */

/* KEEP */
static void
e53toe (pe, y)
     unsigned EMUSHORT *pe, *y;
{
#ifdef DEC

  dectoe (pe, y);

#else
#ifdef IBM

  ibmtoe (pe, y, DFmode);

#else
  register unsigned EMUSHORT r;
  register unsigned EMUSHORT *e, *p;
  unsigned EMUSHORT yy[NI];
  int denorm, k;

  e = pe;
  denorm = 0;			/* flag if denormalized number */
  ecleaz (yy);
  if (! REAL_WORDS_BIG_ENDIAN)
    e += 3;
  r = *e;
  yy[0] = 0;
  if (r & 0x8000)
    yy[0] = 0xffff;
  yy[M] = (r & 0x0f) | 0x10;
  r &= ~0x800f;			/* strip sign and 4 significand bits */
#ifdef INFINITY
  if (r == 0x7ff0)
    {
#ifdef NANS
      if (! REAL_WORDS_BIG_ENDIAN)
	{
	  if (((pe[3] & 0xf) != 0) || (pe[2] != 0)
	      || (pe[1] != 0) || (pe[0] != 0))
	    {
	      enan (y, yy[0] != 0);
	      return;
	    }
	}
      else
	{
	  if (((pe[0] & 0xf) != 0) || (pe[1] != 0)
	      || (pe[2] != 0) || (pe[3] != 0))
	    {
	      enan (y, yy[0] != 0);
	      return;
	    }
	}
#endif  /* NANS */
      eclear (y);
      einfin (y);
      if (yy[0])
	eneg (y);
      return;
    }
#endif  /* INFINITY */
  r >>= 4;
  /* If zero exponent, then the significand is denormalized.
     So take back the understood high significand bit. */

  if (r == 0)
    {
      denorm = 1;
      yy[M] &= ~0x10;
    }
  r += EXONE - 01777;
  yy[E] = r;
  p = &yy[M + 1];
#ifdef IEEE
  if (! REAL_WORDS_BIG_ENDIAN)
    {
      *p++ = *(--e);
      *p++ = *(--e);
      *p++ = *(--e);
    }
  else
    {
      ++e;
      *p++ = *e++;
      *p++ = *e++;
      *p++ = *e++;
    }
#endif
  eshift (yy, -5);
  if (denorm)
    {				/* if zero exponent, then normalize the significand */
      if ((k = enormlz (yy)) > NBITS)
	ecleazs (yy);
      else
	yy[E] -= (unsigned EMUSHORT) (k - 1);
    }
  emovo (yy, y);
#endif /* not IBM */
#endif /* not DEC */
}

#endif /* defined (NEED_E53TOE) */

/* Convert single precision float PE to e type Y.  */

/* KEEP */
static void 
e24toe (pe, y)
     unsigned EMUSHORT *pe, *y;
{
#ifdef IBM

  ibmtoe (pe, y, SFmode);

#else
  register unsigned EMUSHORT r;
  register unsigned EMUSHORT *e, *p;
  unsigned EMUSHORT yy[NI];
  int denorm, k;

  e = pe;
  denorm = 0;			/* flag if denormalized number */
  ecleaz (yy);
#ifdef IEEE
  if (! REAL_WORDS_BIG_ENDIAN)
    e += 1;
#endif
#ifdef DEC
  e += 1;
#endif
  r = *e;
  yy[0] = 0;
  if (r & 0x8000)
    yy[0] = 0xffff;
  yy[M] = (r & 0x7f) | 0200;
  r &= ~0x807f;			/* strip sign and 7 significand bits */
#ifdef INFINITY
  if (r == 0x7f80)
    {
#ifdef NANS
      if (REAL_WORDS_BIG_ENDIAN)
	{
	  if (((pe[0] & 0x7f) != 0) || (pe[1] != 0))
	    {
	      enan (y, yy[0] != 0);
	      return;
	    }
	}
      else
	{
	  if (((pe[1] & 0x7f) != 0) || (pe[0] != 0))
	    {
	      enan (y, yy[0] != 0);
	      return;
	    }
	}
#endif  /* NANS */
      eclear (y);
      einfin (y);
      if (yy[0])
	eneg (y);
      return;
    }
#endif  /* INFINITY */
  r >>= 7;
  /* If zero exponent, then the significand is denormalized.
     So take back the understood high significand bit. */
  if (r == 0)
    {
      denorm = 1;
      yy[M] &= ~0200;
    }
  r += EXONE - 0177;
  yy[E] = r;
  p = &yy[M + 1];
#ifdef DEC
  *p++ = *(--e);
#endif
#ifdef IEEE
  if (! REAL_WORDS_BIG_ENDIAN)
    *p++ = *(--e);
  else
    {
      ++e;
      *p++ = *e++;
    }
#endif
  eshift (yy, -8);
  if (denorm)
    {				/* if zero exponent, then normalize the significand */
      if ((k = enormlz (yy)) > NBITS)
	ecleazs (yy);
      else
	yy[E] -= (unsigned EMUSHORT) (k - 1);
    }
  emovo (yy, y);
#endif /* not IBM */
}

/* e type to double precision.  */

#ifdef DEC
/* Convert e-type X to DEC-format double E.  */

#if 1 || defined (NEED_ETOE53)

/* KEEP */
static void 
etoe53 (x, e)
     unsigned EMUSHORT *x, *e;
{
  etodec (x, e);		/* see etodec.c */
}

#endif	/* defined (NEED_ETOE53) */

/* Convert exploded e-type X, that has already been rounded to
   56-bit double precision, to DEC double Y.  */

/* KEEP */
static void 
toe53 (x, y)
     unsigned EMUSHORT *x, *y;
{
  todec (x, y);
}

#else
#ifdef IBM
/* Convert e-type X to IBM 370-format double E.  */

#if 1 || defined (NEED_ETOE53)

/* KEEP */
static void 
etoe53 (x, e)
     unsigned EMUSHORT *x, *e;
{
  etoibm (x, e, DFmode);
}

#endif	/* defined (NEED_ETOE53) */

/* Convert exploded e-type X, that has already been rounded to
   56-bit precision, to IBM 370 double Y.  */

/* KEEP */
static void 
toe53 (x, y)
     unsigned EMUSHORT *x, *y;
{
  toibm (x, y, DFmode);
}

#else  /* it's neither DEC nor IBM */

/* Convert e-type X to IEEE double E.  */

#if 1 || defined (NEED_ETOE53)

/* KEEP */
static void 
etoe53 (x, e)
     unsigned EMUSHORT *x, *e;
{
  unsigned EMUSHORT xi[NI];
  EMULONG exp;
  int rndsav;

#ifdef NANS
  if (eisnan (x))
    {
      make_nan (e, eisneg (x), DFmode);
      return;
    }
#endif
  emovi (x, xi);
  /* adjust exponent for offsets */
  exp = (EMULONG) xi[E] - (EXONE - 0x3ff);
#ifdef INFINITY
  if (eisinf (x))
    goto nonorm;
#endif
  /* round off to nearest or even */
  rndsav = rndprc;
  rndprc = 53;
  emdnorm (xi, 0, 0, exp, 64);
  rndprc = rndsav;
 nonorm:
  toe53 (xi, e);
}

#endif	/* defined (NEED_ETOE53) */

/* Convert exploded e-type X, that has already been rounded to
   53-bit precision, to IEEE double Y.  */

/* KEEP */
static void 
toe53 (x, y)
     unsigned EMUSHORT *x, *y;
{
  unsigned EMUSHORT i;
  unsigned EMUSHORT *p;

#ifdef NANS
  if (eiisnan (x))
    {
      make_nan (y, eiisneg (x), DFmode);
      return;
    }
#endif
  p = &x[0];
#ifdef IEEE
  if (! REAL_WORDS_BIG_ENDIAN)
    y += 3;
#endif
  *y = 0;			/* output high order */
  if (*p++)
    *y = 0x8000;		/* output sign bit */

  i = *p++;
  if (i >= (unsigned int) 2047)
    {				/* Saturate at largest number less than infinity. */
#ifdef INFINITY
      *y |= 0x7ff0;
      if (! REAL_WORDS_BIG_ENDIAN)
	{
	  *(--y) = 0;
	  *(--y) = 0;
	  *(--y) = 0;
	}
      else
	{
	  ++y;
	  *y++ = 0;
	  *y++ = 0;
	  *y++ = 0;
	}
#else
      *y |= (unsigned EMUSHORT) 0x7fef;
      if (! REAL_WORDS_BIG_ENDIAN)
	{
	  *(--y) = 0xffff;
	  *(--y) = 0xffff;
	  *(--y) = 0xffff;
	}
      else
	{
	  ++y;
	  *y++ = 0xffff;
	  *y++ = 0xffff;
	  *y++ = 0xffff;
	}
#endif
      return;
    }
  if (i == 0)
    {
      eshift (x, 4);
    }
  else
    {
      i <<= 4;
      eshift (x, 5);
    }
  i |= *p++ & (unsigned EMUSHORT) 0x0f;	/* *p = xi[M] */
  *y |= (unsigned EMUSHORT) i;	/* high order output already has sign bit set */
  if (! REAL_WORDS_BIG_ENDIAN)
    {
      *(--y) = *p++;
      *(--y) = *p++;
      *(--y) = *p;
    }
  else
    {
      ++y;
      *y++ = *p++;
      *y++ = *p++;
      *y++ = *p++;
    }
}

#endif /* not IBM */
#endif /* not DEC */

/* Shift the significand of exploded e-type X up or down by SC bits.  */

/* KEEP */
static int 
eshift (x, sc)
     unsigned EMUSHORT *x;
     int sc;
{
  unsigned EMUSHORT lost;
  unsigned EMUSHORT *p;

  if (sc == 0)
    return (0);

  lost = 0;
  p = x + NI - 1;

  if (sc < 0)
    {
      sc = -sc;
      while (sc >= 16)
	{
	  lost |= *p;		/* remember lost bits */
	  eshdn6 (x);
	  sc -= 16;
	}

      while (sc >= 8)
	{
	  lost |= *p & 0xff;
	  eshdn8 (x);
	  sc -= 8;
	}

      while (sc > 0)
	{
	  lost |= *p & 1;
	  eshdn1 (x);
	  sc -= 1;
	}
    }
  else
    {
      while (sc >= 16)
	{
	  eshup6 (x);
	  sc -= 16;
	}

      while (sc >= 8)
	{
	  eshup8 (x);
	  sc -= 8;
	}

      while (sc > 0)
	{
	  eshup1 (x);
	  sc -= 1;
	}
    }
  if (lost)
    lost = 1;
  return ((int) lost);
}

/* Shift normalize the significand area of exploded e-type X.
   Return the shift count (up = positive).  */

/* KEEP */
static int 
enormlz (x)
     unsigned EMUSHORT x[];
{
  register unsigned EMUSHORT *p;
  int sc;

  sc = 0;
  p = &x[M];
  if (*p != 0)
    goto normdn;
  ++p;
  if (*p & 0x8000)
    return (0);			/* already normalized */
  while (*p == 0)
    {
      eshup6 (x);
      sc += 16;

      /* With guard word, there are NBITS+16 bits available.
       Return true if all are zero.  */
      if (sc > NBITS)
	return (sc);
    }
  /* see if high byte is zero */
  while ((*p & 0xff00) == 0)
    {
      eshup8 (x);
      sc += 8;
    }
  /* now shift 1 bit at a time */
  while ((*p & 0x8000) == 0)
    {
      eshup1 (x);
      sc += 1;
      if (sc > NBITS)
	{
	  mtherr ("enormlz", UNDERFLOW);
	  return (sc);
	}
    }
  return (sc);

  /* Normalize by shifting down out of the high guard word
     of the significand */
 normdn:

  if (*p & 0xff00)
    {
      eshdn8 (x);
      sc -= 8;
    }
  while (*p != 0)
    {
      eshdn1 (x);
      sc -= 1;

      if (sc < -NBITS)
	{
	  mtherr ("enormlz", OVERFLOW);
	  return (sc);
	}
    }
  return (sc);
}

/* Report an error condition CODE encountered in function NAME.
   CODE is one of the following:

    Mnemonic        Value          Significance
 
     DOMAIN            1       argument domain error
     SING              2       function singularity
     OVERFLOW          3       overflow range error
     UNDERFLOW         4       underflow range error
     TLOSS             5       total loss of precision
     PLOSS             6       partial loss of precision
     INVALID           7       NaN - producing operation
     EDOM             33       Unix domain error code
     ERANGE           34       Unix range error code
 
   The order of appearance of the following messages is bound to the
   error codes defined above.  */

#define NMSGS 8
static char *ermsg[NMSGS] =
{
  "unknown",			/* error code 0 */
  "domain",			/* error code 1 */
  "singularity",		/* et seq.      */
  "overflow",
  "underflow",
  "total loss of precision",
  "partial loss of precision",
  "invalid operation"
};

extern int merror;

/* KEEP */
static void 
mtherr (name, code)
     char *name;
     int code;
{
  char errstr[80];

  /* The string passed by the calling program is supposed to be the
     name of the function in which the error occurred.
     The code argument selects which error message string will be printed.  */

  if ((code <= 0) || (code >= NMSGS))
    code = 0;
  sprintf (errstr, " %s %s error", name, ermsg[code]);
  if (extra_warnings)
    warning (errstr);
  /* Set global error message word */
  merror = code + 1;
}

#ifdef DEC
/* Convert DEC double precision D to e type E.  */

/* KEEP */
static void 
dectoe (d, e)
     unsigned EMUSHORT *d;
     unsigned EMUSHORT *e;
{
  unsigned EMUSHORT y[NI];
  register unsigned EMUSHORT r, *p;

  ecleaz (y);			/* start with a zero */
  p = y;			/* point to our number */
  r = *d;			/* get DEC exponent word */
  if (*d & (unsigned int) 0x8000)
    *p = 0xffff;		/* fill in our sign */
  ++p;				/* bump pointer to our exponent word */
  r &= 0x7fff;			/* strip the sign bit */
  if (r == 0)			/* answer = 0 if high order DEC word = 0 */
    goto done;


  r >>= 7;			/* shift exponent word down 7 bits */
  r += EXONE - 0201;		/* subtract DEC exponent offset */
  /* add our e type exponent offset */
  *p++ = r;			/* to form our exponent */

  r = *d++;			/* now do the high order mantissa */
  r &= 0177;			/* strip off the DEC exponent and sign bits */
  r |= 0200;			/* the DEC understood high order mantissa bit */
  *p++ = r;			/* put result in our high guard word */

  *p++ = *d++;			/* fill in the rest of our mantissa */
  *p++ = *d++;
  *p = *d;

  eshdn8 (y);			/* shift our mantissa down 8 bits */
 done:
  emovo (y, e);
}

/* Convert e type X to DEC double precision D.  */

/* KEEP */
static void 
etodec (x, d)
     unsigned EMUSHORT *x, *d;
{
  unsigned EMUSHORT xi[NI];
  EMULONG exp;
  int rndsav;

  emovi (x, xi);
  /* Adjust exponent for offsets.  */
  exp = (EMULONG) xi[E] - (EXONE - 0201);
  /* Round off to nearest or even.  */
  rndsav = rndprc;
  rndprc = 56;
  emdnorm (xi, 0, 0, exp, 64);
  rndprc = rndsav;
  todec (xi, d);
}

/* Convert exploded e-type X, that has already been rounded to
   56-bit precision, to DEC format double Y.  */

/* KEEP */
static void 
todec (x, y)
     unsigned EMUSHORT *x, *y;
{
  unsigned EMUSHORT i;
  unsigned EMUSHORT *p;

  p = x;
  *y = 0;
  if (*p++)
    *y = 0100000;
  i = *p++;
  if (i == 0)
    {
      *y++ = 0;
      *y++ = 0;
      *y++ = 0;
      *y++ = 0;
      return;
    }
  if (i > 0377)
    {
      *y++ |= 077777;
      *y++ = 0xffff;
      *y++ = 0xffff;
      *y++ = 0xffff;
#ifdef ERANGE
      errno = ERANGE;
#endif
      return;
    }
  i &= 0377;
  i <<= 7;
  eshup8 (x);
  x[M] &= 0177;
  i |= x[M];
  *y++ |= i;
  *y++ = x[M + 1];
  *y++ = x[M + 2];
  *y++ = x[M + 3];
}
#endif /* DEC */

#ifdef IBM
/* Convert IBM single/double precision to e type.  */

/* KEEP */
static void 
ibmtoe (d, e, mode)
     unsigned EMUSHORT *d;
     unsigned EMUSHORT *e;
     enum machine_mode mode;
{
  unsigned EMUSHORT y[NI];
  register unsigned EMUSHORT r, *p;
  int rndsav;

  ecleaz (y);			/* start with a zero */
  p = y;			/* point to our number */
  r = *d;			/* get IBM exponent word */
  if (*d & (unsigned int) 0x8000)
    *p = 0xffff;		/* fill in our sign */
  ++p;				/* bump pointer to our exponent word */
  r &= 0x7f00;			/* strip the sign bit */
  r >>= 6;			/* shift exponent word down 6 bits */
				/* in fact shift by 8 right and 2 left */
  r += EXONE - (0x41 << 2);	/* subtract IBM exponent offset */
  				/* add our e type exponent offset */
  *p++ = r;			/* to form our exponent */

  *p++ = *d++ & 0xff;		/* now do the high order mantissa */
				/* strip off the IBM exponent and sign bits */
  if (mode != SFmode)		/* there are only 2 words in SFmode */
    {
      *p++ = *d++;		/* fill in the rest of our mantissa */
      *p++ = *d++;
    }
  *p = *d;

  if (y[M] == 0 && y[M+1] == 0 && y[M+2] == 0 && y[M+3] == 0)
    y[0] = y[E] = 0;
  else
    y[E] -= 5 + enormlz (y);	/* now normalise the mantissa */
			      /* handle change in RADIX */
  emovo (y, e);
}



/* Convert e type to IBM single/double precision.  */

/* KEEP */
static void 
etoibm (x, d, mode)
     unsigned EMUSHORT *x, *d;
     enum machine_mode mode;
{
  unsigned EMUSHORT xi[NI];
  EMULONG exp;
  int rndsav;

  emovi (x, xi);
  exp = (EMULONG) xi[E] - (EXONE - (0x41 << 2));	/* adjust exponent for offsets */
							/* round off to nearest or even */
  rndsav = rndprc;
  rndprc = 56;
  emdnorm (xi, 0, 0, exp, 64);
  rndprc = rndsav;
  toibm (xi, d, mode);
}

/* KEEP */
static void 
toibm (x, y, mode)
     unsigned EMUSHORT *x, *y;
     enum machine_mode mode;
{
  unsigned EMUSHORT i;
  unsigned EMUSHORT *p;
  int r;

  p = x;
  *y = 0;
  if (*p++)
    *y = 0x8000;
  i = *p++;
  if (i == 0)
    {
      *y++ = 0;
      *y++ = 0;
      if (mode != SFmode)
	{
	  *y++ = 0;
	  *y++ = 0;
	}
      return;
    }
  r = i & 0x3;
  i >>= 2;
  if (i > 0x7f)
    {
      *y++ |= 0x7fff;
      *y++ = 0xffff;
      if (mode != SFmode)
	{
	  *y++ = 0xffff;
	  *y++ = 0xffff;
	}
#ifdef ERANGE
      errno = ERANGE;
#endif
      return;
    }
  i &= 0x7f;
  *y |= (i << 8);
  eshift (x, r + 5);
  *y++ |= x[M];
  *y++ = x[M + 1];
  if (mode != SFmode)
    {
      *y++ = x[M + 2];
      *y++ = x[M + 3];
    }
}
#endif /* IBM */

/* Output a binary NaN bit pattern in the target machine's format.  */

/* If special NaN bit patterns are required, define them in tm.h
   as arrays of unsigned 16-bit shorts.  Otherwise, use the default
   patterns here. */
#ifdef TFMODE_NAN
TFMODE_NAN;
#else
#ifdef IEEE
extern unsigned EMUSHORT TFbignan[];
extern unsigned EMUSHORT TFlittlenan[];
#endif
#endif

#ifdef XFMODE_NAN
XFMODE_NAN;
#else
#ifdef IEEE
extern unsigned EMUSHORT XFbignan[];
extern unsigned EMUSHORT XFlittlenan[];
#endif
#endif

#ifdef DFMODE_NAN
DFMODE_NAN;
#else
#ifdef IEEE
extern unsigned EMUSHORT DFbignan[];
extern unsigned EMUSHORT DFlittlenan[];
#endif
#endif

#ifdef SFMODE_NAN
SFMODE_NAN;
#else
#ifdef IEEE
extern unsigned EMUSHORT SFbignan[];
extern unsigned EMUSHORT SFlittlenan[];
#endif
#endif


/* KEEP */
static void
make_nan (nan, sign, mode)
     unsigned EMUSHORT *nan;
     int sign;
     enum machine_mode mode;
{
  int n;
  unsigned EMUSHORT *p;

  switch (mode)
    {
/* Possibly the `reserved operand' patterns on a VAX can be
   used like NaN's, but probably not in the same way as IEEE. */
#if !defined(DEC) && !defined(IBM)
    case TFmode:
      n = 8;
      if (REAL_WORDS_BIG_ENDIAN)
	p = TFbignan;
      else
	p = TFlittlenan;
      break;
    case XFmode:
      n = 6;
      if (REAL_WORDS_BIG_ENDIAN)
	p = XFbignan;
      else
	p = XFlittlenan;
      break;
    case DFmode:
      n = 4;
      if (REAL_WORDS_BIG_ENDIAN)
	p = DFbignan;
      else
	p = DFlittlenan;
      break;
    case HFmode:
    case SFmode:
      n = 2;
      if (REAL_WORDS_BIG_ENDIAN)
	p = SFbignan;
      else
	p = SFlittlenan;
      break;
#endif
    default:
      abort ();
    }
  if (REAL_WORDS_BIG_ENDIAN)
    *nan++ = (sign << 15) | *p++;
  while (--n != 0)
    *nan++ = *p++;
  if (! REAL_WORDS_BIG_ENDIAN)
    *nan = (sign << 15) | *p;
}

/* This is the inverse of the function `etarsingle' invoked by
   REAL_VALUE_TO_TARGET_SINGLE.  */

REAL_VALUE_TYPE
ereal_unto_float (f)
     long f;
{
  REAL_VALUE_TYPE r;
  unsigned EMUSHORT s[2];
  unsigned EMUSHORT e[NE];

  /* Convert 32 bit integer to array of 16 bit pieces in target machine order.
   This is the inverse operation to what the function `endian' does.  */
  if (REAL_WORDS_BIG_ENDIAN)
    {
      s[0] = (unsigned EMUSHORT) (f >> 16);
      s[1] = (unsigned EMUSHORT) f;
    }
  else
    {
      s[0] = (unsigned EMUSHORT) f;
      s[1] = (unsigned EMUSHORT) (f >> 16);
    }
  /* Convert and promote the target float to E-type. */
  e24toe (s, e);
  /* Output E-type to REAL_VALUE_TYPE. */
  PUT_REAL (e, &r);
  return r;
}


/* This is the inverse of the function `etardouble' invoked by
   REAL_VALUE_TO_TARGET_DOUBLE.  */

REAL_VALUE_TYPE
ereal_unto_double (d)
     long d[];
{
  REAL_VALUE_TYPE r;
  unsigned EMUSHORT s[4];
  unsigned EMUSHORT e[NE];

  /* Convert array of HOST_WIDE_INT to equivalent array of 16-bit pieces.  */
  if (REAL_WORDS_BIG_ENDIAN)
    {
      s[0] = (unsigned EMUSHORT) (d[0] >> 16);
      s[1] = (unsigned EMUSHORT) d[0];
      s[2] = (unsigned EMUSHORT) (d[1] >> 16);
      s[3] = (unsigned EMUSHORT) d[1];
    }
  else
    {
      /* Target float words are little-endian.  */
      s[0] = (unsigned EMUSHORT) d[0];
      s[1] = (unsigned EMUSHORT) (d[0] >> 16);
      s[2] = (unsigned EMUSHORT) d[1];
      s[3] = (unsigned EMUSHORT) (d[1] >> 16);
    }
  /* Convert target double to E-type. */
  e53toe (s, e);
  /* Output E-type to REAL_VALUE_TYPE. */
  PUT_REAL (e, &r);
  return r;
}
#endif /* EMU_NON_COMPILE not defined */

#endif /* defined (REAL_ARITHMETIC) */

/* End the cruft g77 used to patch into gcc-2.7/real.h.  */
