target.c

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

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

This file is part of GNU Fortran.

GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

   Related Modules:
      None

   Description:
      Implements conversion of lexer tokens to machine-dependent numerical
      form and accordingly issues diagnostic messages when necessary.

      Also, this module, especially its .h file, provides nearly all of the
      information on the target machine's data type, kind type, and length
      type capabilities.  The idea is that by carefully going through
      target.h and changing things properly, one can accomplish much
      towards the porting of the FFE to a new machine.	There are limits
      to how much this can accomplish towards that end, however.  For one
      thing, the ffeexpr_collapse_convert function doesn't contain all the
      conversion cases necessary, because the text file would be
      enormous (even though most of the function would be cut during the
      cpp phase because of the absence of the types), so when adding to
      the number of supported kind types for a given type, one must look
      to see if ffeexpr_collapse_convert needs modification in this area,
      in addition to providing the appropriate macros and functions in
      ffetarget.  Note that if combinatorial explosion actually becomes a
      problem for a given machine, one might have to modify the way conversion
      expressions are built so that instead of just one conversion expr, a
      series of conversion exprs are built to make a path from one type to
      another that is not a "near neighbor".  For now, however, with a handful
      of each of the numeric types and only one character type, things appear
      manageable.

      A nonobvious change to ffetarget would be if the target machine was
      not a 2's-complement machine.  Any item with the word "magical" (case-
      insensitive) in the FFE's source code (at least) indicates an assumption
      that a 2's-complement machine is the target, and thus that there exists
      a magnitude that can be represented as a negative number but not as
      a positive number.  It is possible that this situation can be dealt
      with by changing only ffetarget, for example, on a 1's-complement
      machine, perhaps #defineing ffetarget_constant_is_magical to simply
      FALSE along with making the appropriate changes in ffetarget's number
      parsing functions would be sufficient to effectively "comment out" code
      in places like ffeexpr that do certain magical checks.  But it is
      possible there are other 2's-complement dependencies lurking in the
      FFE (as possibly is true of any large program); if you find any, please
      report them so we can replace them with dependencies on ffetarget
      instead.

   Modifications:
*/

/* Include files. */

#include "proj.h"
#include "glimits.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))
	fputc (c, f);
      else
	fprintf (f, "\\%03o", (unsigned int) c);
      break;
    }
}

/* ffetarget_aggregate_info -- Determine type for aggregate storage area

   See prototype.

   If aggregate type is distinct, just return it.  Else return a type
   representing a common denominator for the nondistinct type (for now,
   just return default character, since that'll work on almost all target
   machines).

   The rules for abt/akt are (as implemented by ffestorag_update):

   abt == FFEINFO_basictypeANY (akt == FFEINFO_kindtypeANY also, by
   definition): CHARACTER and non-CHARACTER types mixed.

   abt == FFEINFO_basictypeNONE (akt == FFEINFO_kindtypeNONE also, by
   definition): More than one non-CHARACTER type mixed, but no CHARACTER
   types mixed in.

   abt some other value, akt == FFEINFO_kindtypeNONE: abt indicates the
   only basic type mixed in, but more than one kind type is mixed in.

   abt some other value, akt some other value: abt and akt indicate the
   only type represented in the aggregation.  */

void
ffetarget_aggregate_info (ffeinfoBasictype *ebt, ffeinfoKindtype *ekt,
			  ffetargetAlign *units, ffeinfoBasictype abt,
			  ffeinfoKindtype akt)
{
  ffetype type;

  if ((abt == FFEINFO_basictypeNONE) || (abt == FFEINFO_basictypeANY)
      || (akt == FFEINFO_kindtypeNONE))
    {
      *ebt = FFEINFO_basictypeCHARACTER;
      *ekt = FFEINFO_kindtypeCHARACTERDEFAULT;
    }
  else
    {
      *ebt = abt;
      *ekt = akt;
    }

  type = ffeinfo_type (*ebt, *ekt);
  assert (type != NULL);

  *units = ffetype_size (type);
}

/* ffetarget_align -- Align one storage area to superordinate, update super

   See prototype.

   updated_alignment/updated_modulo contain the already existing
   alignment requirements for the storage area at whose offset the
   object with alignment requirements alignment/modulo is to be placed.
   Find the smallest pad such that the requirements are maintained and
   return it, but only after updating the updated_alignment/_modulo
   requirements as necessary to indicate the placement of the new object.  */

