data.c

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

#if 0				/* not allowed by ANSI, but perhaps as an
				   extension someday? */
    case FFEBLD_opFUNCREF:
      error =;
      break;
#endif

#if 0				/* not valid ops */
    case FFEBLD_opSUBRREF:
      error =;
      break;

    case FFEBLD_opARRAYREF:
      error =;
      break;
#endif

#if 0				/* not valid for integer1 */
    case FFEBLD_opSUBSTR:
      error =;
      break;
#endif

    default:
      error = FFEBAD_DATA_EVAL;
      break;
    }

  if (error != FFEBAD)
    {
      ffebad_start (error);
      ffest_ffebad_here_current_stmt (0);
      ffebad_finish ();
      result = 0;
    }

  return result;
}

/* ffedata_eval_offset_ -- Evaluate offset info array

   ffetargetOffset offset;  // 0...max-1.
   ffebld subscripts;  // an opITEM list of subscript exprs.
   ffebld dims;	 // an opITEM list of opBOUNDS exprs.

   result = ffedata_eval_offset_(expr);

   Evalues the expression (which yields a kindtypeINTEGER1 result) and
   returns the result.	*/

static ffetargetOffset
ffedata_eval_offset_ (ffebld subscripts, ffebld dims)
{
  ffetargetIntegerDefault offset = 0;
  ffetargetIntegerDefault width = 1;
  ffetargetIntegerDefault value;
  ffetargetIntegerDefault lowbound;
  ffetargetIntegerDefault highbound;
  ffetargetOffset final;
  ffebld subscript;
  ffebld dim;
  ffebld low;
  ffebld high;
  int rank = 0;
  bool ok;

  while (subscripts != NULL)
    {
      ++rank;
      assert (dims != NULL);

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

      assert (ffeinfo_basictype (ffebld_info (subscript)) == FFEINFO_basictypeINTEGER);
      assert (ffeinfo_kindtype (ffebld_info (subscript)) == FFEINFO_kindtypeINTEGER1);
      value = ffedata_eval_integer1_ (subscript);

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

      if (low == NULL)
	lowbound = 1;
      else
	{
	  assert (ffeinfo_basictype (ffebld_info (low)) == FFEINFO_basictypeINTEGER);
	  assert (ffeinfo_kindtype (ffebld_info (low)) == FFEINFO_kindtypeINTEGERDEFAULT);
	  lowbound = ffedata_eval_integer1_ (low);
	}

      assert (ffeinfo_basictype (ffebld_info (high)) == FFEINFO_basictypeINTEGER);
      assert (ffeinfo_kindtype (ffebld_info (high)) == FFEINFO_kindtypeINTEGERDEFAULT);
      highbound = ffedata_eval_integer1_ (high);

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

	  sprintf (rankstr, "%d", rank);
	  value = lowbound;
	  ffebad_start (FFEBAD_DATA_SUBSCRIPT);
	  ffebad_string (ffesymbol_text (ffedata_symbol_));
	  ffebad_string (rankstr);
	  ffebad_finish ();
	}

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

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

  assert (dims == NULL);

  ok = ffetarget_offset (&final, offset);
  assert (ok);

  return final;
}

/* ffedata_eval_substr_begin_ -- Evaluate begin-point of substr reference

   ffetargetCharacterSize beginpoint;
   ffebld endval;  // head(colon).

   beginpoint = ffedata_eval_substr_end_(endval);

   If beginval is NULL, returns 0.  Otherwise makes sure beginval is
   kindtypeINTEGERDEFAULT, makes sure its value is > 0,
   and returns its value minus one, or issues an error message.	 */

