intrin.c

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

/* intrin.c -- Recognize references to intrinsics
   Copyright (C) 1995-1998 Free Software Foundation, Inc.
   Contributed by James Craig Burley.

This file is part of GNU Fortran.

GNU Fortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.

GNU Fortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with GNU Fortran; see the file COPYING.  If not, write to
the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
02111-1307, USA.

*/

#include "proj.h"
#include "intrin.h"
#include "expr.h"
#include "info.h"
#include "src.h"
#include "symbol.h"
#include "target.h"
#include "top.h"

struct _ffeintrin_name_
  {
    const char *name_uc;
    const char *name_lc;
    const char *name_ic;
    ffeintrinGen generic;
    ffeintrinSpec specific;
  };

struct _ffeintrin_gen_
  {
    const char *name;			/* Name as seen in program. */
    ffeintrinSpec specs[2];
  };

struct _ffeintrin_spec_
  {
    const char *name;		/* Uppercase name as seen in source code,
				   lowercase if no source name, "none" if no
				   name at all (NONE case). */
    bool is_actualarg;		/* Ok to pass as actual arg if -pedantic. */
    ffeintrinFamily family;
    ffeintrinImp implementation;
  };

struct _ffeintrin_imp_
  {
    const char *name;		/* Name of implementation. */
#if FFECOM_targetCURRENT == FFECOM_targetGCC
    ffecomGfrt gfrt_direct;	/* library routine, direct-callable form. */
    ffecomGfrt gfrt_f2c;	/* library routine, f2c-callable form. */
    ffecomGfrt gfrt_gnu;	/* library routine, gnu-callable form. */
#endif	/* FFECOM_targetCURRENT == FFECOM_targetGCC */
    const char *control;
    char y2kbad;
  };

static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
				ffebld args, ffeinfoBasictype *xbt,
				ffeinfoKindtype *xkt,
				ffetargetCharacterSize *xsz,
				bool *check_intrin,
				ffelexToken t,
				bool commit);
static bool ffeintrin_check_any_ (ffebld arglist);
static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic);

