intrin.c

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

		okay = FALSE;
	      break;
	    }

	  switch (extra)
	    {
	    case '&':
	      if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
		  || ((ffebld_op (a) != FFEBLD_opSYMTER)
		      && (ffebld_op (a) != FFEBLD_opSUBSTR)
		      && (ffebld_op (a) != FFEBLD_opARRAYREF)))
		okay = FALSE;
	      break;

	    case 'w':
	    case 'x':
	      if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
		  || ((ffebld_op (a) != FFEBLD_opSYMTER)
		      && (ffebld_op (a) != FFEBLD_opARRAYREF)
		      && (ffebld_op (a) != FFEBLD_opSUBSTR)))
		okay = FALSE;
	      break;

	    case '-':
	    case 'i':
	      break;

	    default:
	      if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
		okay = FALSE;
	      break;
	    }

	  if ((optional == '!')
	      && lastarg_complex)
	    okay = FALSE;

	  if (!okay)
	    {
	      /* If it wasn't optional, it's an error,
		 else maybe it could match a later argspec.  */
	      if (optional == '\0')
		return FFEBAD_INTRINSIC_REF;
	      break;	/* Try next argspec. */
	    }

	  lastarg_complex
	    = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);

	  if (anynum && commit)
	    {
	      /* If we know dummy arg type, convert to that now.  */

	      if (abt == FFEINFO_basictypeNONE)
		abt = FFEINFO_basictypeINTEGER;
	      if (akt == FFEINFO_kindtypeNONE)
		akt = FFEINFO_kindtypeINTEGER1;

	      /* We have a known type, convert hollerith/typeless to it.  */

	      a = ffeexpr_convert (a, t, NULL,
				   abt, akt, 0,
				   FFETARGET_charactersizeNONE,
				   FFEEXPR_contextLET);
	      ffebld_set_head (arg, a);
	    }
	  else if ((c[colon + 1] == '*') && commit)
	    {
	      /* This is where we promote types to the consensus
		 type for the COL.  Maybe this is where -fpedantic
		 should issue a warning as well.  */

	      a = ffeexpr_convert (a, t, NULL,
				   col_bt, col_kt, 0,
				   ffeinfo_size (i),
				   FFEEXPR_contextLET);
	      ffebld_set_head (arg, a);
	    }

	  arg = ffebld_trail (arg);	/* Arg accepted, now move on. */

	  if (optional == '*')
	    continue;	/* Go ahead and try another arg. */
	  if (required == '\0')
	    break;
	  if ((required == 'n')
	      || (required == '+'))
	    {
	      optional = '*';
	      required = '\0';
	    }
	  else if (required == 'p')
	    required = 'n';
	} while (TRUE);
    }

  *xbt = bt;
  *xkt = kt;
  *xsz = sz;
  return FFEBAD;
}

static bool
ffeintrin_check_any_ (ffebld arglist)
{
  ffebld item;

  for (; arglist != NULL; arglist = ffebld_trail (arglist))
    {
      item = ffebld_head (arglist);
      if ((item != NULL)
	  && (ffebld_op (item) == FFEBLD_opANY))
	return TRUE;
    }

  return FALSE;
}

/* Compare name to intrinsic's name.  Uses strcmp on arguments' names.	*/

static int
ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
{
  const char *uc = ((struct _ffeintrin_name_ *) intrinsic)->name_uc;
  const char *lc = ((struct _ffeintrin_name_ *) intrinsic)->name_lc;
  const char *ic = ((struct _ffeintrin_name_ *) intrinsic)->name_ic;

  return ffesrc_strcmp_2c (ffe_case_intrin (), name, uc, lc, ic);
}

/* Return basic type of intrinsic implementation, based on its
   run-time implementation *only*.  (This is used only when
   the type of an intrinsic name is needed without having a
   list of arguments, i.e. an interface signature, such as when
   passing the intrinsic itself, or really the run-time-library
   function, as an argument.)

   If there's no eligible intrinsic implementation, there must be
   a bug somewhere else; no such reference should have been permitted
   to go this far.  (Well, this might be wrong.)  */