ffetargetAlign
ffetarget_align (ffetargetAlign *updated_alignment,
		 ffetargetAlign *updated_modulo, ffetargetOffset offset,
		 ffetargetAlign alignment, ffetargetAlign modulo)
{
  ffetargetAlign pad;
  ffetargetAlign min_pad;	/* Minimum amount of padding needed. */
  ffetargetAlign min_m = 0;	/* Minimum-padding m. */
  ffetargetAlign ua;		/* Updated alignment. */
  ffetargetAlign um;		/* Updated modulo. */
  ffetargetAlign ucnt;		/* Multiplier applied to ua. */
  ffetargetAlign m;		/* Copy of modulo. */
  ffetargetAlign cnt;		/* Multiplier applied to alignment. */
  ffetargetAlign i;
  ffetargetAlign j;

  assert (alignment > 0);
  assert (*updated_alignment > 0);
  
  assert (*updated_modulo < *updated_alignment);
  assert (modulo < alignment);

  /* The easy case: similar alignment requirements.  */
  if (*updated_alignment == alignment)
    {
      if (modulo > *updated_modulo)
	pad = alignment - (modulo - *updated_modulo);
      else
	pad = *updated_modulo - modulo;
      if (offset < 0)
	/* De-negatize offset, since % wouldn't do the expected thing.  */
	offset = alignment - ((- offset) % alignment);
      pad = (offset + pad) % alignment;
      if (pad != 0)
	pad = alignment - pad;
      return pad;
    }

  /* Sigh, find LCM (Least Common Multiple) for the two alignment factors. */

  for (ua = *updated_alignment, ucnt = 1;
       ua % alignment != 0;
       ua += *updated_alignment)
    ++ucnt;

  cnt = ua / alignment;

  if (offset < 0)
    /* De-negatize offset, since % wouldn't do the expected thing.  */
    offset = ua - ((- offset) % ua);

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

  /* Find all combinations of modulo values the two alignment requirements
     have; pick the combination that results in the smallest padding
     requirement.  Of course, if a zero-pad requirement is encountered, just
     use that one. */

  for (um = *updated_modulo, i = 0; i < ucnt; um += *updated_alignment, ++i)
    {
      for (m = modulo, j = 0; j < cnt; m += alignment, ++j)
	{
	  /* This code is similar to the "easy case" code above. */
	  if (m > um)
	    pad = ua - (m - um);
	  else
	    pad = um - m;
	  pad = (offset + pad) % ua;
	  if (pad == 0)
	    {
	      /* A zero pad means we've got something useful.  */
	      *updated_alignment = ua;
	      *updated_modulo = um;
	      return 0;
	    }
	  pad = ua - pad;
	  if (pad < min_pad)
	    {			/* New minimum padding value. */
	      min_pad = pad;
	      min_m = um;
	    }
	}
    }

  *updated_alignment = ua;
  *updated_modulo = min_m;
  return min_pad;
}

/* Always append a null byte to the end, in case this is wanted in
   a special case such as passing a string as a FORMAT or %REF.
   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
   because it isn't a "feature" that is self-documenting.  Use the
   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
   in the code.  */

#if FFETARGET_okCHARACTER1
bool
ffetarget_character1 (ffetargetCharacter1 *val, ffelexToken character,
		      mallocPool pool)
{
  val->length = ffelex_token_length (character);
  if (val->length == 0)
    val->text = NULL;
  else
    {
      val->text = malloc_new_kp (pool, "ffetargetCharacter1", val->length + 1);
      memcpy (val->text, ffelex_token_text (character), val->length);
      val->text[val->length] = '\0';
    }

  return TRUE;
}

#endif
/* Produce orderable comparison between two constants

   Compare lengths, if equal then use memcmp.  */

#if FFETARGET_okCHARACTER1
int
ffetarget_cmp_character1 (ffetargetCharacter1 l, ffetargetCharacter1 r)
{
  if (l.length < r.length)
    return -1;
  if (l.length > r.length)
    return 1;
  if (l.length == 0)
    return 0;
  return memcmp (l.text, r.text, l.length);
}

#endif
/* ffetarget_concatenate_character1 -- Perform CONCAT op on two constants

   Always append a null byte to the end, in case this is wanted in
   a special case such as passing a string as a FORMAT or %REF.
   Done to save a bit of hassle, nothing more, but it's a kludge anyway,
   because it isn't a "feature" that is self-documenting.  Use the
   string "FFETARGET-NULL-KLUDGE" to flag anyplace you use this feature
   in the code.  */

#if FFETARGET_okCHARACTER1
ffebad
ffetarget_concatenate_character1 (ffetargetCharacter1 *res,
	      ffetargetCharacter1 l, ffetargetCharacter1 r, mallocPool pool,
				  ffetargetCharacterSize *len)
{
  res->length = *len = l.length + r.length;
  if (*len == 0)
    res->text = NULL;
  else
    {
      res->text = malloc_new_kp (pool, "ffetargetCharacter1(CONCAT)", *len + 1);
      if (l.length != 0)
	memcpy (res->text, l.text, l.length);
      if (r.length != 0)
	memcpy (res->text + l.length, r.text, r.length);
      res->text[*len] = '\0';
    }

  return FFEBAD;
}

