equiv.c

来自「gcc-2.95.3 Linux下最常用的C编译器」· C语言 代码 · 共 1,499 行 · 第 1/3 页

#if FFEEQUIV_DEBUG
		  fprintf (stderr, " (was %" ffetargetOffset_f "d).\n",
			   ffestorag_offset (item_st));
#endif
		  /* Make sure offset agrees with known offset. */
		  if (item_offset != ffestorag_offset (item_st))
		    {
		      char io1[40];
		      char io2[40];

		      sprintf (&io1[0], "%" ffetargetOffset_f "d", item_offset);
		      sprintf (&io2[0], "%" ffetargetOffset_f "d", ffestorag_offset (item_st));
		      ffebad_start (FFEBAD_EQUIV_MISMATCH);
		      ffebad_string (ffesymbol_text (item_sym));
		      ffebad_string (ffesymbol_text (root_sym));
		      ffebad_string (io1);
		      ffebad_string (io2);
		      ffebad_finish ();
		    }
		}
	      ffesymbol_set_equiv (item_sym, NULL);	/* Don't bother with me anymore. */
	    }			/* (For every equivalence item in the list) */
	  ffebld_set_head (list, NULL);	/* Don't do this list again. */
	}			/* (For every equivalence list in the list of
				   equivs) */
    } while (new_storage && need_storage);

  ffesymbol_set_equiv (root_sym, NULL);	/* This one has storage now. */

  ffeequiv_kill (eq);		/* Fully processed, no longer needed. */

  /* If the offset for this storage area is zero (it cannot be positive),
     that means the alignment/modulo info is already correct.  Otherwise,
     the alignment info is correct, but the modulo info reflects a
     zero offset, so fix it.  */

  if (ffestorag_offset (st) < 0)
    {
      /* Calculate the initial padding necessary to preserve
	 the alignment/modulo requirements for the storage area.
	 These requirements are themselves kept track of in the
	 record for the storage area as a whole, but really pertain
	 to offset 0 of that area, which is where the root symbol
	 was originally placed.

	 The goal here is to have the offset and size for the area
	 faithfully reflect the area itself, not extra requirements
	 like alignment.  So to meet the alignment requirements,
	 the modulo for the area should be set as if the area had an
	 alignment requirement of alignment/0 and was aligned/padded
	 downward to meet the alignment requirements of the area at
	 offset zero, the amount of padding needed being the desired
	 value for the modulo of the area.  */

      alignment = ffestorag_alignment (st);
      modulo = ffestorag_modulo (st);

      /* Since we want to move the whole area *down* (lower memory
	 addresses) as required by the alignment/modulo paid, negate
	 the offset to ffetarget_align, which assumes aligning *up*
	 is desired.  */
      pad = ffetarget_align (&alignment, &modulo,
			     - ffestorag_offset (st),
			     alignment, 0);
      ffestorag_set_modulo (st, pad);
    }

  if (init)
    ffedata_gather (st);	/* Gather subordinate inits into one init. */
}

/* ffeequiv_offset_ -- Determine offset from start of symbol

   ffetargetOffset offset;
   ffesymbol s;	 // Symbol for error reporting.
   ffebld expr;	 // opSUBSTR, opARRAYREF, opSYMTER, opANY.
   bool subtract;  // FALSE means add to adjust, TRUE means subtract from it.
   ffetargetOffset adjust;  // Helps keep answer in pos range (unsigned).
   if (!ffeequiv_offset_(&offset,s,expr,subtract,adjust))
       // error doing the calculation, message already printed

   Returns the offset represented by the SUBSTR, ARRAYREF, or SUBSTR/ARRAYREF
   combination added-to/subtracted-from the adjustment specified.  If there
   is an error of some kind, returns FALSE, else returns TRUE.	Note that
   only the first storage unit specified is considered; A(1:1) and A(1:2000)
   have the same first storage unit and so return the same offset.  */