ffeinfoBasictype
ffeintrin_basictype (ffeintrinSpec spec)
{
  ffeintrinImp imp;
  ffecomGfrt gfrt;

  assert (spec < FFEINTRIN_spec);
  imp = ffeintrin_specs_[spec].implementation;
  assert (imp < FFEINTRIN_imp);

  if (ffe_is_f2c ())
    gfrt = ffeintrin_imps_[imp].gfrt_f2c;
  else 
    gfrt = ffeintrin_imps_[imp].gfrt_gnu;

  assert (gfrt != FFECOM_gfrt);

  return ffecom_gfrt_basictype (gfrt);
}

/* Return family to which specific intrinsic belongs.  */

ffeintrinFamily
ffeintrin_family (ffeintrinSpec spec)
{
  if (spec >= FFEINTRIN_spec)
    return FALSE;
  return ffeintrin_specs_[spec].family;
}

/* Check and fill in info on func/subr ref node.

   ffebld expr;			// FUNCREF or SUBRREF with no info (caller
				// gets it from the modified info structure).
   ffeinfo info;		// Already filled in, will be overwritten.
   ffelexToken token;		// Used for error message.
   ffeintrin_fulfill_generic (&expr, &info, token);

   Based on the generic id, figure out which specific procedure is meant and
   pick that one.  Else return an error, a la _specific.  */

