data.c

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

	      && (ffestorag_init (ffedata_storage_) != NULL)))
	{
#if 0
	  ffebad_start (FFEBAD_DATA_REINIT);
	  ffest_ffebad_here_current_stmt (0);
	  ffebad_string (ffesymbol_text (ffedata_symbol_));
	  ffebad_finish ();
	  ffedata_reported_error_ = TRUE;
	  return FALSE;
#else
	  ffedata_reinit_ = TRUE;
	  return TRUE;
#endif
	}
      ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
      ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
      if (ffesymbol_rank (ffedata_symbol_) == 0)
	ffedata_arraysize_ = 1;	/* Shouldn't happen in this case... */
      else
	{
	  ffebld size = ffesymbol_arraysize (ffedata_symbol_);

	  assert (size != NULL);
	  assert (ffebld_op (size) == FFEBLD_opCONTER);
	  assert (ffeinfo_basictype (ffebld_info (size))
		  == FFEINFO_basictypeINTEGER);
	  assert (ffeinfo_kindtype (ffebld_info (size))
		  == FFEINFO_kindtypeINTEGERDEFAULT);
	  ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
							       (size));
	}
      ffedata_expected_ = 1;
      ffedata_number_ = 0;
      ffedata_offset_ = ffedata_eval_offset_ (ffebld_right (next),
					  ffesymbol_dims (ffedata_symbol_));
      ffedata_size_ = (ffedata_basictype_ == FFEINFO_basictypeCHARACTER)
	? ffesymbol_size (ffedata_symbol_) : 1;
      ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
      ffedata_charexpected_ = ffedata_size_;
      ffedata_charnumber_ = 0;
      ffedata_charoffset_ = 0;
      break;

    case FFEBLD_opSUBSTR:	/* Substring reference to scalar or array
				   element. */
      {
	bool arrayref = ffebld_op (ffebld_left (next)) == FFEBLD_opARRAYREF;
	ffebld colon = ffebld_right (next);

	assert (colon != NULL);

	ffedata_symbol_ = ffebld_symter (ffebld_left (arrayref
					      ? ffebld_left (next) : next));
	ffedata_storage_ = (ffesymbol_storage (ffedata_symbol_) == NULL) ? NULL
	  : ffestorag_parent (ffesymbol_storage (ffedata_symbol_));
	if (ffedata_storage_ != NULL)
	  {
	    ffetarget_aggregate_info (&ffedata_storage_bt_, &ffedata_storage_kt_,
				      &ffedata_storage_units_,
				      ffestorag_basictype (ffedata_storage_),
				      ffestorag_kindtype (ffedata_storage_));
	    ffedata_storage_size_ = ffestorag_size (ffedata_storage_)
	      / ffedata_storage_units_;
	    assert (ffestorag_size (ffedata_storage_) % ffedata_storage_units_ == 0);
	  }

	if ((ffesymbol_init (ffedata_symbol_) != NULL)
	    || ((ffedata_storage_ != NULL)
		&& (ffestorag_init (ffedata_storage_) != NULL)))
	  {
#if 0
	    ffebad_start (FFEBAD_DATA_REINIT);
	    ffest_ffebad_here_current_stmt (0);
	    ffebad_string (ffesymbol_text (ffedata_symbol_));
	    ffebad_finish ();
	    ffedata_reported_error_ = TRUE;
	    return FALSE;
#else
	    ffedata_reinit_ = TRUE;
	    return TRUE;
#endif
	  }
	ffedata_basictype_ = ffesymbol_basictype (ffedata_symbol_);
	ffedata_kindtype_ = ffesymbol_kindtype (ffedata_symbol_);
	if (ffesymbol_rank (ffedata_symbol_) == 0)
	  ffedata_arraysize_ = 1;
	else
	  {
	    ffebld size = ffesymbol_arraysize (ffedata_symbol_);

	    assert (size != NULL);
	    assert (ffebld_op (size) == FFEBLD_opCONTER);
	    assert (ffeinfo_basictype (ffebld_info (size))
		    == FFEINFO_basictypeINTEGER);
	    assert (ffeinfo_kindtype (ffebld_info (size))
		    == FFEINFO_kindtypeINTEGERDEFAULT);
	    ffedata_arraysize_ = ffebld_constant_integerdefault (ffebld_conter
								 (size));
	  }
	ffedata_expected_ = arrayref ? 1 : ffedata_arraysize_;
	ffedata_number_ = 0;
	ffedata_offset_ = arrayref ? ffedata_eval_offset_ (ffebld_right
		(ffebld_left (next)), ffesymbol_dims (ffedata_symbol_)) : 0;
	ffedata_size_ = ffesymbol_size (ffedata_symbol_);
	ffedata_symbolsize_ = ffedata_size_ * ffedata_arraysize_;
	ffedata_charnumber_ = 0;
	ffedata_charoffset_ = ffedata_eval_substr_begin_ (ffebld_head (colon));
	ffedata_charexpected_ = ffedata_eval_substr_end_ (ffebld_head
				(ffebld_trail (colon)), ffedata_charoffset_,
				   ffedata_size_) - ffedata_charoffset_ + 1;
      }
      break;

    case FFEBLD_opIMPDO:	/* Implied-DO construct. */
      {
	ffebld itervar;
	ffebld start;
	ffebld end;
	ffebld incr;
	ffebld item = ffebld_right (next);

	itervar = ffebld_head (item);
	item = ffebld_trail (item);
	start = ffebld_head (item);
	item = ffebld_trail (item);
	end = ffebld_head (item);
	item = ffebld_trail (item);
	incr = ffebld_head (item);

	ffedata_push_ ();
	ffedata_stack_->outer_list = ffedata_list_;
	ffedata_stack_->my_list = ffedata_list_ = ffebld_left (next);

	assert (ffeinfo_basictype (ffebld_info (itervar))
		== FFEINFO_basictypeINTEGER);
	assert (ffeinfo_kindtype (ffebld_info (itervar))
		== FFEINFO_kindtypeINTEGERDEFAULT);
	ffedata_stack_->itervar = ffebld_symter (itervar);

	assert (ffeinfo_basictype (ffebld_info (start))
		== FFEINFO_basictypeINTEGER);
	assert (ffeinfo_kindtype (ffebld_info (start))
		== FFEINFO_kindtypeINTEGERDEFAULT);
	ffesymbol_set_value (ffedata_stack_->itervar, ffedata_eval_integer1_ (start));

	assert (ffeinfo_basictype (ffebld_info (end))
		== FFEINFO_basictypeINTEGER);
	assert (ffeinfo_kindtype (ffebld_info (end))
		== FFEINFO_kindtypeINTEGERDEFAULT);
	ffedata_stack_->final = ffedata_eval_integer1_ (end);

	if (incr == NULL)
	  ffedata_stack_->increment = 1;
	else
	  {
	    assert (ffeinfo_basictype (ffebld_info (incr))
		    == FFEINFO_basictypeINTEGER);
	    assert (ffeinfo_kindtype (ffebld_info (incr))
		    == FFEINFO_kindtypeINTEGERDEFAULT);
	    ffedata_stack_->increment = ffedata_eval_integer1_ (incr);
	    if (ffedata_stack_->increment == 0)
	      {
		ffebad_start (FFEBAD_DATA_ZERO);
		ffest_ffebad_here_current_stmt (0);
		ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
		ffebad_finish ();
		ffedata_pop_ ();
		ffedata_reported_error_ = TRUE;
		return FALSE;
	      }
	  }

	if ((ffedata_stack_->increment > 0)
	    ? ffesymbol_value (ffedata_stack_->itervar)
	    > ffedata_stack_->final
	    : ffesymbol_value (ffedata_stack_->itervar)
	    < ffedata_stack_->final)
	  {
	    ffedata_reported_error_ = TRUE;
	    ffebad_start (FFEBAD_DATA_EMPTY);
	    ffest_ffebad_here_current_stmt (0);
	    ffebad_string (ffesymbol_text (ffedata_stack_->itervar));
	    ffebad_finish ();
	    ffedata_pop_ ();
	    return FALSE;
	  }
      }
      goto tail_recurse;	/* :::::::::::::::::::: */

    case FFEBLD_opANY:
      ffedata_reported_error_ = TRUE;
      return FALSE;

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

  return TRUE;
}