static bool
ffeequiv_offset_ (ffetargetOffset *offset, ffesymbol s UNUSED,
		  ffebld expr, bool subtract, ffetargetOffset adjust,
		  bool no_precede)
{
  ffetargetIntegerDefault value = 0;
  ffetargetOffset cval;		/* Converted value. */
  ffesymbol sym;

  if (expr == NULL)
    return FALSE;

again:				/* :::::::::::::::::::: */

  switch (ffebld_op (expr))
    {
    case FFEBLD_opANY:
      return FALSE;

    case FFEBLD_opSYMTER:
      {
	ffetargetOffset size;	/* Size of a single unit. */
	ffetargetAlign a;	/* Ignored. */
	ffetargetAlign m;	/* Ignored. */

	sym = ffebld_symter (expr);
	if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
	  return FALSE;

	ffetarget_layout (ffesymbol_text (sym), &a, &m, &size,
			  ffesymbol_basictype (sym),
			  ffesymbol_kindtype (sym), 1, 1);

	if (value < 0)
	  {			/* Really invalid, as in A(-2:5), but in case
				   it's wanted.... */
	    if (!ffetarget_offset (&cval, -value))
	      return FALSE;

	    if (!ffetarget_offset_multiply (&cval, cval, size))
	      return FALSE;

	    if (subtract)
	      return ffetarget_offset_add (offset, cval, adjust);

	    if (no_precede && (cval > adjust))
	      {
	      neg:		/* :::::::::::::::::::: */
		ffebad_start (FFEBAD_COMMON_NEG);
		ffebad_string (ffesymbol_text (sym));
		ffebad_finish ();
		return FALSE;
	      }
	    return ffetarget_offset_add (offset, -cval, adjust);
	  }

	if (!ffetarget_offset (&cval, value))
	  return FALSE;

	if (!ffetarget_offset_multiply (&cval, cval, size))
	  return FALSE;

	if (!subtract)
	  return ffetarget_offset_add (offset, cval, adjust);

	if (no_precede && (cval > adjust))
	  goto neg;		/* :::::::::::::::::::: */

	return ffetarget_offset_add (offset, -cval, adjust);
      }

    case FFEBLD_opARRAYREF:
      {
	ffebld symexp = ffebld_left (expr);
	ffebld subscripts = ffebld_right (expr);
	ffebld dims;
	ffetargetIntegerDefault width;
	ffetargetIntegerDefault arrayval;
	ffetargetIntegerDefault lowbound;
	ffetargetIntegerDefault highbound;
	ffebld subscript;
	ffebld dim;
	ffebld low;
	ffebld high;
	int rank = 0;

	if (ffebld_op (symexp) != FFEBLD_opSYMTER)
	  return FALSE;

	sym = ffebld_symter (symexp);
	if (ffesymbol_basictype (sym) == FFEINFO_basictypeANY)
	  return FALSE;

	if (ffesymbol_size (sym) == FFETARGET_charactersizeNONE)
	  width = 1;
	else
	  width = ffesymbol_size (sym);
	dims = ffesymbol_dims (sym);

	while (subscripts != NULL)
	  {
	    ++rank;
	    if (dims == NULL)
	      {
		ffebad_start (FFEBAD_EQUIV_MANY);
		ffebad_string (ffesymbol_text (sym));
		ffebad_finish ();
		return FALSE;
	      }

	    subscript = ffebld_head (subscripts);
	    dim = ffebld_head (dims);

	    if (ffebld_op (subscript) == FFEBLD_opANY)
	      return FALSE;

	    assert (ffebld_op (subscript) == FFEBLD_opCONTER);
	    assert (ffeinfo_basictype (ffebld_info (subscript))
		    == FFEINFO_basictypeINTEGER);
	    assert (ffeinfo_kindtype (ffebld_info (subscript))
		    == FFEINFO_kindtypeINTEGERDEFAULT);
	    arrayval = ffebld_constant_integerdefault (ffebld_conter
						       (subscript));

	    if (ffebld_op (dim) == FFEBLD_opANY)
	      return FALSE;

	    assert (ffebld_op (dim) == FFEBLD_opBOUNDS);
	    low = ffebld_left (dim);
	    high = ffebld_right (dim);

	    if (low == NULL)
	      lowbound = 1;
	    else
	      {
		if (ffebld_op (low) == FFEBLD_opANY)
		  return FALSE;

		assert (ffebld_op (low) == FFEBLD_opCONTER);
		assert (ffeinfo_basictype (ffebld_info (low))
			== FFEINFO_basictypeINTEGER);
		assert (ffeinfo_kindtype (ffebld_info (low))
			== FFEINFO_kindtypeINTEGERDEFAULT);
		lowbound
		  = ffebld_constant_integerdefault (ffebld_conter (low));
	      }

	    if (ffebld_op (high) == FFEBLD_opANY)
	      return FALSE;

	    assert (ffebld_op (high) == FFEBLD_opCONTER);
	    assert (ffeinfo_basictype (ffebld_info (high))
		    == FFEINFO_basictypeINTEGER);
	    assert (ffeinfo_kindtype (ffebld_info (high))
		    == FFEINFO_kindtypeINTEGER1);
	    highbound
	      = ffebld_constant_integerdefault (ffebld_conter (high));

	    if ((arrayval < lowbound) || (arrayval > highbound))
	      {
		char rankstr[10];

		sprintf (rankstr, "%d", rank);
		ffebad_start (FFEBAD_EQUIV_SUBSCRIPT);
		ffebad_string (ffesymbol_text (sym));
		ffebad_string (rankstr);
		ffebad_finish ();
	      }

	    subscripts = ffebld_trail (subscripts);
	    dims = ffebld_trail (dims);

	    value += width * (arrayval - lowbound);
	    if (subscripts != NULL)
	      width *= highbound - lowbound + 1;
	  }

	if (dims != NULL)
	  {
	    ffebad_start (FFEBAD_EQUIV_FEW);
	    ffebad_string (ffesymbol_text (sym));
	    ffebad_finish ();
	    return FALSE;
	  }

	expr = symexp;
      }
      goto again;		/* :::::::::::::::::::: */

    case FFEBLD_opSUBSTR:
      {
	ffebld begin = ffebld_head (ffebld_right (expr));

	expr = ffebld_left (expr);
	if (ffebld_op (expr) == FFEBLD_opANY)
	  return FALSE;
	if (ffebld_op (expr) == FFEBLD_opARRAYREF)
	  sym = ffebld_symter (ffebld_left (expr));
	else if (ffebld_op (expr) == FFEBLD_opSYMTER)
	  sym = ffebld_symter (expr);
	else
	  sym = NULL;

	if ((sym != NULL)
	    && (ffesymbol_basictype (sym) == FFEINFO_basictypeANY))
	  return FALSE;

	if (begin == NULL)
	  value = 0;
	else
	  {
	    if (ffebld_op (begin) == FFEBLD_opANY)
	      return FALSE;
	    assert (ffebld_op (begin) == FFEBLD_opCONTER);
	    assert (ffeinfo_basictype (ffebld_info (begin))
		    == FFEINFO_basictypeINTEGER);
	    assert (ffeinfo_kindtype (ffebld_info (begin))
		    == FFEINFO_kindtypeINTEGERDEFAULT);

	    value = ffebld_constant_integerdefault (ffebld_conter (begin));

	    if ((value < 1)
		|| ((sym != NULL)
		    && (value > ffesymbol_size (sym))))
	      {
		ffebad_start (FFEBAD_EQUIV_RANGE);
		ffebad_string (ffesymbol_text (sym));
		ffebad_finish ();
	      }

	    --value;
	  }
	if ((sym != NULL)
	    && (ffesymbol_basictype (sym) != FFEINFO_basictypeCHARACTER))
	  {
	    ffebad_start (FFEBAD_EQUIV_SUBSTR);
	    ffebad_string (ffesymbol_text (sym));
	    ffebad_finish ();
	    value = 0;
	  }
      }
      goto again;		/* :::::::::::::::::::: */

    default:
      assert ("bad op" == NULL);
      return FALSE;
    }

}

