target.c

gcc-2.95.3 Linux下最常用的C编译器

    {
      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;
    }
}