/* ffedata_convert_ -- Convert source expression to given type using cache

   ffebld source;
   ffelexToken source_token;
   ffelexToken dest_token;  // Any appropriate token for "destination".
   ffeinfoBasictype bt;
   ffeinfoKindtype kt;
   ffetargetCharactersize sz;
   source = ffedata_convert_(source,source_token,dest_token,bt,kt,sz);

   Like ffeexpr_convert, but calls it only if necessary (if the converted
   expression doesn't already exist in the cache) and then puts the result
   in the cache.  */

static ffebld
ffedata_convert_ (ffebld source, ffelexToken source_token,
		  ffelexToken dest_token, ffeinfoBasictype bt,
		  ffeinfoKindtype kt, ffeinfoRank rk,
		  ffetargetCharacterSize sz)
{
  ffebld converted;
  int i;
  int max;
  ffedataConvertCache_ cache;

  for (i = 0; i < ffedata_convert_cache_use_; ++i)
    if ((bt == ffedata_convert_cache_[i].basic_type)
	&& (kt == ffedata_convert_cache_[i].kind_type)
	&& (sz == ffedata_convert_cache_[i].size)
	&& (rk == ffedata_convert_cache_[i].rank))
      return ffedata_convert_cache_[i].converted;

  converted = ffeexpr_convert (source, source_token, dest_token, bt, kt, rk,
			       sz, FFEEXPR_contextDATA);

  if (ffedata_convert_cache_use_ >= ffedata_convert_cache_max_)
    {
      if (ffedata_convert_cache_max_ == 0)
	max = 4;
      else
	max = ffedata_convert_cache_max_ << 1;

      if (max > ffedata_convert_cache_max_)
	{
	  cache = (ffedataConvertCache_) malloc_new_ks (malloc_pool_image (),
				    "FFEDATA cache", max * sizeof (*cache));
	  if (ffedata_convert_cache_max_ != 0)
	    {
	      memcpy (cache, ffedata_convert_cache_,
		      ffedata_convert_cache_max_ * sizeof (*cache));
	      malloc_kill_ks (malloc_pool_image (), ffedata_convert_cache_,
			      ffedata_convert_cache_max_ * sizeof (*cache));
	    }
	  ffedata_convert_cache_ = cache;
	  ffedata_convert_cache_max_ = max;
	}
      else
	return converted;	/* In case int overflows! */
    }

  i = ffedata_convert_cache_use_++;

  ffedata_convert_cache_[i].converted = converted;
  ffedata_convert_cache_[i].basic_type = bt;
  ffedata_convert_cache_[i].kind_type = kt;
  ffedata_convert_cache_[i].size = sz;
  ffedata_convert_cache_[i].rank = rk;

  return converted;
}