/* ffeequiv_add -- Add list of equivalences to list of lists for eq object

   ffeequiv eq;
   ffebld list;
   ffelexToken t;  // points to first item in equivalence list
   ffeequiv_add(eq,list,t);

   Check the list to make sure only one common symbol is involved (even
   if multiple times) and agrees with the common symbol for the equivalence
   object (or it has no common symbol until now).  Prepend (or append, it
   doesn't matter) the list to the list of lists for the equivalence object.
   Otherwise report an error and return.  */

void
ffeequiv_add (ffeequiv eq, ffebld list, ffelexToken t)
{
  ffebld item;
  ffesymbol symbol;
  ffesymbol common = ffeequiv_common (eq);

  for (item = list; item != NULL; item = ffebld_trail (item))
    {
      symbol = ffeequiv_symbol (ffebld_head (item));

      if (ffesymbol_common (symbol) != NULL)	/* Is symbol known in COMMON yet? */
	{
	  if (common == NULL)
	    common = ffesymbol_common (symbol);
	  else if (common != ffesymbol_common (symbol))
	    {
	      /* Yes, and symbol disagrees with others on the COMMON area. */
	      ffebad_start (FFEBAD_EQUIV_COMMON);
	      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	      ffebad_string (ffesymbol_text (common));
	      ffebad_string (ffesymbol_text (ffesymbol_common (symbol)));
	      ffebad_finish ();
	      return;
	    }
	}
    }

  if ((common != NULL)
      && (ffeequiv_common (eq) == NULL))	/* Is COMMON involved already? */
    ffeequiv_set_common (eq, common);	/* No, but it is now. */

  for (item = list; item != NULL; item = ffebld_trail (item))
    {
      symbol = ffeequiv_symbol (ffebld_head (item));

      if (ffesymbol_equiv (symbol) == NULL)
	ffesymbol_set_equiv (symbol, eq);
      else
	assert (ffesymbol_equiv (symbol) == eq);

      if (ffesymbol_common (symbol) == NULL)	/* Is symbol in a COMMON
						   area? */
	{			/* No (at least not yet). */
	  if (ffesymbol_is_save (symbol))
	    ffeequiv_update_save (eq);	/* EQUIVALENCE has >=1 SAVEd entity. */
	  if (ffesymbol_is_init (symbol))
	    ffeequiv_update_init (eq);	/* EQUIVALENCE has >=1 init'd entity. */
	  continue;		/* Nothing more to do here. */
	}

#if FFEGLOBAL_ENABLED
      if (ffesymbol_is_init (symbol))
	ffeglobal_init_common (ffesymbol_common (symbol), t);
#endif

      if (ffesymbol_is_save (ffesymbol_common (symbol)))
	ffeequiv_update_save (eq);	/* EQUIVALENCE is in a SAVEd COMMON block. */
      if (ffesymbol_is_init (ffesymbol_common (symbol)))
	ffeequiv_update_init (eq);	/* EQUIVALENCE is in a init'd COMMON block. */
    }

  ffeequiv_set_list (eq, ffebld_new_item (list, ffeequiv_list (eq)));
}

