intrin.c

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

    {				/* Make sure binary-searched list is in alpha
				   order. */
      if (strcmp (ffeintrin_names_[i - 1].name_uc,
		  ffeintrin_names_[i].name_uc) >= 0)
	assert ("name list out of order" == NULL);
    }

  for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
    {
      assert ((ffeintrin_names_[i].generic == FFEINTRIN_genNONE)
	      || (ffeintrin_names_[i].specific == FFEINTRIN_specNONE));

      p1 = ffeintrin_names_[i].name_uc;
      p2 = ffeintrin_names_[i].name_lc;
      p3 = ffeintrin_names_[i].name_ic;
      for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3)
	{
	  if (! IN_CTYPE_DOMAIN (*p1)
	      || ! IN_CTYPE_DOMAIN (*p2)
	      || ! IN_CTYPE_DOMAIN (*p3))
	    break;
	  if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
	    continue;
	  if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2)
	      || (*p1 != toupper ((unsigned char)*p2))
	      || ((*p3 != *p1) && (*p3 != *p2)))
	    break;
	}
      assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
    }

  for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i)
    {
      const char *c = ffeintrin_imps_[i].control;

      if (c[0] == '\0')
	continue;

      if ((c[0] != '-')
	  && (c[0] != 'A')
	  && (c[0] != 'C')
	  && (c[0] != 'I')
	  && (c[0] != 'L')
	  && (c[0] != 'R')
	  && (c[0] != 'B')
	  && (c[0] != 'F')
	  && (c[0] != 'N')
	  && (c[0] != 'S'))
	{
	  fprintf (stderr, "%s: bad return-base-type\n",
		   ffeintrin_imps_[i].name);
	  continue;
	}
      if ((c[1] != '-')
	  && (c[1] != '=')
	  && ((c[1] < '1')
	      || (c[1] > '9'))
	  && (c[1] != 'C'))
	{
	  fprintf (stderr, "%s: bad return-kind-type\n",
		   ffeintrin_imps_[i].name);
	  continue;
	}
      if (c[2] == ':')
	colon = 2;
      else
	{
	  if (c[2] != '*')
	    {
	      fprintf (stderr, "%s: bad return-modifier\n",
		       ffeintrin_imps_[i].name);
	      continue;
	    }
	  colon = 3;
	}
      if ((c[colon] != ':') || (c[colon + 2] != ':'))
	{
	  fprintf (stderr, "%s: bad control\n",
		   ffeintrin_imps_[i].name);
	  continue;
	}
      if ((c[colon + 1] != '-')
	  && (c[colon + 1] != '*')
	  && ((c[colon + 1] < '0')
	      || (c[colon + 1] > '9')))
	{
	  fprintf (stderr, "%s: bad COL-spec\n",
		   ffeintrin_imps_[i].name);
	  continue;
	}
      c += (colon + 3);
      while (c[0] != '\0')
	{
	  while ((c[0] != '=')
		 && (c[0] != ',')
		 && (c[0] != '\0'))
	    ++c;
	  if (c[0] != '=')
	    {
	      fprintf (stderr, "%s: bad keyword\n",
		       ffeintrin_imps_[i].name);
	      break;
	    }
	  if ((c[1] == '?')
	      || (c[1] == '!')
	      || (c[1] == '+')
	      || (c[1] == '*')
	      || (c[1] == 'n')
	      || (c[1] == 'p'))
	    ++c;
	  if ((c[1] != '-')
	      && (c[1] != 'A')
	      && (c[1] != 'C')
	      && (c[1] != 'I')
	      && (c[1] != 'L')
	      && (c[1] != 'R')
	      && (c[1] != 'B')
	      && (c[1] != 'F')
	      && (c[1] != 'N')
	      && (c[1] != 'S')
	      && (c[1] != 'g')
	      && (c[1] != 's'))
	    {
	      fprintf (stderr, "%s: bad arg-base-type\n",
		       ffeintrin_imps_[i].name);
	      break;
	    }
	  if ((c[2] != '*')
	      && ((c[2] < '1')
		  || (c[2] > '9'))
	      && (c[2] != 'A'))
	    {
	      fprintf (stderr, "%s: bad arg-kind-type\n",
		       ffeintrin_imps_[i].name);
	      break;
	    }
	  if (c[3] == '[')
	    {
	      if (((c[4] < '0') || (c[4] > '9'))
		  || ((c[5] != ']')
		      && (++c, (c[4] < '0') || (c[4] > '9')
			  || (c[5] != ']'))))
		{
		  fprintf (stderr, "%s: bad arg-len\n",
			   ffeintrin_imps_[i].name);
		  break;
		}
	      c += 3;
	    }
	  if (c[3] == '(')
	    {
	      if (((c[4] < '0') || (c[4] > '9'))
		  || ((c[5] != ')')
		      && (++c, (c[4] < '0') || (c[4] > '9')
			  || (c[5] != ')'))))
		{
		  fprintf (stderr, "%s: bad arg-rank\n",
			   ffeintrin_imps_[i].name);
		  break;
		}
	      c += 3;
	    }
	  else if ((c[3] == '&')
		   && (c[4] == '&'))
	    ++c;
	  if ((c[3] == '&')
	      || (c[3] == 'i')
	      || (c[3] == 'w')
	      || (c[3] == 'x'))
	    ++c;
	  if (c[3] == ',')
	    {
	      c += 4;
	      continue;
	    }
	  if (c[3] != '\0')
	    {
	      fprintf (stderr, "%s: bad arg-list\n",
		       ffeintrin_imps_[i].name);
	    }
	  break;
	}
    }
}