static ffetargetCharacterSize
ffedata_eval_substr_begin_ (ffebld expr)
{
  ffetargetIntegerDefault val;

  if (expr == NULL)
    return 0;

  assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
  assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGERDEFAULT);

  val = ffedata_eval_integer1_ (expr);

  if (val < 1)
    {
      val = 1;
      ffebad_start (FFEBAD_DATA_RANGE);
      ffest_ffebad_here_current_stmt (0);
      ffebad_string (ffesymbol_text (ffedata_symbol_));
      ffebad_finish ();
      ffedata_reported_error_ = TRUE;
    }

  return val - 1;
}

/* ffedata_eval_substr_end_ -- Evaluate end-point of substr reference

   ffetargetCharacterSize endpoint;
   ffebld endval;  // head(trail(colon)).
   ffetargetCharacterSize min;	// beginpoint of substr reference.
   ffetargetCharacterSize max;	// size of entity.

   endpoint = ffedata_eval_substr_end_(endval,dflt);

   If endval is NULL, returns max.  Otherwise makes sure endval is
   kindtypeINTEGERDEFAULT, makes sure its value is > min and <= max,
   and returns its value minus one, or issues an error message.	 */

static ffetargetCharacterSize
ffedata_eval_substr_end_ (ffebld expr, ffetargetCharacterSize min,
			  ffetargetCharacterSize max)
{
  ffetargetIntegerDefault val;

  if (expr == NULL)
    return max - 1;

  assert (ffeinfo_basictype (ffebld_info (expr)) == FFEINFO_basictypeINTEGER);
  assert (ffeinfo_kindtype (ffebld_info (expr)) == FFEINFO_kindtypeINTEGER1);

  val = ffedata_eval_integer1_ (expr);

  if ((val < (ffetargetIntegerDefault) min)
      || (val > (ffetargetIntegerDefault) max))
    {
      val = 1;
      ffebad_start (FFEBAD_DATA_RANGE);
      ffest_ffebad_here_current_stmt (0);
      ffebad_string (ffesymbol_text (ffedata_symbol_));
      ffebad_finish ();
      ffedata_reported_error_ = TRUE;
    }

  return val - 1;
}

/* ffedata_gather_ -- Gather initial values for sym into master sym inits

   ffestorag mst;  // A typeCBLOCK or typeLOCAL aggregate.
   ffestorag st;  // A typeCOMMON or typeEQUIV member.
   ffedata_gather_(mst,st);

   If st has any initialization info, transfer that info into mst and
   clear st's info.  */