/* ffeequiv_dump -- Dump info on equivalence object

   ffeequiv eq;
   ffeequiv_dump(eq);  */

#if FFECOM_targetCURRENT == FFECOM_targetFFE
void
ffeequiv_dump (ffeequiv eq)
{
  if (ffeequiv_common (eq) != NULL)
    fprintf (dmpout, "(common %s) ", ffesymbol_text (ffeequiv_common (eq)));
  ffebld_dump (ffeequiv_list (eq));
}
#endif

/* ffeequiv_exec_transition -- Do the hard work on all the equivalence objects

   ffeequiv_exec_transition();	*/

void
ffeequiv_exec_transition ()
{
  while (ffeequiv_list_.first != (ffeequiv) &ffeequiv_list_.first)
    ffeequiv_layout_local_ (ffeequiv_list_.first);
}

/* ffeequiv_init_2 -- Initialize for new program unit

   ffeequiv_init_2();

   Initializes the list of equivalences.  */

void
ffeequiv_init_2 ()
{
  ffeequiv_list_.first = (ffeequiv) &ffeequiv_list_.first;
  ffeequiv_list_.last = (ffeequiv) &ffeequiv_list_.first;
}

/* ffeequiv_kill -- Kill equivalence object after removing from list

   ffeequiv eq;
   ffeequiv_kill(eq);

   Removes equivalence object from master list, then kills it.	*/

void
ffeequiv_kill (ffeequiv victim)
{
  victim->next->previous = victim->previous;
  victim->previous->next = victim->next;
  if (ffe_is_do_internal_checks ())
    {
      ffebld list;
      ffebld item;
      ffebld expr;

      /* Assert that nobody our victim points to still points to it.  */

      assert ((victim->common == NULL)
	      || (ffesymbol_equiv (victim->common) == NULL));

      for (list = victim->list; list != NULL; list = ffebld_trail (list))
	{
	  for (item = ffebld_head (list); item != NULL; item = ffebld_trail (item))
	    {
	      ffesymbol sym;

	      expr = ffebld_head (item);
	      sym = ffeequiv_symbol (expr);
	      if (sym == NULL)
		continue;
	      assert (ffesymbol_equiv (sym) != victim);
	    }
	}
    }
  malloc_kill_ks (ffe_pool_program_unit (), victim, sizeof (*victim));
}

/* ffeequiv_layout_cblock -- Lay out storage for common area

   ffestorag st;
   if (ffeequiv_layout_cblock(st))
       // at least one equiv'd symbol has init/accretion expr.