/* Determine whether intrinsic is okay as an actual argument.  */

bool
ffeintrin_is_actualarg (ffeintrinSpec spec)
{
  ffeIntrinsicState state;

  if (spec >= FFEINTRIN_spec)
    return FALSE;

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

  return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
#if FFECOM_targetCURRENT == FFECOM_targetGCC
    && (ffe_is_f2c ()
	? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
	   != FFECOM_gfrt)
	: (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
	   != FFECOM_gfrt))
#endif
    && ((state == FFE_intrinsicstateENABLED)
	|| (state == FFE_intrinsicstateHIDDEN));
}

/* Determine if name is intrinsic, return info.

   const char *name;		// C-string name of possible intrinsic.
   ffelexToken t;		// NULL if no diagnostic to be given.
   bool explicit;		// TRUE if INTRINSIC name.
   ffeintrinGen gen;		// (TRUE only) Generic id of intrinsic.
   ffeintrinSpec spec;		// (TRUE only) Specific id of intrinsic.
   ffeintrinImp imp;		// (TRUE only) Implementation id of intrinsic.
   if (ffeintrin_is_intrinsic (name, t, explicit,
			       &gen, &spec, &imp))
				// is an intrinsic, use gen, spec, imp, and
				// kind accordingly.  */

bool
ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
			ffeintrinGen *xgen, ffeintrinSpec *xspec,
			ffeintrinImp *ximp)
{
  struct _ffeintrin_name_ *intrinsic;
  ffeintrinGen gen;
  ffeintrinSpec spec;
  ffeintrinImp imp;
  ffeIntrinsicState state;
  bool disabled = FALSE;
  bool unimpl = FALSE;

  intrinsic = bsearch (name, &ffeintrin_names_[0],
		       ARRAY_SIZE (ffeintrin_names_),
		       sizeof (struct _ffeintrin_name_),
		         (void *) ffeintrin_cmp_name_);

  if (intrinsic == NULL)
    return FALSE;

  gen = intrinsic->generic;
  spec = intrinsic->specific;
  imp = ffeintrin_specs_[spec].implementation;

  /* Generic is okay only if at least one of its specifics is okay.  */

  if (gen != FFEINTRIN_genNONE)
    {
      int i;
      ffeintrinSpec tspec;
      bool ok = FALSE;

      name = ffeintrin_gens_[gen].name;

      for (i = 0;
	   (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
	   && ((tspec
		= ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
	   ++i)
	{
	  state = ffeintrin_state_family (ffeintrin_specs_[tspec].family);

	  if (state == FFE_intrinsicstateDELETED)
	    continue;

	  if (state == FFE_intrinsicstateDISABLED)
	    {
	      disabled = TRUE;
	      continue;
	    }

	  if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE)
	    {
	      unimpl = TRUE;
	      continue;
	    }

	  if ((state == FFE_intrinsicstateENABLED)
	      || (explicit
		  && (state == FFE_intrinsicstateHIDDEN)))
	    {
	      ok = TRUE;
	      break;
	    }
	}
      if (!ok)
	gen = FFEINTRIN_genNONE;
    }

  /* Specific is okay only if not: unimplemented, disabled, deleted, or
     hidden and not explicit.  */

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

      if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family))
	   == FFE_intrinsicstateDELETED)
	  || (!explicit
	      && (state == FFE_intrinsicstateHIDDEN)))
	spec = FFEINTRIN_specNONE;
      else if (state == FFE_intrinsicstateDISABLED)
	{
	  disabled = TRUE;
	  spec = FFEINTRIN_specNONE;
	}
      else if (imp == FFEINTRIN_impNONE)
	{
	  unimpl = TRUE;
	  spec = FFEINTRIN_specNONE;
	}
    }

  /* If neither is okay, not an intrinsic.  */

  if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
    {
      /* Here is where we produce a diagnostic about a reference to a
	 disabled or unimplemented intrinsic, if the diagnostic is desired.  */

      if ((disabled || unimpl)
	  && (t != NULL))
	{
	  ffebad_start (disabled
			? FFEBAD_INTRINSIC_DISABLED
			: FFEBAD_INTRINSIC_UNIMPLW);
	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
	  ffebad_string (name);
	  ffebad_finish ();
	}

      return FALSE;
    }

  /* Determine whether intrinsic is function or subroutine.  If no specific
     id, scan list of possible specifics for generic to get consensus.  If
     not unanimous, or clear from the context, return NONE.  */

  if (spec == FFEINTRIN_specNONE)
    {
      int i;
      ffeintrinSpec tspec;
      ffeintrinImp timp;
      bool at_least_one_ok = FALSE;

      for (i = 0;
	   (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
	   && ((tspec
		= ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
	   ++i)
	{
	  if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family))
	       == FFE_intrinsicstateDELETED)
	      || (state == FFE_intrinsicstateDISABLED))
	    continue;

	  if ((timp = ffeintrin_specs_[tspec].implementation)
	      == FFEINTRIN_impNONE)
	    continue;

	  at_least_one_ok = TRUE;
	  break;
	}

      if (!at_least_one_ok)
	{
	  *xgen = FFEINTRIN_genNONE;
	  *xspec = FFEINTRIN_specNONE;
	  *ximp = FFEINTRIN_impNONE;
	  return FALSE;
	}
    }

  *xgen = gen;
  *xspec = spec;
  *ximp = imp;
  return TRUE;
}

/* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90).  */

bool
ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec)
{
  if (spec == FFEINTRIN_specNONE)
    {
      if (gen == FFEINTRIN_genNONE)
	return FALSE;

      spec = ffeintrin_gens_[gen].specs[0];
      if (spec == FFEINTRIN_specNONE)
	return FALSE;
    }

  if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77)
      || (ffe_is_90 ()
	  && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90)
	      || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL)
	      || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC))))
    return TRUE;
  return FALSE;
}

/* Return kind type of intrinsic implementation.  See ffeintrin_basictype,
   its sibling.  */

ffeinfoKindtype
ffeintrin_kindtype (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_kindtype (gfrt);
}

/* Return name of generic intrinsic.  */

const char *
ffeintrin_name_generic (ffeintrinGen gen)
{
  assert (gen < FFEINTRIN_gen);
  return ffeintrin_gens_[gen].name;
}

/* Return name of intrinsic implementation.  */

const char *
ffeintrin_name_implementation (ffeintrinImp imp)
{
  assert (imp < FFEINTRIN_imp);
  return ffeintrin_imps_[imp].name;
}

/* Return external/internal name of specific intrinsic.	 */

const char *
ffeintrin_name_specific (ffeintrinSpec spec)
{
  assert (spec < FFEINTRIN_spec);
  return ffeintrin_specs_[spec].name;
}

/* Return state of family.  */

ffeIntrinsicState
ffeintrin_state_family (ffeintrinFamily family)
{
  ffeIntrinsicState state;

  switch (family)
    {
    case FFEINTRIN_familyNONE:
      return FFE_intrinsicstateDELETED;

    case FFEINTRIN_familyF77:
      return FFE_intrinsicstateENABLED;

    case FFEINTRIN_familyASC:
      state = ffe_intrinsic_state_f2c ();
      state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
      return state;

    case FFEINTRIN_familyMIL:
      state = ffe_intrinsic_state_vxt ();
      state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
      state = ffe_state_max (state, ffe_intrinsic_state_mil ());
      return state;

    case FFEINTRIN_familyGNU:
      state = ffe_intrinsic_state_gnu ();
      return state;

    case FFEINTRIN_familyF90:
      state = ffe_intrinsic_state_f90 ();
      return state;

    case FFEINTRIN_familyVXT:
      state = ffe_intrinsic_state_vxt ();
      return state;

    case FFEINTRIN_familyFVZ:
      state = ffe_intrinsic_state_f2c ();
      state = ffe_state_max (state, ffe_intrinsic_state_vxt ());
      return state;

    case FFEINTRIN_familyF2C:
      state = ffe_intrinsic_state_f2c ();
      return state;

    case FFEINTRIN_familyF2U:
      state = ffe_intrinsic_state_unix ();
      return state;

    case FFEINTRIN_familyBADU77:
      state = ffe_intrinsic_state_badu77 ();
      return state;

    default:
      assert ("bad family" == NULL);
      return FFE_intrinsicstateDELETED;
    }
}