Initial integration of G77.

Please do a make cleandir before rebuilding gcc!

1 files changed, 2290 insertions, 0 deletions

diff --git a/gnu/usr.bin/gcc/f/target.c b/gnu/usr.bin/gcc/f/target.c
new file mode 100644
index 00000000000..93cb698743a
--- /dev/null
+++ b/gnu/usr.bin/gcc/f/target.c
@@ -0,0 +1,2290 @@
+/* target.c -- Implementation File (module.c template V1.0)
+   Copyright (C) 1995 Free Software Foundation, Inc.
+   Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
+
+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;
+}
+
+#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);
+      memcpy (val->text, ffelex_token_text (character), val->length);
+    }
+
+  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
+
+   Compare lengths, if equal then use memcmp.  */
+
+#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);
+      if (l.length != 0)
+	memcpy (res->text, l.text, l.length);
+      if (r.length != 0)
+	memcpy (res->text + l.length, r.text, r.length);
+    }
+
+  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
+
+   Compare lengths, if equal then use memcmp.  */
+
+#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);
+      memcpy (res->text, l.text + first - 1, *len);
+    }
+
+  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;
+}
+
+#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);
+      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);
+	}
+    }
+
+  return FFEBAD;
+}
+
+#endif
+#if FFETARGET_okCHARACTER1
+ffebad
+ffetarget_convert_character1_hollerith (ffetargetCharacter1 *res,
+					ffetargetCharacterSize size,
+					ffetargetHollerith l, mallocPool pool)
+{
+  res->length = size;
+  if (size == 0)
+    res->text = NULL;
+  else
+    {
+      res->text = malloc_new_kp (pool, "FFETARGET cvt char1", size);
+      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_integer1 -- Raw conversion.  */
+
+#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);
+      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_logical1 -- Raw conversion.  */
+
+#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);
+      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.  */
+
+#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);
+      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
+
+   See prototype.
+
+   Token use count not affected overall.  */
+
+bool
+ffetarget_hollerith (ffetargetHollerith *val, ffelexToken integer,
+		     mallocPool pool)
+{
+  val->length = ffelex_token_length (integer);
+  val->text = malloc_new_kp (pool, "ffetargetHollerith", val->length);
+  memcpy (val->text, ffelex_token_text (integer), val->length);
+
+  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_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_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 0				/* Don't complain about signed overflow; just
+				   unsigned overflow. */
+      if ((x == FFETARGET_integerALMOST_BIG_OVERFLOW_OCTAL)
+	  && (c == '0' + 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 > '0' + 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 - '0';
+      if (c >= '8')
+	bad_digit = TRUE;
+      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;
+    }
+}