/* ffedata_eval_integer1_ -- Evaluate expression

   ffetargetIntegerDefault result;
   ffebld expr;	 // must be kindtypeINTEGER1.

   result = ffedata_eval_integer1_(expr);

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

static ffetargetIntegerDefault
ffedata_eval_integer1_ (ffebld expr)
{
  ffetargetInteger1 result;
  ffebad error;

  assert (expr != NULL);

  switch (ffebld_op (expr))
    {
    case FFEBLD_opCONTER:
      return ffebld_constant_integer1 (ffebld_conter (expr));

    case FFEBLD_opSYMTER:
      return ffesymbol_value (ffebld_symter (expr));

    case FFEBLD_opUPLUS:
      return ffedata_eval_integer1_ (ffebld_left (expr));

    case FFEBLD_opUMINUS:
      error = ffetarget_uminus_integer1 (&result,
			       ffedata_eval_integer1_ (ffebld_left (expr)));
      break;

    case FFEBLD_opADD:
      error = ffetarget_add_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opSUBTRACT:
      error = ffetarget_subtract_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opMULTIPLY:
      error = ffetarget_multiply_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opDIVIDE:
      error = ffetarget_divide_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opPOWER:
      {
	ffebld r = ffebld_right (expr);

	if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
	    || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
	  error = FFEBAD_DATA_EVAL;
	else
	  error = ffetarget_power_integerdefault_integerdefault (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
						ffedata_eval_integer1_ (r));
      }
      break;

#if 0				/* Only for character basictype. */
    case FFEBLD_opCONCATENATE:
      error =;
      break;
#endif

    case FFEBLD_opNOT:
      error = ffetarget_not_integer1 (&result,
			       ffedata_eval_integer1_ (ffebld_left (expr)));
      break;

#if 0				/* Only for logical basictype. */
    case FFEBLD_opLT:
      error =;
      break;

    case FFEBLD_opLE:
      error =;
      break;

    case FFEBLD_opEQ:
      error =;
      break;

    case FFEBLD_opNE:
      error =;
      break;

    case FFEBLD_opGT:
      error =;
      break;

    case FFEBLD_opGE:
      error =;
      break;
#endif

    case FFEBLD_opAND:
      error = ffetarget_and_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opOR:
      error = ffetarget_or_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opXOR:
      error = ffetarget_xor_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opEQV:
      error = ffetarget_eqv_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opNEQV:
      error = ffetarget_neqv_integer1 (&result,
				ffedata_eval_integer1_ (ffebld_left (expr)),
			      ffedata_eval_integer1_ (ffebld_right (expr)));
      break;

    case FFEBLD_opPAREN:
      return ffedata_eval_integer1_ (ffebld_left (expr));

#if 0				/* ~~ no idea how to do this */
    case FFEBLD_opPERCENT_LOC:
      error =;
      break;
#endif

#if 0				/* not allowed by ANSI, but perhaps as an
				   extension someday? */
    case FFEBLD_opCONVERT:
      switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
	{
	case FFEINFO_basictypeINTEGER:
	  switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	    {
	    default:
	      error = FFEBAD_DATA_EVAL;
	      break;
	    }
	  break;

	case FFEINFO_basictypeREAL:
	  switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
	    {
	    default:
	      error = FFEBAD_DATA_EVAL;
	      break;
	    }
	  break;
	}
      break;
#endif

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

    case FFEBLD_opBOUNDS:
      error =;
      break;
#endif