void
ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t)
{
  ffebld symter;
  ffebldOp op;
  ffeintrinGen gen;
  ffeintrinSpec spec = FFEINTRIN_specNONE;
  ffeinfoBasictype bt = FFEINFO_basictypeNONE;
  ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
  ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
  ffeintrinImp imp;
  ffeintrinSpec tspec;
  ffeintrinImp nimp = FFEINTRIN_impNONE;
  ffebad error;
  bool any = FALSE;
  bool highly_specific = FALSE;
  int i;

  op = ffebld_op (*expr);
  assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
  assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);

  gen = ffebld_symter_generic (ffebld_left (*expr));
  assert (gen != FFEINTRIN_genNONE);

  imp = FFEINTRIN_impNONE;
  error = FFEBAD;

  any = ffeintrin_check_any_ (ffebld_right (*expr));

  for (i = 0;
       (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
	 && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE)
	 && !any;
       ++i)
    {
      ffeintrinImp timp = ffeintrin_specs_[tspec].implementation;
      ffeinfoBasictype tbt;
      ffeinfoKindtype tkt;
      ffetargetCharacterSize tsz;
      ffeIntrinsicState state
      = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
      ffebad terror;

      if (state == FFE_intrinsicstateDELETED)
	continue;

      if (timp != FFEINTRIN_impNONE)
	{
	  if (!(ffeintrin_imps_[timp].control[0] == '-')
	      != !(ffebld_op (*expr) == FFEBLD_opSUBRREF))
	    continue;		/* Form of reference must match form of specific. */
	}

      if (state == FFE_intrinsicstateDISABLED)
	terror = FFEBAD_INTRINSIC_DISABLED;
      else if (timp == FFEINTRIN_impNONE)
	terror = FFEBAD_INTRINSIC_UNIMPL;
      else
	{
	  terror = ffeintrin_check_ (timp, ffebld_op (*expr),
				     ffebld_right (*expr),
				     &tbt, &tkt, &tsz, NULL, t, FALSE);
	  if (terror == FFEBAD)
	    {
	      if (imp != FFEINTRIN_impNONE)
		{
		  ffebad_start (FFEBAD_INTRINSIC_AMBIG);
		  ffebad_here (0, ffelex_token_where_line (t),
			       ffelex_token_where_column (t));
		  ffebad_string (ffeintrin_gens_[gen].name);
		  ffebad_string (ffeintrin_specs_[spec].name);
		  ffebad_string (ffeintrin_specs_[tspec].name);
		  ffebad_finish ();
		}
	      else
		{
		  if (ffebld_symter_specific (ffebld_left (*expr))
		      == tspec)
		    highly_specific = TRUE;
		  imp = timp;
		  spec = tspec;
		  bt = tbt;
		  kt = tkt;
		  sz = tkt;
		  error = terror;
		}
	    }
	  else if (terror != FFEBAD)
	    {			/* This error has precedence over others. */
	      if ((error == FFEBAD_INTRINSIC_DISABLED)
		  || (error == FFEBAD_INTRINSIC_UNIMPL))
		error = FFEBAD;
	    }
	}

      if (error == FFEBAD)
	error = terror;
    }

  if (any || (imp == FFEINTRIN_impNONE))
    {
      if (!any)
	{
	  if (error == FFEBAD)
	    error = FFEBAD_INTRINSIC_REF;
	  ffebad_start (error);
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_string (ffeintrin_gens_[gen].name);
	  ffebad_finish ();
	}

      *expr = ffebld_new_any ();
      *info = ffeinfo_new_any ();
    }
  else
    {
      if (!highly_specific && (nimp != FFEINTRIN_impNONE))
	{
	  fprintf (stderr, "lineno=%ld, gen=%s, imp=%s, timp=%s\n",
		   (long) lineno,
		   ffeintrin_gens_[gen].name,
		   ffeintrin_imps_[imp].name,
		   ffeintrin_imps_[nimp].name);
	  assert ("Ambiguous generic reference" == NULL);
	  abort ();
	}
      error = ffeintrin_check_ (imp, ffebld_op (*expr),
				ffebld_right (*expr),
				&bt, &kt, &sz, NULL, t, TRUE);
      assert (error == FFEBAD);
      *info = ffeinfo_new (bt,
			   kt,
			   0,
			   FFEINFO_kindENTITY,
			   FFEINFO_whereFLEETING,
			   sz);
      symter = ffebld_left (*expr);
      ffebld_symter_set_specific (symter, spec);
      ffebld_symter_set_implementation (symter, imp);
      ffebld_set_info (symter,
		       ffeinfo_new (bt,
				    kt,
				    0,
				    (bt == FFEINFO_basictypeNONE)
				    ? FFEINFO_kindSUBROUTINE
				    : FFEINFO_kindFUNCTION,
				    FFEINFO_whereINTRINSIC,
				    sz));

      if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
	  && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
	       || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
	       || ((sz != FFETARGET_charactersizeNONE)
		   && (sz != ffesymbol_size (ffebld_symter (symter)))))))
	{
	  ffebad_start (FFEBAD_INTRINSIC_TYPE);
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_string (ffeintrin_gens_[gen].name);
	  ffebad_finish ();
	}
      if (ffeintrin_imps_[imp].y2kbad)
	{
	  ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_string (ffeintrin_gens_[gen].name);
	  ffebad_finish ();
	}
    }
}

/* Check and fill in info on func/subr ref node.

   ffebld expr;			// FUNCREF or SUBRREF with no info (caller
				// gets it from the modified info structure).
   ffeinfo info;		// Already filled in, will be overwritten.
   bool check_intrin;           // May be omitted, else set TRUE if intrinsic needs checking.
   ffelexToken token;		// Used for error message.
   ffeintrin_fulfill_specific (&expr, &info, &check_intrin, token);

   Based on the specific id, determine whether the arg list is valid
   (number, type, rank, and kind of args) and fill in the info structure
   accordingly.	 Currently don't rewrite the expression, but perhaps
   someday do so for constant collapsing, except when an error occurs,
   in which case it is overwritten with ANY and info is also overwritten
   accordingly.	 */