static struct _ffeintrin_name_ ffeintrin_names_[]
=
{				/* Alpha order. */
#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
  { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
#include "intrin.def"
#undef DEFNAME
#undef DEFGEN
#undef DEFSPEC
#undef DEFIMP
#undef DEFIMPY
};

static struct _ffeintrin_gen_ ffeintrin_gens_[]
=
{
#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
#define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
  { NAME, { SPEC1, SPEC2, }, },
#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
#include "intrin.def"
#undef DEFNAME
#undef DEFGEN
#undef DEFSPEC
#undef DEFIMP
#undef DEFIMPY
};

static struct _ffeintrin_imp_ ffeintrin_imps_[]
=
{
#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
#if FFECOM_targetCURRENT == FFECOM_targetGCC
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
      { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
	FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE },
#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
      { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
	FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD },
#elif FFECOM_targetCURRENT == FFECOM_targetFFE
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
      { NAME, CONTROL, FALSE },
#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
      { NAME, CONTROL, Y2KBAD },
#else
#error
#endif
#include "intrin.def"
#undef DEFNAME
#undef DEFGEN
#undef DEFSPEC
#undef DEFIMP
#undef DEFIMPY
};

static struct _ffeintrin_spec_ ffeintrin_specs_[]
=
{
#define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
#define DEFGEN(CODE,NAME,SPEC1,SPEC2)
#define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
  { NAME, CALLABLE, FAMILY, IMP, },
#define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
#define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
#include "intrin.def"
#undef DEFGEN
#undef DEFSPEC
#undef DEFIMP
#undef DEFIMPY
};


static ffebad
ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
		  ffebld args, ffeinfoBasictype *xbt,
		  ffeinfoKindtype *xkt,
		  ffetargetCharacterSize *xsz,
		  bool *check_intrin,
		  ffelexToken t,
		  bool commit)
{
  const char *c = ffeintrin_imps_[imp].control;
  bool subr = (c[0] == '-');
  const char *argc;
  ffebld arg;
  ffeinfoBasictype bt;
  ffeinfoKindtype kt;
  ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
  ffeinfoKindtype firstarg_kt;
  bool need_col;
  ffeinfoBasictype col_bt = FFEINFO_basictypeNONE;
  ffeinfoKindtype col_kt = FFEINFO_kindtypeNONE;
  int colon = (c[2] == ':') ? 2 : 3;
  int argno;

  /* Check procedure type (function vs. subroutine) against
     invocation.  */

  if (op == FFEBLD_opSUBRREF)
    {
      if (!subr)
	return FFEBAD_INTRINSIC_IS_FUNC;
    }
  else if (op == FFEBLD_opFUNCREF)
    {
      if (subr)
	return FFEBAD_INTRINSIC_IS_SUBR;
    }
  else
    return FFEBAD_INTRINSIC_REF;

  /* Check the arglist for validity.  */

  if ((args != NULL)
      && (ffebld_head (args) != NULL))
    firstarg_kt = ffeinfo_kindtype (ffebld_info (ffebld_head (args)));
  else
    firstarg_kt = FFEINFO_kindtype;

  for (argc = &c[colon + 3],
	 arg = args;
       *argc != '\0';
       )
    {
      char optional = '\0';
      char required = '\0';
      char extra = '\0';
      char basic;
      char kind;
      int length;
      int elements;
      bool lastarg_complex = FALSE;

      /* We don't do anything with keywords yet.  */
      do
	{
	} while (*(++argc) != '=');

      ++argc;
      if ((*argc == '?')
	  || (*argc == '!')
	  || (*argc == '*'))
	optional = *(argc++);
      if ((*argc == '+')
	  || (*argc == 'n')
	  || (*argc == 'p'))
	required = *(argc++);
      basic = *(argc++);
      kind = *(argc++);
      if (*argc == '[')
	{
	  length = *++argc - '0';
	  if (*++argc != ']')
	    length = 10 * length + (*(argc++) - '0');
	  ++argc;
	}
      else
	length = -1;
      if (*argc == '(')
	{
	  elements = *++argc - '0';
	  if (*++argc != ')')
	    elements = 10 * elements + (*(argc++) - '0');
	  ++argc;
	}
      else if (*argc == '&')
	{
	  elements = -1;
	  ++argc;
	}
      else
	elements = 0;
      if ((*argc == '&')
	  || (*argc == 'i')
	  || (*argc == 'w')
	  || (*argc == 'x'))
	extra = *(argc++);
      if (*argc == ',')
	++argc;

      /* Break out of this loop only when current arg spec completely
	 processed.  */

      do
	{
	  bool okay;
	  ffebld a;
	  ffeinfo i;
	  bool anynum;
	  ffeinfoBasictype abt = FFEINFO_basictypeNONE;
	  ffeinfoKindtype akt = FFEINFO_kindtypeNONE;

	  if ((arg == NULL)
	      || (ffebld_head (arg) == NULL))
	    {
	      if (required != '\0')
		return FFEBAD_INTRINSIC_TOOFEW;
	      if (optional == '\0')
		return FFEBAD_INTRINSIC_TOOFEW;
	      if (arg != NULL)
		arg = ffebld_trail (arg);
	      break;	/* Try next argspec. */
	    }

	  a = ffebld_head (arg);
	  i = ffebld_info (a);
	  anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
	    || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);

	  /* See how well the arg matches up to the spec.  */

	  switch (basic)
	    {
	    case 'A':
	      okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
		&& ((length == -1)
		    || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
	      break;

	    case 'C':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
	      abt = FFEINFO_basictypeCOMPLEX;
	      break;

	    case 'I':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
	      abt = FFEINFO_basictypeINTEGER;
	      break;

	    case 'L':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
	      abt = FFEINFO_basictypeLOGICAL;
	      break;

	    case 'R':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
	      abt = FFEINFO_basictypeREAL;
	      break;

	    case 'B':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
	      break;

	    case 'F':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
	      break;

	    case 'N':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
	      break;

	    case 'S':
	      okay = anynum
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
		|| (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
	      break;

	    case 'g':
	      okay = ((ffebld_op (a) == FFEBLD_opLABTER)
		      || (ffebld_op (a) == FFEBLD_opLABTOK));
	      elements = -1;
	      extra = '-';
	      break;

	    case 's':
	      okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
			 && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
			 && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
			|| ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
			    && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
			    && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
			|| (ffeinfo_kind (i) == FFEINFO_kindNONE))
		       && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
			   || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
		      || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
			  && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
	      elements = -1;
	      extra = '-';
	      break;

	    case '-':
	    default:
	      okay = TRUE;
	      break;
	    }

	  switch (kind)
	    {
	    case '1': case '2': case '3': case '4': case '5':
	    case '6': case '7': case '8': case '9':
	      akt = (kind - '0');
	      if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
		  || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
		{
		  switch (akt)
		    {	/* Translate to internal kinds for now! */
		    default:
		      break;

		    case 2:
		      akt = 4;
		      break;

		    case 3:
		      akt = 2;
		      break;

		    case 4:
		      akt = 5;
		      break;

		    case 6:
		      akt = 3;
		      break;

		    case 7:
		      akt = ffecom_pointer_kind ();
		      break;
		    }
		}
	      okay &= anynum || (ffeinfo_kindtype (i) == akt);
	      break;

	    case 'A':
	      okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
	      akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
		: firstarg_kt;
	      break;

	    case '*':
	    default:
	      break;
	    }

	  switch (elements)
	    {
	      ffebld b;

	    case -1:
	      break;

	    case 0:
	      if (ffeinfo_rank (i) != 0)
		okay = FALSE;
	      break;

	    default:
	      if ((ffeinfo_rank (i) != 1)
		  || (ffebld_op (a) != FFEBLD_opSYMTER)
		  || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
		  || (ffebld_op (b) != FFEBLD_opCONTER)
		  || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
		  || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
		  || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
		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)
	    {
	      /* If we know dummy arg type, convert to that now.  */

	      if ((abt != FFEINFO_basictypeNONE)
		  && (akt != FFEINFO_kindtypeNONE)
		  && commit)
		{
		  /* 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);
		}
	    }

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