#endif
/* ffetarget_eq_character1 -- Perform relational comparison on char constants

   Compare lengths, if equal then use memcmp.  */

#if FFETARGET_okCHARACTER1
ffebad
ffetarget_eq_character1 (bool *res, ffetargetCharacter1 l,
			 ffetargetCharacter1 r)
{
  assert (l.length == r.length);
  *res = (memcmp (l.text, r.text, l.length) == 0);
  return FFEBAD;
}

#endif
/* ffetarget_le_character1 -- Perform relational comparison on char constants

   Compare lengths, if equal then use memcmp.  */

#if FFETARGET_okCHARACTER1
ffebad
ffetarget_le_character1 (bool *res, ffetargetCharacter1 l,
			 ffetargetCharacter1 r)
{
  assert (l.length == r.length);
  *res = (memcmp (l.text, r.text, l.length) <= 0);
  return FFEBAD;
}

#endif
/* ffetarget_lt_character1 -- Perform relational comparison on char constants

   Compare lengths, if equal then use memcmp.  */

#if FFETARGET_okCHARACTER1
ffebad
ffetarget_lt_character1 (bool *res, ffetargetCharacter1 l,
			 ffetargetCharacter1 r)
{
  assert (l.length == r.length);
  *res = (memcmp (l.text, r.text, l.length) < 0);
  return FFEBAD;
}

#endif
/* ffetarget_ge_character1 -- Perform relational comparison on char constants

   Compare lengths, if equal then use memcmp.  */

#if FFETARGET_okCHARACTER1
ffebad
ffetarget_ge_character1 (bool *res, ffetargetCharacter1 l,
			 ffetargetCharacter1 r)
{
  assert (l.length == r.length);
  *res = (memcmp (l.text, r.text, l.length) >= 0);
  return FFEBAD;
}

#endif
/* ffetarget_gt_character1 -- Perform relational comparison on char constants

   Compare lengths, if equal then use memcmp.  */

#if FFETARGET_okCHARACTER1
ffebad
ffetarget_gt_character1 (bool *res, ffetargetCharacter1 l,
			 ffetargetCharacter1 r)
{
  assert (l.length == r.length);
  *res = (memcmp (l.text, r.text, l.length) > 0);
  return FFEBAD;
}
#endif

#if FFETARGET_okCHARACTER1
bool
ffetarget_iszero_character1 (ffetargetCharacter1 constant)
{
  ffetargetCharacterSize i;

  for (i = 0; i < constant.length; ++i)
    if (constant.text[i] != 0)
      return FALSE;
  return TRUE;
}
#endif

bool
ffetarget_iszero_hollerith (ffetargetHollerith constant)
{
  ffetargetHollerithSize i;

  for (i = 0; i < constant.length; ++i)
    if (constant.text[i] != 0)
      return FALSE;
  return TRUE;
}

/* ffetarget_layout -- Do storage requirement analysis for entity

   Return the alignment/modulo requirements along with the size, given the
   data type info and the number of elements an array (1 for a scalar).	 */

void
ffetarget_layout (const char *error_text UNUSED, ffetargetAlign *alignment,
		  ffetargetAlign *modulo, ffetargetOffset *size,
		  ffeinfoBasictype bt, ffeinfoKindtype kt,
		  ffetargetCharacterSize charsize,
		  ffetargetIntegerDefault num_elements)
{
  bool ok;			/* For character type. */
  ffetargetOffset numele;	/* Converted from num_elements. */
  ffetype type;

  type = ffeinfo_type (bt, kt);
  assert (type != NULL);

  *alignment = ffetype_alignment (type);
  *modulo = ffetype_modulo (type);
  if (bt == FFEINFO_basictypeCHARACTER)
    {
      ok = ffetarget_offset_charsize (size, charsize, ffetype_size (type));
#ifdef ffetarget_offset_overflow
      if (!ok)
	ffetarget_offset_overflow (error_text);
#endif
    }
  else
    *size = ffetype_size (type);

  if ((num_elements < 0)
      || !ffetarget_offset (&numele, num_elements)
      || !ffetarget_offset_multiply (size, *size, numele))
    {
      ffetarget_offset_overflow (error_text);
      *alignment = 1;
      *modulo = 0;
      *size = 0;
    }
}

/* ffetarget_ne_character1 -- Perform relational comparison on char constants

   Compare lengths, if equal then use memcmp.  */

#if FFETARGET_okCHARACTER1