static void
ffedata_gather_ (ffestorag mst, ffestorag st)
{
  ffesymbol s;
  ffesymbol s_whine;		/* Symbol to complain about in diagnostics. */
  ffebld b;
  ffetargetOffset offset;
  ffetargetOffset units_expected;
  ffebitCount actual;
  ffebldConstantArray array;
  ffebld accter;
  ffetargetCopyfunc fn;
  void *ptr1;
  void *ptr2;
  size_t size;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffeinfoBasictype ign_bt;
  ffeinfoKindtype ign_kt;
  ffetargetAlign units;
  ffebit bits;
  ffetargetOffset source_offset;
  bool whine = FALSE;

  if (st == NULL)
    return;			/* Nothing to do. */

  s = ffestorag_symbol (st);

  assert (s != NULL);		/* Must have a corresponding symbol (else how
				   inited?). */
  assert (ffestorag_init (st) == NULL);	/* No init info on storage itself. */
  assert (ffestorag_accretion (st) == NULL);

  if ((((b = ffesymbol_init (s)) == NULL)
       && ((b = ffesymbol_accretion (s)) == NULL))
      || (ffebld_op (b) == FFEBLD_opANY)
      || ((ffebld_op (b) == FFEBLD_opCONVERT)
	  && (ffebld_op (ffebld_left (b)) == FFEBLD_opANY)))
    return;			/* Nothing to do. */

  /* b now holds the init/accretion expr. */

  ffesymbol_set_init (s, NULL);
  ffesymbol_set_accretion (s, NULL);
  ffesymbol_set_accretes (s, 0);

  s_whine = ffestorag_symbol (mst);
  if (s_whine == NULL)
    s_whine = s;

  /* Make sure we haven't fully accreted during an array init. */

  if (ffestorag_init (mst) != NULL)
    {
      ffebad_start (FFEBAD_DATA_MULTIPLE);
      ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
      ffebad_string (ffesymbol_text (s_whine));
      ffebad_finish ();
      return;
    }

  bt = ffeinfo_basictype (ffebld_info (b));
  kt = ffeinfo_kindtype (ffebld_info (b));

  /* Calculate offset for aggregate area. */

  ffedata_charexpected_ = (bt == FFEINFO_basictypeCHARACTER)
    ? ffebld_size (b) : 1;
  ffetarget_aggregate_info (&ign_bt, &ign_kt, &units, bt,
			    kt);/* Find out unit size of source datum. */
  assert (units % ffedata_storage_units_ == 0);
  units_expected = ffedata_charexpected_ * units / ffedata_storage_units_;
  offset = (ffestorag_offset (st) - ffestorag_offset (mst))
    / ffedata_storage_units_;

  /* Does an accretion array exist?  If not, create it. */

  if (ffestorag_accretion (mst) == NULL)
    {
#if FFEDATA_sizeTOO_BIG_INIT_ != 0
      if (ffedata_storage_size_ >= FFEDATA_sizeTOO_BIG_INIT_)
	{
	  char bignum[40];

	  sprintf (&bignum[0], "%ld", (long) ffedata_storage_size_);
	  ffebad_start (FFEBAD_TOO_BIG_INIT);
	  ffebad_here (0, ffesymbol_where_line (s_whine),
		       ffesymbol_where_column (s_whine));
	  ffebad_string (ffesymbol_text (s_whine));
	  ffebad_string (bignum);
	  ffebad_finish ();
	}
#endif
      array = ffebld_constantarray_new (ffedata_storage_bt_,
				ffedata_storage_kt_, ffedata_storage_size_);
      accter = ffebld_new_accter (array, ffebit_new (ffe_pool_program_unit (),
						     ffedata_storage_size_));
      ffebld_set_info (accter, ffeinfo_new
		       (ffedata_storage_bt_,
			ffedata_storage_kt_,
			1,
			FFEINFO_kindENTITY,
			FFEINFO_whereCONSTANT,
			(ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
			? 1 : FFETARGET_charactersizeNONE));
      ffestorag_set_accretion (mst, accter);
      ffestorag_set_accretes (mst, ffedata_storage_size_);
    }
  else
    {
      accter = ffestorag_accretion (mst);
      assert (ffedata_storage_size_ == (ffetargetOffset) ffebld_accter_size (accter));
      array = ffebld_accter (accter);
    }

  /* Put value in accretion array at desired offset. */

  fn = ffetarget_aggregate_ptr_memcpy (ffedata_storage_bt_, ffedata_storage_kt_,
				       bt, kt);

  switch (ffebld_op (b))
    {
    case FFEBLD_opCONTER:
      ffebld_constantarray_prepare (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
				    ffedata_storage_kt_, offset,
			   ffebld_constant_ptr_to_union (ffebld_conter (b)),
				    bt, kt);
      (*fn) (ptr1, ptr2, size);	/* Does the appropriate memcpy-like
				   operation. */
      ffebit_count (ffebld_accter_bits (accter),
		    offset, FALSE, units_expected, &actual);	/* How many FALSE? */
      if (units_expected != (ffetargetOffset) actual)
	{
	  ffebad_start (FFEBAD_DATA_MULTIPLE);
	  ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
	  ffebad_string (ffesymbol_text (s));
	  ffebad_finish ();
	}
      ffestorag_set_accretes (mst,
			      ffestorag_accretes (mst)
			      - actual);	/* Decrement # of values
						   actually accreted. */
      ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);

      /* If done accreting for this storage area, establish as initialized. */

      if (ffestorag_accretes (mst) == 0)
	{
	  ffestorag_set_init (mst, accter);
	  ffestorag_set_accretion (mst, NULL);
	  ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
	  ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
	  ffebld_set_arrter (ffestorag_init (mst),
			     ffebld_accter (ffestorag_init (mst)));
	  ffebld_arrter_set_size (ffestorag_init (mst),
				  ffedata_storage_size_);
	  ffebld_arrter_set_pad (ffestorag_init (mst), 0);
	  ffecom_notify_init_storage (mst);
	}

      return;

    case FFEBLD_opARRTER:
      ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
			     ffedata_storage_kt_, offset, ffebld_arrter (b),
				      bt, kt);
      size *= ffebld_arrter_size (b);
      units_expected *= ffebld_arrter_size (b);
      (*fn) (ptr1, ptr2, size);	/* Does the appropriate memcpy-like
				   operation. */
      ffebit_count (ffebld_accter_bits (accter),
		    offset, FALSE, units_expected, &actual);	/* How many FALSE? */
      if (units_expected != (ffetargetOffset) actual)
	{
	  ffebad_start (FFEBAD_DATA_MULTIPLE);
	  ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
	  ffebad_string (ffesymbol_text (s));
	  ffebad_finish ();
	}
      ffestorag_set_accretes (mst,
			      ffestorag_accretes (mst)
			      - actual);	/* Decrement # of values
						   actually accreted. */
      ffebit_set (ffebld_accter_bits (accter), offset, 1, units_expected);

      /* If done accreting for this storage area, establish as initialized. */

      if (ffestorag_accretes (mst) == 0)
	{
	  ffestorag_set_init (mst, accter);
	  ffestorag_set_accretion (mst, NULL);
	  ffebit_kill (ffebld_accter_bits (ffestorag_init (mst)));
	  ffebld_set_op (ffestorag_init (mst), FFEBLD_opARRTER);
	  ffebld_set_arrter (ffestorag_init (mst),
			     ffebld_accter (ffestorag_init (mst)));
	  ffebld_arrter_set_size (ffestorag_init (mst),
				  ffedata_storage_size_);
	  ffebld_arrter_set_pad (ffestorag_init (mst), 0);
	  ffecom_notify_init_storage (mst);
	}

      return;

    case FFEBLD_opACCTER:
      ffebld_constantarray_preparray (&ptr1, &ptr2, &size, array, ffedata_storage_bt_,
			     ffedata_storage_kt_, offset, ffebld_accter (b),
				      bt, kt);
      bits = ffebld_accter_bits (b);
      source_offset = 0;

      for (;;)
	{
	  ffetargetOffset unexp;
	  ffetargetOffset siz;
	  ffebitCount length;
	  bool value;

	  ffebit_test (bits, source_offset, &value, &length);
	  if (length == 0)
	    break;		/* Exit the loop early. */
	  siz = size * length;
	  unexp = units_expected * length;
	  if (value)
	    {
	      (*fn) (ptr1, ptr2, siz);	/* Does memcpy-like operation. */
	      ffebit_count (ffebld_accter_bits (accter),	/* How many FALSE? */
			    offset, FALSE, unexp, &actual);
	      if (!whine && (unexp != (ffetargetOffset) actual))
		{
		  whine = TRUE;	/* Don't whine more than once for one gather. */
		  ffebad_start (FFEBAD_DATA_MULTIPLE);
		  ffebad_here (0, ffewhere_line_unknown (), ffewhere_column_unknown ());
		  ffebad_string (ffesymbol_text (s));
		  ffebad_finish ();
		}
	      ffestorag_set_accretes (mst,
				      ffestorag_accretes (mst)
				      - actual);	/* Decrement # of values
							   actually accreted. */
	      ffebit_set (ffebld_accter_bits (accter), offset, 1, unexp);
	    }
	  source_offset += length;
	  offset += unexp;