void
ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
			    bool *check_intrin, ffelexToken t)
{
  ffebld symter;
  ffebldOp op;
  ffeintrinGen gen;
  ffeintrinSpec spec;
  ffeintrinImp imp;
  ffeinfoBasictype bt = FFEINFO_basictypeNONE;
  ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
  ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
  ffeIntrinsicState state;
  ffebad error;
  bool any = FALSE;
  const char *name;

  op = ffebld_op (*expr);
  assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
  assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);

  gen = ffebld_symter_generic (ffebld_left (*expr));
  spec = ffebld_symter_specific (ffebld_left (*expr));
  assert (spec != FFEINTRIN_specNONE);

  if (gen != FFEINTRIN_genNONE)
    name = ffeintrin_gens_[gen].name;
  else
    name = ffeintrin_specs_[spec].name;

  state = ffeintrin_state_family (ffeintrin_specs_[spec].family);

  imp = ffeintrin_specs_[spec].implementation;
  if (check_intrin != NULL)
    *check_intrin = FALSE;

  any = ffeintrin_check_any_ (ffebld_right (*expr));

  if (state == FFE_intrinsicstateDISABLED)
    error = FFEBAD_INTRINSIC_DISABLED;
  else if (imp == FFEINTRIN_impNONE)
    error = FFEBAD_INTRINSIC_UNIMPL;
  else if (!any)
    {
      error = ffeintrin_check_ (imp, ffebld_op (*expr),
				ffebld_right (*expr),
				&bt, &kt, &sz, check_intrin, t, TRUE);
    }
  else
    error = FFEBAD;	/* Not really needed, but quiet -Wuninitialized. */

  if (any || (error != FFEBAD))
    {
      if (!any)
	{

	  ffebad_start (error);
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_string (name);
	  ffebad_finish ();
	}

      *expr = ffebld_new_any ();
      *info = ffeinfo_new_any ();
    }
  else
    {
      *info = ffeinfo_new (bt,
			   kt,
			   0,
			   FFEINFO_kindENTITY,
			   FFEINFO_whereFLEETING,
			   sz);
      symter = ffebld_left (*expr);
      ffebld_set_info (symter,
		       ffeinfo_new (bt,
				    kt,
				    0,
				    (bt == FFEINFO_basictypeNONE)
				    ? FFEINFO_kindSUBROUTINE
				    : FFEINFO_kindFUNCTION,
				    FFEINFO_whereINTRINSIC,
				    sz));

      if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
	  && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
	       || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
	       || (sz != ffesymbol_size (ffebld_symter (symter))))))
	{
	  ffebad_start (FFEBAD_INTRINSIC_TYPE);
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_string (name);
	  ffebad_finish ();
	}
      if (ffeintrin_imps_[imp].y2kbad)
	{
	  ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
	  ffebad_here (0, ffelex_token_where_line (t),
		       ffelex_token_where_column (t));
	  ffebad_string (name);
	  ffebad_finish ();
	}
    }
}

/* Return run-time index of intrinsic implementation as direct call.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecomGfrt
ffeintrin_gfrt_direct (ffeintrinImp imp)
{
  assert (imp < FFEINTRIN_imp);

  return ffeintrin_imps_[imp].gfrt_direct;
}
#endif

/* Return run-time index of intrinsic implementation as actual argument.  */

#if FFECOM_targetCURRENT == FFECOM_targetGCC
ffecomGfrt
ffeintrin_gfrt_indirect (ffeintrinImp imp)
{
  assert (imp < FFEINTRIN_imp);

  if (! ffe_is_f2c ())
    return ffeintrin_imps_[imp].gfrt_gnu;
  return ffeintrin_imps_[imp].gfrt_f2c;
}
#endif

void
ffeintrin_init_0 ()
{
  int i;
  const char *p1;
  const char *p2;
  const char *p3;
  int colon;

  if (!ffe_is_do_internal_checks ())
    return;

  assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_));
  assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_));
  assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_));

  for (i = 1; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)