1 /* intrin.c -- Recognize references to intrinsics
2 Copyright (C) 1995, 1996, 1997, 1998, 2002 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
33 struct _ffeintrin_name_
35 const char *const name_uc;
36 const char *const name_lc;
37 const char *const name_ic;
38 const ffeintrinGen generic;
39 const ffeintrinSpec specific;
42 struct _ffeintrin_gen_
44 const char *const name; /* Name as seen in program. */
45 const ffeintrinSpec specs[2];
48 struct _ffeintrin_spec_
50 const char *const name; /* Uppercase name as seen in source code,
51 lowercase if no source name, "none" if no
52 name at all (NONE case). */
53 const bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */
54 const ffeintrinFamily family;
55 const ffeintrinImp implementation;
58 struct _ffeintrin_imp_
60 const char *const name; /* Name of implementation. */
61 const ffecomGfrt gfrt_direct;/* library routine, direct-callable form. */
62 const ffecomGfrt gfrt_f2c; /* library routine, f2c-callable form. */
63 const ffecomGfrt gfrt_gnu; /* library routine, gnu-callable form. */
64 const char *const control;
68 static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
69 ffebld args, ffeinfoBasictype *xbt,
71 ffetargetCharacterSize *xsz,
75 static bool ffeintrin_check_any_ (ffebld arglist);
76 static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic);
78 static const struct _ffeintrin_name_ ffeintrin_names_[]
81 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
82 { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
83 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
84 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
85 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
86 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
95 static const struct _ffeintrin_gen_ ffeintrin_gens_[]
98 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
99 #define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
100 { NAME, { SPEC1, SPEC2, }, },
101 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
102 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
103 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
104 #include "intrin.def"
112 static const struct _ffeintrin_imp_ ffeintrin_imps_[]
115 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
116 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
117 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
118 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
119 { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
120 FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE },
121 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
122 { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
123 FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD },
124 #include "intrin.def"
132 static const struct _ffeintrin_spec_ ffeintrin_specs_[]
135 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
136 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
137 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
138 { NAME, CALLABLE, FAMILY, IMP, },
139 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
140 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
141 #include "intrin.def"
150 ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
151 ffebld args, ffeinfoBasictype *xbt,
152 ffeinfoKindtype *xkt,
153 ffetargetCharacterSize *xsz,
158 const char *c = ffeintrin_imps_[imp].control;
159 bool subr = (c[0] == '-');
164 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
165 ffeinfoKindtype firstarg_kt;
167 ffeinfoBasictype col_bt = FFEINFO_basictypeNONE;
168 ffeinfoKindtype col_kt = FFEINFO_kindtypeNONE;
169 int colon = (c[2] == ':') ? 2 : 3;
172 /* Check procedure type (function vs. subroutine) against
175 if (op == FFEBLD_opSUBRREF)
178 return FFEBAD_INTRINSIC_IS_FUNC;
180 else if (op == FFEBLD_opFUNCREF)
183 return FFEBAD_INTRINSIC_IS_SUBR;
186 return FFEBAD_INTRINSIC_REF;
188 /* Check the arglist for validity. */
191 && (ffebld_head (args) != NULL))
192 firstarg_kt = ffeinfo_kindtype (ffebld_info (ffebld_head (args)));
194 firstarg_kt = FFEINFO_kindtype;
196 for (argc = &c[colon + 3],
201 char optional = '\0';
202 char required = '\0';
208 bool lastarg_complex = FALSE;
210 /* We don't do anything with keywords yet. */
213 } while (*(++argc) != '=');
219 optional = *(argc++);
223 required = *(argc++);
228 length = *++argc - '0';
230 length = 10 * length + (*(argc++) - '0');
237 elements = *++argc - '0';
239 elements = 10 * elements + (*(argc++) - '0');
242 else if (*argc == '&')
257 /* Break out of this loop only when current arg spec completely
266 ffeinfoBasictype abt = FFEINFO_basictypeNONE;
267 ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
270 || (ffebld_head (arg) == NULL))
272 if (required != '\0')
273 return FFEBAD_INTRINSIC_TOOFEW;
274 if (optional == '\0')
275 return FFEBAD_INTRINSIC_TOOFEW;
277 arg = ffebld_trail (arg);
278 break; /* Try next argspec. */
281 a = ffebld_head (arg);
283 anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
284 || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
286 /* See how well the arg matches up to the spec. */
291 okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
293 || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
298 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
299 abt = FFEINFO_basictypeCOMPLEX;
304 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
305 abt = FFEINFO_basictypeINTEGER;
310 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
311 abt = FFEINFO_basictypeLOGICAL;
316 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
317 abt = FFEINFO_basictypeREAL;
322 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
323 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
328 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
329 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
334 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
335 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
336 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
341 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
342 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
346 okay = ((ffebld_op (a) == FFEBLD_opLABTER)
347 || (ffebld_op (a) == FFEBLD_opLABTOK));
353 okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
354 && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
355 && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
356 || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
357 && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
358 && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
359 || (ffeinfo_kind (i) == FFEINFO_kindNONE))
360 && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
361 || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
362 || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
363 && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
376 case '1': case '2': case '3': case '4': case '5':
377 case '6': case '7': case '8': case '9':
379 if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
380 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
383 { /* Translate to internal kinds for now! */
404 akt = ffecom_pointer_kind ();
408 okay &= anynum || (ffeinfo_kindtype (i) == akt);
412 okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
413 akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
418 /* Accept integers and logicals not wider than the default integer/logical. */
419 if (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
421 okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER1
422 || ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER2
423 || ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGER3);
424 akt = FFEINFO_kindtypeINTEGER1; /* The default. */
426 else if (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL)
428 okay &= anynum || (ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL1
429 || ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL2
430 || ffeinfo_kindtype (i) == FFEINFO_kindtypeLOGICAL3);
431 akt = FFEINFO_kindtypeLOGICAL1; /* The default. */
448 if (ffeinfo_rank (i) != 0)
453 if ((ffeinfo_rank (i) != 1)
454 || (ffebld_op (a) != FFEBLD_opSYMTER)
455 || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
456 || (ffebld_op (b) != FFEBLD_opCONTER)
457 || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
458 || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
459 || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
467 if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
468 || ((ffebld_op (a) != FFEBLD_opSYMTER)
469 && (ffebld_op (a) != FFEBLD_opSUBSTR)
470 && (ffebld_op (a) != FFEBLD_opARRAYREF)))
476 if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
477 || ((ffebld_op (a) != FFEBLD_opSYMTER)
478 && (ffebld_op (a) != FFEBLD_opARRAYREF)
479 && (ffebld_op (a) != FFEBLD_opSUBSTR)))
488 if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
493 if ((optional == '!')
499 /* If it wasn't optional, it's an error,
500 else maybe it could match a later argspec. */
501 if (optional == '\0')
502 return FFEBAD_INTRINSIC_REF;
503 break; /* Try next argspec. */
507 = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
511 /* If we know dummy arg type, convert to that now. */
513 if ((abt != FFEINFO_basictypeNONE)
514 && (akt != FFEINFO_kindtypeNONE)
517 /* We have a known type, convert hollerith/typeless
520 a = ffeexpr_convert (a, t, NULL,
522 FFETARGET_charactersizeNONE,
524 ffebld_set_head (arg, a);
528 arg = ffebld_trail (arg); /* Arg accepted, now move on. */
531 continue; /* Go ahead and try another arg. */
532 if (required == '\0')
534 if ((required == 'n')
535 || (required == '+'))
540 else if (required == 'p')
546 return FFEBAD_INTRINSIC_TOOMANY;
548 /* Set up the initial type for the return value of the function. */
554 bt = FFEINFO_basictypeCHARACTER;
555 sz = (c[2] == '*') ? FFETARGET_charactersizeNONE : 1;
559 bt = FFEINFO_basictypeCOMPLEX;
563 bt = FFEINFO_basictypeINTEGER;
567 bt = FFEINFO_basictypeLOGICAL;
571 bt = FFEINFO_basictypeREAL;
582 bt = FFEINFO_basictypeNONE;
588 case '1': case '2': case '3': case '4': case '5':
589 case '6': case '7': case '8': case '9':
591 if ((bt == FFEINFO_basictypeINTEGER)
592 || (bt == FFEINFO_basictypeLOGICAL))
595 { /* Translate to internal kinds for now! */
616 kt = ffecom_pointer_kind ();
633 kt = FFEINFO_kindtypeNONE;
637 /* Determine collective type of COL, if there is one. */
639 if (need_col || c[colon + 1] != '-')
642 bool have_anynum = FALSE;
645 for (arg = args, arg_count=0;
647 arg = ffebld_trail (arg), arg_count++ )
649 ffebld a = ffebld_head (arg);
657 if ( c[colon+1] != '*' && (c[colon+1]-'0') != arg_count )
660 anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
661 || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
668 if ((col_bt == FFEINFO_basictypeNONE)
669 && (col_kt == FFEINFO_kindtypeNONE))
671 col_bt = ffeinfo_basictype (i);
672 col_kt = ffeinfo_kindtype (i);
676 ffeexpr_type_combine (&col_bt, &col_kt,
678 ffeinfo_basictype (i),
679 ffeinfo_kindtype (i),
681 if ((col_bt == FFEINFO_basictypeNONE)
682 || (col_kt == FFEINFO_kindtypeNONE))
683 return FFEBAD_INTRINSIC_REF;
688 && ((col_bt == FFEINFO_basictypeNONE)
689 || (col_kt == FFEINFO_kindtypeNONE)))
691 /* No type, but have hollerith/typeless. Use type of return
692 value to determine type of COL. */
697 return FFEBAD_INTRINSIC_REF;
702 if ((col_bt != FFEINFO_basictypeNONE)
703 && (col_bt != FFEINFO_basictypeINTEGER))
704 return FFEBAD_INTRINSIC_REF;
710 col_bt = FFEINFO_basictypeINTEGER;
711 col_kt = FFEINFO_kindtypeINTEGER1;
715 if ((col_bt != FFEINFO_basictypeNONE)
716 && (col_bt != FFEINFO_basictypeCOMPLEX))
717 return FFEBAD_INTRINSIC_REF;
718 col_bt = FFEINFO_basictypeCOMPLEX;
719 col_kt = FFEINFO_kindtypeREAL1;
723 if ((col_bt != FFEINFO_basictypeNONE)
724 && (col_bt != FFEINFO_basictypeREAL))
725 return FFEBAD_INTRINSIC_REF;
728 col_bt = FFEINFO_basictypeREAL;
729 col_kt = FFEINFO_kindtypeREAL1;
737 okay = (col_bt == FFEINFO_basictypeINTEGER)
738 || (col_bt == FFEINFO_basictypeLOGICAL);
744 okay = (col_bt == FFEINFO_basictypeCOMPLEX)
745 || (col_bt == FFEINFO_basictypeREAL);
751 okay = (col_bt == FFEINFO_basictypeCOMPLEX)
752 || (col_bt == FFEINFO_basictypeINTEGER)
753 || (col_bt == FFEINFO_basictypeREAL);
759 okay = (col_bt == FFEINFO_basictypeINTEGER)
760 || (col_bt == FFEINFO_basictypeREAL)
761 || (col_bt == FFEINFO_basictypeCOMPLEX);
763 bt = ((col_bt != FFEINFO_basictypeCOMPLEX) ? col_bt
764 : FFEINFO_basictypeREAL);
776 if (col_bt == FFEINFO_basictypeCOMPLEX)
778 if (col_kt != FFEINFO_kindtypeREALDEFAULT)
779 *check_intrin = TRUE;
787 return FFEBAD_INTRINSIC_REF;
790 /* Now, convert args in the arglist to the final type of the COL. */
792 for (argno = 0, argc = &c[colon + 3],
797 char optional = '\0';
798 char required = '\0';
804 bool lastarg_complex = FALSE;
806 /* We don't do anything with keywords yet. */
809 } while (*(++argc) != '=');
815 optional = *(argc++);
819 required = *(argc++);
824 length = *++argc - '0';
826 length = 10 * length + (*(argc++) - '0');
833 elements = *++argc - '0';
835 elements = 10 * elements + (*(argc++) - '0');
838 else if (*argc == '&')
853 /* Break out of this loop only when current arg spec completely
862 ffeinfoBasictype abt = FFEINFO_basictypeNONE;
863 ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
866 || (ffebld_head (arg) == NULL))
869 arg = ffebld_trail (arg);
870 break; /* Try next argspec. */
873 a = ffebld_head (arg);
875 anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
876 || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
878 /* Determine what the default type for anynum would be. */
882 switch (c[colon + 1])
886 case '0': case '1': case '2': case '3': case '4':
887 case '5': case '6': case '7': case '8': case '9':
888 if (argno != (c[colon + 1] - '0'))
897 /* Again, match arg up to the spec. We go through all of
898 this again to properly follow the contour of optional
899 arguments. Probably this level of flexibility is not
900 needed, perhaps it's even downright naughty. */
905 okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
907 || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
912 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
913 abt = FFEINFO_basictypeCOMPLEX;
918 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
919 abt = FFEINFO_basictypeINTEGER;
924 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
925 abt = FFEINFO_basictypeLOGICAL;
930 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
931 abt = FFEINFO_basictypeREAL;
936 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
937 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
942 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
943 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
948 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
949 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
950 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
955 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
956 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
960 okay = ((ffebld_op (a) == FFEBLD_opLABTER)
961 || (ffebld_op (a) == FFEBLD_opLABTOK));
967 okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
968 && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
969 && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
970 || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
971 && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
972 && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
973 || (ffeinfo_kind (i) == FFEINFO_kindNONE))
974 && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
975 || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
976 || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
977 && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
990 case '1': case '2': case '3': case '4': case '5':
991 case '6': case '7': case '8': case '9':
993 if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
994 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
997 { /* Translate to internal kinds for now! */
1018 akt = ffecom_pointer_kind ();
1022 okay &= anynum || (ffeinfo_kindtype (i) == akt);
1026 okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
1027 akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
1044 if (ffeinfo_rank (i) != 0)
1049 if ((ffeinfo_rank (i) != 1)
1050 || (ffebld_op (a) != FFEBLD_opSYMTER)
1051 || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
1052 || (ffebld_op (b) != FFEBLD_opCONTER)
1053 || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
1054 || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
1055 || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
1063 if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
1064 || ((ffebld_op (a) != FFEBLD_opSYMTER)
1065 && (ffebld_op (a) != FFEBLD_opSUBSTR)
1066 && (ffebld_op (a) != FFEBLD_opARRAYREF)))
1072 if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
1073 || ((ffebld_op (a) != FFEBLD_opSYMTER)
1074 && (ffebld_op (a) != FFEBLD_opARRAYREF)
1075 && (ffebld_op (a) != FFEBLD_opSUBSTR)))
1084 if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
1089 if ((optional == '!')
1095 /* If it wasn't optional, it's an error,
1096 else maybe it could match a later argspec. */
1097 if (optional == '\0')
1098 return FFEBAD_INTRINSIC_REF;
1099 break; /* Try next argspec. */
1103 = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
1105 if (anynum && commit)
1107 /* If we know dummy arg type, convert to that now. */
1109 if (abt == FFEINFO_basictypeNONE)
1110 abt = FFEINFO_basictypeINTEGER;
1111 if (akt == FFEINFO_kindtypeNONE)
1112 akt = FFEINFO_kindtypeINTEGER1;
1114 /* We have a known type, convert hollerith/typeless to it. */
1116 a = ffeexpr_convert (a, t, NULL,
1118 FFETARGET_charactersizeNONE,
1119 FFEEXPR_contextLET);
1120 ffebld_set_head (arg, a);
1122 else if ((c[colon + 1] == '*') && commit)
1124 /* This is where we promote types to the consensus
1125 type for the COL. Maybe this is where -fpedantic
1126 should issue a warning as well. */
1128 a = ffeexpr_convert (a, t, NULL,
1131 FFEEXPR_contextLET);
1132 ffebld_set_head (arg, a);
1135 arg = ffebld_trail (arg); /* Arg accepted, now move on. */
1137 if (optional == '*')
1138 continue; /* Go ahead and try another arg. */
1139 if (required == '\0')
1141 if ((required == 'n')
1142 || (required == '+'))
1147 else if (required == 'p')
1159 ffeintrin_check_any_ (ffebld arglist)
1163 for (; arglist != NULL; arglist = ffebld_trail (arglist))
1165 item = ffebld_head (arglist);
1167 && (ffebld_op (item) == FFEBLD_opANY))
1174 /* Compare a forced-to-uppercase name with a known-upper-case name. */
1177 upcasecmp_ (const char *name, const char *ucname)
1179 for ( ; *name != 0 && *ucname != 0; name++, ucname++)
1181 int i = TOUPPER(*name) - *ucname;
1187 return *name - *ucname;
1190 /* Compare name to intrinsic's name.
1191 The intrinsics table is sorted on the upper case entries; so first
1192 compare irrespective of case on the `uc' entry. If it matches,
1193 compare according to the setting of intrinsics case comparison mode. */
1196 ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
1198 const char *const uc = ((const struct _ffeintrin_name_ *) intrinsic)->name_uc;
1199 const char *const lc = ((const struct _ffeintrin_name_ *) intrinsic)->name_lc;
1200 const char *const ic = ((const struct _ffeintrin_name_ *) intrinsic)->name_ic;
1203 if ((i = upcasecmp_ (name, uc)) == 0)
1205 switch (ffe_case_intrin ())
1208 return strcmp(name, lc);
1209 case FFE_caseINITCAP:
1210 return strcmp(name, ic);
1219 /* Return basic type of intrinsic implementation, based on its
1220 run-time implementation *only*. (This is used only when
1221 the type of an intrinsic name is needed without having a
1222 list of arguments, i.e. an interface signature, such as when
1223 passing the intrinsic itself, or really the run-time-library
1224 function, as an argument.)
1226 If there's no eligible intrinsic implementation, there must be
1227 a bug somewhere else; no such reference should have been permitted
1228 to go this far. (Well, this might be wrong.) */
1231 ffeintrin_basictype (ffeintrinSpec spec)
1236 assert (spec < FFEINTRIN_spec);
1237 imp = ffeintrin_specs_[spec].implementation;
1238 assert (imp < FFEINTRIN_imp);
1241 gfrt = ffeintrin_imps_[imp].gfrt_f2c;
1243 gfrt = ffeintrin_imps_[imp].gfrt_gnu;
1245 assert (gfrt != FFECOM_gfrt);
1247 return ffecom_gfrt_basictype (gfrt);
1250 /* Return family to which specific intrinsic belongs. */
1253 ffeintrin_family (ffeintrinSpec spec)
1255 if (spec >= FFEINTRIN_spec)
1257 return ffeintrin_specs_[spec].family;
1260 /* Check and fill in info on func/subr ref node.
1262 ffebld expr; // FUNCREF or SUBRREF with no info (caller
1263 // gets it from the modified info structure).
1264 ffeinfo info; // Already filled in, will be overwritten.
1265 ffelexToken token; // Used for error message.
1266 ffeintrin_fulfill_generic (&expr, &info, token);
1268 Based on the generic id, figure out which specific procedure is meant and
1269 pick that one. Else return an error, a la _specific. */
1272 ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t)
1277 ffeintrinSpec spec = FFEINTRIN_specNONE;
1278 ffeinfoBasictype bt = FFEINFO_basictypeNONE;
1279 ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
1280 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
1282 ffeintrinSpec tspec;
1283 ffeintrinImp nimp = FFEINTRIN_impNONE;
1286 bool highly_specific = FALSE;
1289 op = ffebld_op (*expr);
1290 assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
1291 assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
1293 gen = ffebld_symter_generic (ffebld_left (*expr));
1294 assert (gen != FFEINTRIN_genNONE);
1296 imp = FFEINTRIN_impNONE;
1299 any = ffeintrin_check_any_ (ffebld_right (*expr));
1302 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1303 && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE)
1307 ffeintrinImp timp = ffeintrin_specs_[tspec].implementation;
1308 ffeinfoBasictype tbt;
1309 ffeinfoKindtype tkt;
1310 ffetargetCharacterSize tsz;
1311 ffeIntrinsicState state
1312 = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
1315 if (state == FFE_intrinsicstateDELETED)
1318 if (timp != FFEINTRIN_impNONE)
1320 if (!(ffeintrin_imps_[timp].control[0] == '-')
1321 != !(ffebld_op (*expr) == FFEBLD_opSUBRREF))
1322 continue; /* Form of reference must match form of specific. */
1325 if (state == FFE_intrinsicstateDISABLED)
1326 terror = FFEBAD_INTRINSIC_DISABLED;
1327 else if (timp == FFEINTRIN_impNONE)
1328 terror = FFEBAD_INTRINSIC_UNIMPL;
1331 terror = ffeintrin_check_ (timp, ffebld_op (*expr),
1332 ffebld_right (*expr),
1333 &tbt, &tkt, &tsz, NULL, t, FALSE);
1334 if (terror == FFEBAD)
1336 if (imp != FFEINTRIN_impNONE)
1338 ffebad_start (FFEBAD_INTRINSIC_AMBIG);
1339 ffebad_here (0, ffelex_token_where_line (t),
1340 ffelex_token_where_column (t));
1341 ffebad_string (ffeintrin_gens_[gen].name);
1342 ffebad_string (ffeintrin_specs_[spec].name);
1343 ffebad_string (ffeintrin_specs_[tspec].name);
1348 if (ffebld_symter_specific (ffebld_left (*expr))
1350 highly_specific = TRUE;
1359 else if (terror != FFEBAD)
1360 { /* This error has precedence over others. */
1361 if ((error == FFEBAD_INTRINSIC_DISABLED)
1362 || (error == FFEBAD_INTRINSIC_UNIMPL))
1367 if (error == FFEBAD)
1371 if (any || (imp == FFEINTRIN_impNONE))
1375 if (error == FFEBAD)
1376 error = FFEBAD_INTRINSIC_REF;
1377 ffebad_start (error);
1378 ffebad_here (0, ffelex_token_where_line (t),
1379 ffelex_token_where_column (t));
1380 ffebad_string (ffeintrin_gens_[gen].name);
1384 *expr = ffebld_new_any ();
1385 *info = ffeinfo_new_any ();
1389 if (!highly_specific && (nimp != FFEINTRIN_impNONE))
1391 fprintf (stderr, "lineno=%ld, gen=%s, imp=%s, timp=%s\n",
1393 ffeintrin_gens_[gen].name,
1394 ffeintrin_imps_[imp].name,
1395 ffeintrin_imps_[nimp].name);
1396 assert ("Ambiguous generic reference" == NULL);
1399 error = ffeintrin_check_ (imp, ffebld_op (*expr),
1400 ffebld_right (*expr),
1401 &bt, &kt, &sz, NULL, t, TRUE);
1402 assert (error == FFEBAD);
1403 *info = ffeinfo_new (bt,
1407 FFEINFO_whereFLEETING,
1409 symter = ffebld_left (*expr);
1410 ffebld_symter_set_specific (symter, spec);
1411 ffebld_symter_set_implementation (symter, imp);
1412 ffebld_set_info (symter,
1416 (bt == FFEINFO_basictypeNONE)
1417 ? FFEINFO_kindSUBROUTINE
1418 : FFEINFO_kindFUNCTION,
1419 FFEINFO_whereINTRINSIC,
1422 if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
1423 && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
1424 || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
1425 || ((sz != FFETARGET_charactersizeNONE)
1426 && (sz != ffesymbol_size (ffebld_symter (symter)))))))
1428 ffebad_start (FFEBAD_INTRINSIC_TYPE);
1429 ffebad_here (0, ffelex_token_where_line (t),
1430 ffelex_token_where_column (t));
1431 ffebad_string (ffeintrin_gens_[gen].name);
1434 if (ffeintrin_imps_[imp].y2kbad)
1436 ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
1437 ffebad_here (0, ffelex_token_where_line (t),
1438 ffelex_token_where_column (t));
1439 ffebad_string (ffeintrin_gens_[gen].name);
1445 /* Check and fill in info on func/subr ref node.
1447 ffebld expr; // FUNCREF or SUBRREF with no info (caller
1448 // gets it from the modified info structure).
1449 ffeinfo info; // Already filled in, will be overwritten.
1450 bool check_intrin; // May be omitted, else set TRUE if intrinsic needs checking.
1451 ffelexToken token; // Used for error message.
1452 ffeintrin_fulfill_specific (&expr, &info, &check_intrin, token);
1454 Based on the specific id, determine whether the arg list is valid
1455 (number, type, rank, and kind of args) and fill in the info structure
1456 accordingly. Currently don't rewrite the expression, but perhaps
1457 someday do so for constant collapsing, except when an error occurs,
1458 in which case it is overwritten with ANY and info is also overwritten
1462 ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
1463 bool *check_intrin, ffelexToken t)
1470 ffeinfoBasictype bt = FFEINFO_basictypeNONE;
1471 ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
1472 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
1473 ffeIntrinsicState state;
1478 op = ffebld_op (*expr);
1479 assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
1480 assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
1482 gen = ffebld_symter_generic (ffebld_left (*expr));
1483 spec = ffebld_symter_specific (ffebld_left (*expr));
1484 assert (spec != FFEINTRIN_specNONE);
1486 if (gen != FFEINTRIN_genNONE)
1487 name = ffeintrin_gens_[gen].name;
1489 name = ffeintrin_specs_[spec].name;
1491 state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1493 imp = ffeintrin_specs_[spec].implementation;
1494 if (check_intrin != NULL)
1495 *check_intrin = FALSE;
1497 any = ffeintrin_check_any_ (ffebld_right (*expr));
1499 if (state == FFE_intrinsicstateDISABLED)
1500 error = FFEBAD_INTRINSIC_DISABLED;
1501 else if (imp == FFEINTRIN_impNONE)
1502 error = FFEBAD_INTRINSIC_UNIMPL;
1505 error = ffeintrin_check_ (imp, ffebld_op (*expr),
1506 ffebld_right (*expr),
1507 &bt, &kt, &sz, check_intrin, t, TRUE);
1510 error = FFEBAD; /* Not really needed, but quiet -Wuninitialized. */
1512 if (any || (error != FFEBAD))
1517 ffebad_start (error);
1518 ffebad_here (0, ffelex_token_where_line (t),
1519 ffelex_token_where_column (t));
1520 ffebad_string (name);
1524 *expr = ffebld_new_any ();
1525 *info = ffeinfo_new_any ();
1529 *info = ffeinfo_new (bt,
1533 FFEINFO_whereFLEETING,
1535 symter = ffebld_left (*expr);
1536 ffebld_set_info (symter,
1540 (bt == FFEINFO_basictypeNONE)
1541 ? FFEINFO_kindSUBROUTINE
1542 : FFEINFO_kindFUNCTION,
1543 FFEINFO_whereINTRINSIC,
1546 if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
1547 && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
1548 || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
1549 || (sz != ffesymbol_size (ffebld_symter (symter))))))
1551 ffebad_start (FFEBAD_INTRINSIC_TYPE);
1552 ffebad_here (0, ffelex_token_where_line (t),
1553 ffelex_token_where_column (t));
1554 ffebad_string (name);
1557 if (ffeintrin_imps_[imp].y2kbad)
1559 ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
1560 ffebad_here (0, ffelex_token_where_line (t),
1561 ffelex_token_where_column (t));
1562 ffebad_string (name);
1568 /* Return run-time index of intrinsic implementation as direct call. */
1571 ffeintrin_gfrt_direct (ffeintrinImp imp)
1573 assert (imp < FFEINTRIN_imp);
1575 return ffeintrin_imps_[imp].gfrt_direct;
1578 /* Return run-time index of intrinsic implementation as actual argument. */
1581 ffeintrin_gfrt_indirect (ffeintrinImp imp)
1583 assert (imp < FFEINTRIN_imp);
1585 if (! ffe_is_f2c ())
1586 return ffeintrin_imps_[imp].gfrt_gnu;
1587 return ffeintrin_imps_[imp].gfrt_f2c;
1599 if (!ffe_is_do_internal_checks ())
1602 assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_));
1603 assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_));
1604 assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_));
1606 for (i = 1; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
1607 { /* Make sure binary-searched list is in alpha
1609 if (strcmp (ffeintrin_names_[i - 1].name_uc,
1610 ffeintrin_names_[i].name_uc) >= 0)
1611 assert ("name list out of order" == NULL);
1614 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
1616 assert ((ffeintrin_names_[i].generic == FFEINTRIN_genNONE)
1617 || (ffeintrin_names_[i].specific == FFEINTRIN_specNONE));
1619 p1 = ffeintrin_names_[i].name_uc;
1620 p2 = ffeintrin_names_[i].name_lc;
1621 p3 = ffeintrin_names_[i].name_ic;
1622 for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3)
1624 if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
1626 if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2)
1627 || (*p1 != TOUPPER (*p2))
1628 || ((*p3 != *p1) && (*p3 != *p2)))
1631 assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
1634 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i)
1636 const char *c = ffeintrin_imps_[i].control;
1652 fprintf (stderr, "%s: bad return-base-type\n",
1653 ffeintrin_imps_[i].name);
1662 fprintf (stderr, "%s: bad return-kind-type\n",
1663 ffeintrin_imps_[i].name);
1672 fprintf (stderr, "%s: bad return-modifier\n",
1673 ffeintrin_imps_[i].name);
1678 if ((c[colon] != ':') || (c[colon + 2] != ':'))
1680 fprintf (stderr, "%s: bad control\n",
1681 ffeintrin_imps_[i].name);
1684 if ((c[colon + 1] != '-')
1685 && (c[colon + 1] != '*')
1686 && (! ISDIGIT (c[colon + 1])))
1688 fprintf (stderr, "%s: bad COL-spec\n",
1689 ffeintrin_imps_[i].name);
1693 while (c[0] != '\0')
1695 while ((c[0] != '=')
1701 fprintf (stderr, "%s: bad keyword\n",
1702 ffeintrin_imps_[i].name);
1725 fprintf (stderr, "%s: bad arg-base-type\n",
1726 ffeintrin_imps_[i].name);
1734 fprintf (stderr, "%s: bad arg-kind-type\n",
1735 ffeintrin_imps_[i].name);
1740 if ((! ISDIGIT (c[4]))
1742 && (++c, ! ISDIGIT (c[4])
1745 fprintf (stderr, "%s: bad arg-len\n",
1746 ffeintrin_imps_[i].name);
1753 if ((! ISDIGIT (c[4]))
1755 && (++c, ! ISDIGIT (c[4])
1758 fprintf (stderr, "%s: bad arg-rank\n",
1759 ffeintrin_imps_[i].name);
1764 else if ((c[3] == '&')
1779 fprintf (stderr, "%s: bad arg-list\n",
1780 ffeintrin_imps_[i].name);
1787 /* Determine whether intrinsic is okay as an actual argument. */
1790 ffeintrin_is_actualarg (ffeintrinSpec spec)
1792 ffeIntrinsicState state;
1794 if (spec >= FFEINTRIN_spec)
1797 state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1799 return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
1801 ? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
1803 : (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
1805 && ((state == FFE_intrinsicstateENABLED)
1806 || (state == FFE_intrinsicstateHIDDEN));
1809 /* Determine if name is intrinsic, return info.
1811 const char *name; // C-string name of possible intrinsic.
1812 ffelexToken t; // NULL if no diagnostic to be given.
1813 bool explicit; // TRUE if INTRINSIC name.
1814 ffeintrinGen gen; // (TRUE only) Generic id of intrinsic.
1815 ffeintrinSpec spec; // (TRUE only) Specific id of intrinsic.
1816 ffeintrinImp imp; // (TRUE only) Implementation id of intrinsic.
1817 if (ffeintrin_is_intrinsic (name, t, explicit,
1819 // is an intrinsic, use gen, spec, imp, and
1820 // kind accordingly. */
1823 ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
1824 ffeintrinGen *xgen, ffeintrinSpec *xspec,
1827 struct _ffeintrin_name_ *intrinsic;
1831 ffeIntrinsicState state;
1832 bool disabled = FALSE;
1833 bool unimpl = FALSE;
1835 intrinsic = bsearch (name, &ffeintrin_names_[0],
1836 ARRAY_SIZE (ffeintrin_names_),
1837 sizeof (struct _ffeintrin_name_),
1838 (void *) ffeintrin_cmp_name_);
1840 if (intrinsic == NULL)
1843 gen = intrinsic->generic;
1844 spec = intrinsic->specific;
1845 imp = ffeintrin_specs_[spec].implementation;
1847 /* Generic is okay only if at least one of its specifics is okay. */
1849 if (gen != FFEINTRIN_genNONE)
1852 ffeintrinSpec tspec;
1855 name = ffeintrin_gens_[gen].name;
1858 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1860 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1863 state = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
1865 if (state == FFE_intrinsicstateDELETED)
1868 if (state == FFE_intrinsicstateDISABLED)
1874 if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE)
1880 if ((state == FFE_intrinsicstateENABLED)
1882 && (state == FFE_intrinsicstateHIDDEN)))
1889 gen = FFEINTRIN_genNONE;
1892 /* Specific is okay only if not: unimplemented, disabled, deleted, or
1893 hidden and not explicit. */
1895 if (spec != FFEINTRIN_specNONE)
1897 if (gen != FFEINTRIN_genNONE)
1898 name = ffeintrin_gens_[gen].name;
1900 name = ffeintrin_specs_[spec].name;
1902 if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family))
1903 == FFE_intrinsicstateDELETED)
1905 && (state == FFE_intrinsicstateHIDDEN)))
1906 spec = FFEINTRIN_specNONE;
1907 else if (state == FFE_intrinsicstateDISABLED)
1910 spec = FFEINTRIN_specNONE;
1912 else if (imp == FFEINTRIN_impNONE)
1915 spec = FFEINTRIN_specNONE;
1919 /* If neither is okay, not an intrinsic. */
1921 if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
1923 /* Here is where we produce a diagnostic about a reference to a
1924 disabled or unimplemented intrinsic, if the diagnostic is desired. */
1926 if ((disabled || unimpl)
1929 ffebad_start (disabled
1930 ? FFEBAD_INTRINSIC_DISABLED
1931 : FFEBAD_INTRINSIC_UNIMPLW);
1932 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1933 ffebad_string (name);
1940 /* Determine whether intrinsic is function or subroutine. If no specific
1941 id, scan list of possible specifics for generic to get consensus. If
1942 not unanimous, or clear from the context, return NONE. */
1944 if (spec == FFEINTRIN_specNONE)
1947 ffeintrinSpec tspec;
1949 bool at_least_one_ok = FALSE;
1952 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1954 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1957 if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family))
1958 == FFE_intrinsicstateDELETED)
1959 || (state == FFE_intrinsicstateDISABLED))
1962 if ((timp = ffeintrin_specs_[tspec].implementation)
1963 == FFEINTRIN_impNONE)
1966 at_least_one_ok = TRUE;
1970 if (!at_least_one_ok)
1972 *xgen = FFEINTRIN_genNONE;
1973 *xspec = FFEINTRIN_specNONE;
1974 *ximp = FFEINTRIN_impNONE;
1985 /* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90). */
1988 ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec)
1990 if (spec == FFEINTRIN_specNONE)
1992 if (gen == FFEINTRIN_genNONE)
1995 spec = ffeintrin_gens_[gen].specs[0];
1996 if (spec == FFEINTRIN_specNONE)
2000 if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77)
2002 && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90)
2003 || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL)
2004 || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC))))
2009 /* Return kind type of intrinsic implementation. See ffeintrin_basictype,
2013 ffeintrin_kindtype (ffeintrinSpec spec)
2018 assert (spec < FFEINTRIN_spec);
2019 imp = ffeintrin_specs_[spec].implementation;
2020 assert (imp < FFEINTRIN_imp);
2023 gfrt = ffeintrin_imps_[imp].gfrt_f2c;
2025 gfrt = ffeintrin_imps_[imp].gfrt_gnu;
2027 assert (gfrt != FFECOM_gfrt);
2029 return ffecom_gfrt_kindtype (gfrt);
2032 /* Return name of generic intrinsic. */
2035 ffeintrin_name_generic (ffeintrinGen gen)
2037 assert (gen < FFEINTRIN_gen);
2038 return ffeintrin_gens_[gen].name;
2041 /* Return name of intrinsic implementation. */
2044 ffeintrin_name_implementation (ffeintrinImp imp)
2046 assert (imp < FFEINTRIN_imp);
2047 return ffeintrin_imps_[imp].name;
2050 /* Return external/internal name of specific intrinsic. */
2053 ffeintrin_name_specific (ffeintrinSpec spec)
2055 assert (spec < FFEINTRIN_spec);
2056 return ffeintrin_specs_[spec].name;
2059 /* Return state of family. */
2062 ffeintrin_state_family (ffeintrinFamily family)
2064 ffeIntrinsicState state;
2068 case FFEINTRIN_familyNONE:
2069 return FFE_intrinsicstateDELETED;
2071 case FFEINTRIN_familyF77:
2072 return FFE_intrinsicstateENABLED;
2074 case FFEINTRIN_familyASC:
2075 state = ffe_intrinsic_state_f2c ();
2076 state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2079 case FFEINTRIN_familyMIL:
2080 state = ffe_intrinsic_state_vxt ();
2081 state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2082 state = ffe_state_max (state, ffe_intrinsic_state_mil ());
2085 case FFEINTRIN_familyGNU:
2086 state = ffe_intrinsic_state_gnu ();
2089 case FFEINTRIN_familyF90:
2090 state = ffe_intrinsic_state_f90 ();
2093 case FFEINTRIN_familyVXT:
2094 state = ffe_intrinsic_state_vxt ();
2097 case FFEINTRIN_familyFVZ:
2098 state = ffe_intrinsic_state_f2c ();
2099 state = ffe_state_max (state, ffe_intrinsic_state_vxt ());
2102 case FFEINTRIN_familyF2C:
2103 state = ffe_intrinsic_state_f2c ();
2106 case FFEINTRIN_familyF2U:
2107 state = ffe_intrinsic_state_unix ();
2110 case FFEINTRIN_familyBADU77:
2111 state = ffe_intrinsic_state_badu77 ();
2115 assert ("bad family" == NULL);
2116 return FFE_intrinsicstateDELETED;