#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 *const name_uc;
const char *const name_lc;
const char *const name_ic;
const ffeintrinGen generic;
const ffeintrinSpec specific;
};
struct _ffeintrin_gen_
{
const char *const name;
const ffeintrinSpec specs[2];
};
struct _ffeintrin_spec_
{
const char *const name;
const bool is_actualarg;
const ffeintrinFamily family;
const ffeintrinImp implementation;
};
struct _ffeintrin_imp_
{
const char *const name;
const ffecomGfrt gfrt_direct;
const ffecomGfrt gfrt_f2c;
const ffecomGfrt gfrt_gnu;
const char *const control;
const 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 const struct _ffeintrin_name_ ffeintrin_names_[]
=
{
#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 const 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 const 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)
#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 },
#include "intrin.def"
#undef DEFNAME
#undef DEFGEN
#undef DEFSPEC
#undef DEFIMP
#undef DEFIMPY
};
static const 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;
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;
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;
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;
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;
}
a = ffebld_head (arg);
i = ffebld_info (a);
anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
|| (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
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)
{
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 'N':
if (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
{
okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER1
|| ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER2
|| ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER3);
akt = FFEINFO_kindtypeINTEGER1;
}
else if (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL)
{
okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL1
|| ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL2
|| ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL3);
akt = FFEINFO_kindtypeLOGICAL1;
}
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 (optional == '\0')
return FFEBAD_INTRINSIC_REF;
break;
}
lastarg_complex
= (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
if (anynum)
{
if ((abt != FFEINFO_basictypeNONE)
&& (akt != FFEINFO_kindtypeNONE)
&& commit)
{
a = ffeexpr_convert (a, t, NULL,
abt, akt, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
ffebld_set_head (arg, a);
}
}
arg = ffebld_trail (arg);
if (optional == '*')
continue;
if (required == '\0')
break;
if ((required == 'n')
|| (required == '+'))
{
optional = '*';
required = '\0';
}
else if (required == 'p')
required = 'n';
} while (TRUE);
}
if (arg != NULL)
return FFEBAD_INTRINSIC_TOOMANY;
need_col = FALSE;
switch (c[0])
{
case 'A':
bt = FFEINFO_basictypeCHARACTER;
sz = (c[2] == '*') ? FFETARGET_charactersizeNONE : 1;
break;
case 'C':
bt = FFEINFO_basictypeCOMPLEX;
break;
case 'I':
bt = FFEINFO_basictypeINTEGER;
break;
case 'L':
bt = FFEINFO_basictypeLOGICAL;
break;
case 'R':
bt = FFEINFO_basictypeREAL;
break;
case 'B':
case 'F':
case 'N':
case 'S':
need_col = TRUE;
case '-':
default:
bt = FFEINFO_basictypeNONE;
break;
}
switch (c[1])
{
case '1': case '2': case '3': case '4': case '5':
case '6': case '7': case '8': case '9':
kt = (c[1] - '0');
if ((bt == FFEINFO_basictypeINTEGER)
|| (bt == FFEINFO_basictypeLOGICAL))
{
switch (kt)
{
default:
break;
case 2:
kt = 4;
break;
case 3:
kt = 2;
break;
case 4:
kt = 5;
break;
case 6:
kt = 3;
break;
case 7:
kt = ffecom_pointer_kind ();
break;
}
}
break;
case 'C':
if (ffe_is_90 ())
need_col = TRUE;
kt = 1;
break;
case '=':
need_col = TRUE;
case '-':
default:
kt = FFEINFO_kindtypeNONE;
break;
}
if (need_col || c[colon + 1] != '-')
{
bool okay = TRUE;
bool have_anynum = FALSE;
int arg_count=0;
for (arg = args, arg_count=0;
arg != NULL;
arg = ffebld_trail (arg), arg_count++ )
{
ffebld a = ffebld_head (arg);
ffeinfo i;
bool anynum;
if (a == NULL)
continue;
i = ffebld_info (a);
if ( c[colon+1] != '*' && (c[colon+1]-'0') != arg_count )
continue;
anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
|| (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
if (anynum)
{
have_anynum = TRUE;
continue;
}
if ((col_bt == FFEINFO_basictypeNONE)
&& (col_kt == FFEINFO_kindtypeNONE))
{
col_bt = ffeinfo_basictype (i);
col_kt = ffeinfo_kindtype (i);
}
else
{
ffeexpr_type_combine (&col_bt, &col_kt,
col_bt, col_kt,
ffeinfo_basictype (i),
ffeinfo_kindtype (i),
NULL);
if ((col_bt == FFEINFO_basictypeNONE)
|| (col_kt == FFEINFO_kindtypeNONE))
return FFEBAD_INTRINSIC_REF;
}
}
if (have_anynum
&& ((col_bt == FFEINFO_basictypeNONE)
|| (col_kt == FFEINFO_kindtypeNONE)))
{
switch (c[0])
{
case 'A':
return FFEBAD_INTRINSIC_REF;
case 'B':
case 'I':
case 'L':
if ((col_bt != FFEINFO_basictypeNONE)
&& (col_bt != FFEINFO_basictypeINTEGER))
return FFEBAD_INTRINSIC_REF;
case 'N':
case 'S':
case '-':
default:
col_bt = FFEINFO_basictypeINTEGER;
col_kt = FFEINFO_kindtypeINTEGER1;
break;
case 'C':
if ((col_bt != FFEINFO_basictypeNONE)
&& (col_bt != FFEINFO_basictypeCOMPLEX))
return FFEBAD_INTRINSIC_REF;
col_bt = FFEINFO_basictypeCOMPLEX;
col_kt = FFEINFO_kindtypeREAL1;
break;
case 'R':
if ((col_bt != FFEINFO_basictypeNONE)
&& (col_bt != FFEINFO_basictypeREAL))
return FFEBAD_INTRINSIC_REF;
case 'F':
col_bt = FFEINFO_basictypeREAL;
col_kt = FFEINFO_kindtypeREAL1;
break;
}
}
switch (c[0])
{
case 'B':
okay = (col_bt == FFEINFO_basictypeINTEGER)
|| (col_bt == FFEINFO_basictypeLOGICAL);
if (need_col)
bt = col_bt;
break;
case 'F':
okay = (col_bt == FFEINFO_basictypeCOMPLEX)
|| (col_bt == FFEINFO_basictypeREAL);
if (need_col)
bt = col_bt;
break;
case 'N':
okay = (col_bt == FFEINFO_basictypeCOMPLEX)
|| (col_bt == FFEINFO_basictypeINTEGER)
|| (col_bt == FFEINFO_basictypeREAL);
if (need_col)
bt = col_bt;
break;
case 'S':
okay = (col_bt == FFEINFO_basictypeINTEGER)
|| (col_bt == FFEINFO_basictypeREAL)
|| (col_bt == FFEINFO_basictypeCOMPLEX);
if (need_col)
bt = ((col_bt != FFEINFO_basictypeCOMPLEX) ? col_bt
: FFEINFO_basictypeREAL);
break;
}
switch (c[1])
{
case '=':
if (need_col)
kt = col_kt;
break;
case 'C':
if (col_bt == FFEINFO_basictypeCOMPLEX)
{
if (col_kt != FFEINFO_kindtypeREALDEFAULT)
*check_intrin = TRUE;
if (need_col)
kt = col_kt;
}
break;
}
if (!okay)
return FFEBAD_INTRINSIC_REF;
}
for (argno = 0, argc = &c[colon + 3],
arg = args;
*argc != '\0';
++argno)
{
char optional = '\0';
char required = '\0';
char extra = '\0';
char basic;
char kind;
int length;
int elements;
bool lastarg_complex = FALSE;
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;
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 (arg != NULL)
arg = ffebld_trail (arg);
break;
}
a = ffebld_head (arg);
i = ffebld_info (a);
anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
|| (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
if (anynum)
{
switch (c[colon + 1])
{
case '-':
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
if (argno != (c[colon + 1] - '0'))
break;
case '*':
abt = col_bt;
akt = col_kt;
break;
}
}
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)
{
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 (optional == '\0')
return FFEBAD_INTRINSIC_REF;
break;
}
lastarg_complex
= (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
if (anynum && commit)
{
if (abt == FFEINFO_basictypeNONE)
abt = FFEINFO_basictypeINTEGER;
if (akt == FFEINFO_kindtypeNONE)
akt = FFEINFO_kindtypeINTEGER1;
a = ffeexpr_convert (a, t, NULL,
abt, akt, 0,
FFETARGET_charactersizeNONE,
FFEEXPR_contextLET);
ffebld_set_head (arg, a);
}
else if ((c[colon + 1] == '*') && commit)
{
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);
if (optional == '*')
continue;
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;
}
static int
upcasecmp_ (const char *name, const char *ucname)
{
for ( ; *name != 0 && *ucname != 0; name++, ucname++)
{
int i = TOUPPER(*name) - *ucname;
if (i != 0)
return i;
}
return *name - *ucname;
}
static int
ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
{
const char *const uc = ((const struct _ffeintrin_name_ *) intrinsic)->name_uc;
const char *const lc = ((const struct _ffeintrin_name_ *) intrinsic)->name_lc;
const char *const ic = ((const struct _ffeintrin_name_ *) intrinsic)->name_ic;
int i;
if ((i = upcasecmp_ (name, uc)) == 0)
{
switch (ffe_case_intrin ())
{
case FFE_caseLOWER:
return strcmp(name, lc);
case FFE_caseINITCAP:
return strcmp(name, ic);
default:
return 0;
}
}
return i;
}
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);
}
ffeintrinFamily
ffeintrin_family (ffeintrinSpec spec)
{
if (spec >= FFEINTRIN_spec)
return FALSE;
return ffeintrin_specs_[spec].family;
}
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;
}
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)
{
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 ();
}
}
}
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;
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 ();
}
}
}
ffecomGfrt
ffeintrin_gfrt_direct (ffeintrinImp imp)
{
assert (imp < FFEINTRIN_imp);
return ffeintrin_imps_[imp].gfrt_direct;
}
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;
}
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)
{
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 ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
continue;
if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2)
|| (*p1 != TOUPPER (*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] != '*')
&& (! ISDIGIT (c[colon + 1])))
{
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 ((! ISDIGIT (c[4]))
|| ((c[5] != ']')
&& (++c, ! ISDIGIT (c[4])
|| (c[5] != ']'))))
{
fprintf (stderr, "%s: bad arg-len\n",
ffeintrin_imps_[i].name);
break;
}
c += 3;
}
if (c[3] == '(')
{
if ((! ISDIGIT (c[4]))
|| ((c[5] != ')')
&& (++c, ! ISDIGIT (c[4])
|| (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;
}
}
}
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)
&& (ffe_is_f2c ()
? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
!= FFECOM_gfrt)
: (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
!= FFECOM_gfrt))
&& ((state == FFE_intrinsicstateENABLED)
|| (state == FFE_intrinsicstateHIDDEN));
}
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;
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;
}
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 ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
{
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;
}
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;
}
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;
}
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);
}
const char *
ffeintrin_name_generic (ffeintrinGen gen)
{
assert (gen < FFEINTRIN_gen);
return ffeintrin_gens_[gen].name;
}
const char *
ffeintrin_name_implementation (ffeintrinImp imp)
{
assert (imp < FFEINTRIN_imp);
return ffeintrin_imps_[imp].name;
}
const char *
ffeintrin_name_specific (ffeintrinSpec spec)
{
assert (spec < FFEINTRIN_spec);
return ffeintrin_specs_[spec].name;
}
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;
}
}