1 /* intrin.c -- Recognize references to intrinsics
2 Copyright (C) 1995-1998 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_
39 ffeintrinSpec specific
;
42 struct _ffeintrin_gen_
44 const char *name
; /* Name as seen in program. */
45 ffeintrinSpec specs
[2];
48 struct _ffeintrin_spec_
50 const char *name
; /* Uppercase name as seen in source code,
51 lowercase if no source name, "none" if no
52 name at all (NONE case). */
53 bool is_actualarg
; /* Ok to pass as actual arg if -pedantic. */
54 ffeintrinFamily family
;
55 ffeintrinImp implementation
;
58 struct _ffeintrin_imp_
60 const char *name
; /* Name of implementation. */
61 #if FFECOM_targetCURRENT == FFECOM_targetGCC
62 ffecomGfrt gfrt_direct
; /* library routine, direct-callable form. */
63 ffecomGfrt gfrt_f2c
; /* library routine, f2c-callable form. */
64 ffecomGfrt gfrt_gnu
; /* library routine, gnu-callable form. */
65 #endif /* FFECOM_targetCURRENT == FFECOM_targetGCC */
70 static ffebad
ffeintrin_check_ (ffeintrinImp imp
, ffebldOp op
,
71 ffebld args
, ffeinfoBasictype
*xbt
,
73 ffetargetCharacterSize
*xsz
,
77 static bool ffeintrin_check_any_ (ffebld arglist
);
78 static int ffeintrin_cmp_name_ (const void *name
, const void *intrinsic
);
80 static struct _ffeintrin_name_ ffeintrin_names_
[]
83 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
84 { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
85 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
86 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
87 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
88 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
97 static struct _ffeintrin_gen_ ffeintrin_gens_
[]
100 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
101 #define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
102 { NAME, { SPEC1, SPEC2, }, },
103 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
104 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
105 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
106 #include "intrin.def"
114 static struct _ffeintrin_imp_ ffeintrin_imps_
[]
117 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
118 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
119 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
120 #if FFECOM_targetCURRENT == FFECOM_targetGCC
121 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
122 { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
123 FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE },
124 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
125 { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
126 FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD },
127 #elif FFECOM_targetCURRENT == FFECOM_targetFFE
128 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
129 { NAME, CONTROL, FALSE },
130 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
131 { NAME, CONTROL, Y2KBAD },
135 #include "intrin.def"
143 static struct _ffeintrin_spec_ ffeintrin_specs_
[]
146 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
147 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
148 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
149 { NAME, CALLABLE, FAMILY, IMP, },
150 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
151 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
152 #include "intrin.def"
161 ffeintrin_check_ (ffeintrinImp imp
, ffebldOp op
,
162 ffebld args
, ffeinfoBasictype
*xbt
,
163 ffeinfoKindtype
*xkt
,
164 ffetargetCharacterSize
*xsz
,
169 const char *c
= ffeintrin_imps_
[imp
].control
;
170 bool subr
= (c
[0] == '-');
175 ffetargetCharacterSize sz
= FFETARGET_charactersizeNONE
;
176 ffeinfoKindtype firstarg_kt
;
178 ffeinfoBasictype col_bt
= FFEINFO_basictypeNONE
;
179 ffeinfoKindtype col_kt
= FFEINFO_kindtypeNONE
;
180 int colon
= (c
[2] == ':') ? 2 : 3;
183 /* Check procedure type (function vs. subroutine) against
186 if (op
== FFEBLD_opSUBRREF
)
189 return FFEBAD_INTRINSIC_IS_FUNC
;
191 else if (op
== FFEBLD_opFUNCREF
)
194 return FFEBAD_INTRINSIC_IS_SUBR
;
197 return FFEBAD_INTRINSIC_REF
;
199 /* Check the arglist for validity. */
202 && (ffebld_head (args
) != NULL
))
203 firstarg_kt
= ffeinfo_kindtype (ffebld_info (ffebld_head (args
)));
205 firstarg_kt
= FFEINFO_kindtype
;
207 for (argc
= &c
[colon
+ 3],
212 char optional
= '\0';
213 char required
= '\0';
219 bool lastarg_complex
= FALSE
;
221 /* We don't do anything with keywords yet. */
224 } while (*(++argc
) != '=');
230 optional
= *(argc
++);
234 required
= *(argc
++);
239 length
= *++argc
- '0';
241 length
= 10 * length
+ (*(argc
++) - '0');
248 elements
= *++argc
- '0';
250 elements
= 10 * elements
+ (*(argc
++) - '0');
253 else if (*argc
== '&')
268 /* Break out of this loop only when current arg spec completely
277 ffeinfoBasictype abt
= FFEINFO_basictypeNONE
;
278 ffeinfoKindtype akt
= FFEINFO_kindtypeNONE
;
281 || (ffebld_head (arg
) == NULL
))
283 if (required
!= '\0')
284 return FFEBAD_INTRINSIC_TOOFEW
;
285 if (optional
== '\0')
286 return FFEBAD_INTRINSIC_TOOFEW
;
288 arg
= ffebld_trail (arg
);
289 break; /* Try next argspec. */
292 a
= ffebld_head (arg
);
294 anynum
= (ffeinfo_basictype (i
) == FFEINFO_basictypeHOLLERITH
)
295 || (ffeinfo_basictype (i
) == FFEINFO_basictypeTYPELESS
);
297 /* See how well the arg matches up to the spec. */
302 okay
= (ffeinfo_basictype (i
) == FFEINFO_basictypeCHARACTER
)
304 || (ffeinfo_size (i
) == (ffetargetCharacterSize
) length
));
309 || (ffeinfo_basictype (i
) == FFEINFO_basictypeCOMPLEX
);
310 abt
= FFEINFO_basictypeCOMPLEX
;
315 || (ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
);
316 abt
= FFEINFO_basictypeINTEGER
;
321 || (ffeinfo_basictype (i
) == FFEINFO_basictypeLOGICAL
);
322 abt
= FFEINFO_basictypeLOGICAL
;
327 || (ffeinfo_basictype (i
) == FFEINFO_basictypeREAL
);
328 abt
= FFEINFO_basictypeREAL
;
333 || (ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
334 || (ffeinfo_basictype (i
) == FFEINFO_basictypeLOGICAL
);
339 || (ffeinfo_basictype (i
) == FFEINFO_basictypeCOMPLEX
)
340 || (ffeinfo_basictype (i
) == FFEINFO_basictypeREAL
);
345 || (ffeinfo_basictype (i
) == FFEINFO_basictypeCOMPLEX
)
346 || (ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
347 || (ffeinfo_basictype (i
) == FFEINFO_basictypeREAL
);
352 || (ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
353 || (ffeinfo_basictype (i
) == FFEINFO_basictypeREAL
);
357 okay
= ((ffebld_op (a
) == FFEBLD_opLABTER
)
358 || (ffebld_op (a
) == FFEBLD_opLABTOK
));
364 okay
= (((((ffeinfo_basictype (i
) == FFEINFO_basictypeNONE
)
365 && (ffeinfo_kindtype (i
) == FFEINFO_kindtypeNONE
)
366 && (ffeinfo_kind (i
) == FFEINFO_kindSUBROUTINE
))
367 || ((ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
368 && (ffeinfo_kindtype (i
) == FFEINFO_kindtypeINTEGERDEFAULT
)
369 && (ffeinfo_kind (i
) == FFEINFO_kindFUNCTION
))
370 || (ffeinfo_kind (i
) == FFEINFO_kindNONE
))
371 && ((ffeinfo_where (i
) == FFEINFO_whereDUMMY
)
372 || (ffeinfo_where (i
) == FFEINFO_whereGLOBAL
)))
373 || ((ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
374 && (ffeinfo_kind (i
) == FFEINFO_kindENTITY
)));
387 case '1': case '2': case '3': case '4': case '5':
388 case '6': case '7': case '8': case '9':
390 if ((ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
391 || (ffeinfo_basictype (i
) == FFEINFO_basictypeLOGICAL
))
394 { /* Translate to internal kinds for now! */
415 akt
= ffecom_pointer_kind ();
419 okay
&= anynum
|| (ffeinfo_kindtype (i
) == akt
);
423 okay
&= anynum
|| (ffeinfo_kindtype (i
) == firstarg_kt
);
424 akt
= (firstarg_kt
== FFEINFO_kindtype
) ? FFEINFO_kindtypeNONE
441 if (ffeinfo_rank (i
) != 0)
446 if ((ffeinfo_rank (i
) != 1)
447 || (ffebld_op (a
) != FFEBLD_opSYMTER
)
448 || ((b
= ffesymbol_arraysize (ffebld_symter (a
))) == NULL
)
449 || (ffebld_op (b
) != FFEBLD_opCONTER
)
450 || (ffeinfo_basictype (ffebld_info (b
)) != FFEINFO_basictypeINTEGER
)
451 || (ffeinfo_kindtype (ffebld_info (b
)) != FFEINFO_kindtypeINTEGERDEFAULT
)
452 || (ffebld_constant_integer1 (ffebld_conter (b
)) != elements
))
460 if ((ffeinfo_kind (i
) != FFEINFO_kindENTITY
)
461 || ((ffebld_op (a
) != FFEBLD_opSYMTER
)
462 && (ffebld_op (a
) != FFEBLD_opSUBSTR
)
463 && (ffebld_op (a
) != FFEBLD_opARRAYREF
)))
469 if ((ffeinfo_kind (i
) != FFEINFO_kindENTITY
)
470 || ((ffebld_op (a
) != FFEBLD_opSYMTER
)
471 && (ffebld_op (a
) != FFEBLD_opARRAYREF
)
472 && (ffebld_op (a
) != FFEBLD_opSUBSTR
)))
481 if (ffeinfo_kind (i
) != FFEINFO_kindENTITY
)
486 if ((optional
== '!')
492 /* If it wasn't optional, it's an error,
493 else maybe it could match a later argspec. */
494 if (optional
== '\0')
495 return FFEBAD_INTRINSIC_REF
;
496 break; /* Try next argspec. */
500 = (ffeinfo_basictype (i
) == FFEINFO_basictypeCOMPLEX
);
504 /* If we know dummy arg type, convert to that now. */
506 if ((abt
!= FFEINFO_basictypeNONE
)
507 && (akt
!= FFEINFO_kindtypeNONE
)
510 /* We have a known type, convert hollerith/typeless
513 a
= ffeexpr_convert (a
, t
, NULL
,
515 FFETARGET_charactersizeNONE
,
517 ffebld_set_head (arg
, a
);
521 arg
= ffebld_trail (arg
); /* Arg accepted, now move on. */
524 continue; /* Go ahead and try another arg. */
525 if (required
== '\0')
527 if ((required
== 'n')
528 || (required
== '+'))
533 else if (required
== 'p')
539 return FFEBAD_INTRINSIC_TOOMANY
;
541 /* Set up the initial type for the return value of the function. */
547 bt
= FFEINFO_basictypeCHARACTER
;
548 sz
= (c
[2] == '*') ? FFETARGET_charactersizeNONE
: 1;
552 bt
= FFEINFO_basictypeCOMPLEX
;
556 bt
= FFEINFO_basictypeINTEGER
;
560 bt
= FFEINFO_basictypeLOGICAL
;
564 bt
= FFEINFO_basictypeREAL
;
575 bt
= FFEINFO_basictypeNONE
;
581 case '1': case '2': case '3': case '4': case '5':
582 case '6': case '7': case '8': case '9':
584 if ((bt
== FFEINFO_basictypeINTEGER
)
585 || (bt
== FFEINFO_basictypeLOGICAL
))
588 { /* Translate to internal kinds for now! */
609 kt
= ffecom_pointer_kind ();
626 kt
= FFEINFO_kindtypeNONE
;
630 /* Determine collective type of COL, if there is one. */
632 if (need_col
|| c
[colon
+ 1] != '-')
635 bool have_anynum
= FALSE
;
639 arg
= (c
[colon
+ 1] == '*') ? ffebld_trail (arg
) : NULL
)
641 ffebld a
= ffebld_head (arg
);
649 anynum
= (ffeinfo_basictype (i
) == FFEINFO_basictypeHOLLERITH
)
650 || (ffeinfo_basictype (i
) == FFEINFO_basictypeTYPELESS
);
657 if ((col_bt
== FFEINFO_basictypeNONE
)
658 && (col_kt
== FFEINFO_kindtypeNONE
))
660 col_bt
= ffeinfo_basictype (i
);
661 col_kt
= ffeinfo_kindtype (i
);
665 ffeexpr_type_combine (&col_bt
, &col_kt
,
667 ffeinfo_basictype (i
),
668 ffeinfo_kindtype (i
),
670 if ((col_bt
== FFEINFO_basictypeNONE
)
671 || (col_kt
== FFEINFO_kindtypeNONE
))
672 return FFEBAD_INTRINSIC_REF
;
677 && ((col_bt
== FFEINFO_basictypeNONE
)
678 || (col_kt
== FFEINFO_kindtypeNONE
)))
680 /* No type, but have hollerith/typeless. Use type of return
681 value to determine type of COL. */
686 return FFEBAD_INTRINSIC_REF
;
691 if ((col_bt
!= FFEINFO_basictypeNONE
)
692 && (col_bt
!= FFEINFO_basictypeINTEGER
))
693 return FFEBAD_INTRINSIC_REF
;
699 col_bt
= FFEINFO_basictypeINTEGER
;
700 col_kt
= FFEINFO_kindtypeINTEGER1
;
704 if ((col_bt
!= FFEINFO_basictypeNONE
)
705 && (col_bt
!= FFEINFO_basictypeCOMPLEX
))
706 return FFEBAD_INTRINSIC_REF
;
707 col_bt
= FFEINFO_basictypeCOMPLEX
;
708 col_kt
= FFEINFO_kindtypeREAL1
;
712 if ((col_bt
!= FFEINFO_basictypeNONE
)
713 && (col_bt
!= FFEINFO_basictypeREAL
))
714 return FFEBAD_INTRINSIC_REF
;
717 col_bt
= FFEINFO_basictypeREAL
;
718 col_kt
= FFEINFO_kindtypeREAL1
;
726 okay
= (col_bt
== FFEINFO_basictypeINTEGER
)
727 || (col_bt
== FFEINFO_basictypeLOGICAL
);
733 okay
= (col_bt
== FFEINFO_basictypeCOMPLEX
)
734 || (col_bt
== FFEINFO_basictypeREAL
);
740 okay
= (col_bt
== FFEINFO_basictypeCOMPLEX
)
741 || (col_bt
== FFEINFO_basictypeINTEGER
)
742 || (col_bt
== FFEINFO_basictypeREAL
);
748 okay
= (col_bt
== FFEINFO_basictypeINTEGER
)
749 || (col_bt
== FFEINFO_basictypeREAL
)
750 || (col_bt
== FFEINFO_basictypeCOMPLEX
);
752 bt
= ((col_bt
!= FFEINFO_basictypeCOMPLEX
) ? col_bt
753 : FFEINFO_basictypeREAL
);
765 if (col_bt
== FFEINFO_basictypeCOMPLEX
)
767 if (col_kt
!= FFEINFO_kindtypeREALDEFAULT
)
768 *check_intrin
= TRUE
;
776 return FFEBAD_INTRINSIC_REF
;
779 /* Now, convert args in the arglist to the final type of the COL. */
781 for (argno
= 0, argc
= &c
[colon
+ 3],
786 char optional
= '\0';
787 char required
= '\0';
793 bool lastarg_complex
= FALSE
;
795 /* We don't do anything with keywords yet. */
798 } while (*(++argc
) != '=');
804 optional
= *(argc
++);
808 required
= *(argc
++);
813 length
= *++argc
- '0';
815 length
= 10 * length
+ (*(argc
++) - '0');
822 elements
= *++argc
- '0';
824 elements
= 10 * elements
+ (*(argc
++) - '0');
827 else if (*argc
== '&')
842 /* Break out of this loop only when current arg spec completely
851 ffeinfoBasictype abt
= FFEINFO_basictypeNONE
;
852 ffeinfoKindtype akt
= FFEINFO_kindtypeNONE
;
855 || (ffebld_head (arg
) == NULL
))
858 arg
= ffebld_trail (arg
);
859 break; /* Try next argspec. */
862 a
= ffebld_head (arg
);
864 anynum
= (ffeinfo_basictype (i
) == FFEINFO_basictypeHOLLERITH
)
865 || (ffeinfo_basictype (i
) == FFEINFO_basictypeTYPELESS
);
867 /* Determine what the default type for anynum would be. */
871 switch (c
[colon
+ 1])
875 case '0': case '1': case '2': case '3': case '4':
876 case '5': case '6': case '7': case '8': case '9':
877 if (argno
!= (c
[colon
+ 1] - '0'))
886 /* Again, match arg up to the spec. We go through all of
887 this again to properly follow the contour of optional
888 arguments. Probably this level of flexibility is not
889 needed, perhaps it's even downright naughty. */
894 okay
= (ffeinfo_basictype (i
) == FFEINFO_basictypeCHARACTER
)
896 || (ffeinfo_size (i
) == (ffetargetCharacterSize
) length
));
901 || (ffeinfo_basictype (i
) == FFEINFO_basictypeCOMPLEX
);
902 abt
= FFEINFO_basictypeCOMPLEX
;
907 || (ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
);
908 abt
= FFEINFO_basictypeINTEGER
;
913 || (ffeinfo_basictype (i
) == FFEINFO_basictypeLOGICAL
);
914 abt
= FFEINFO_basictypeLOGICAL
;
919 || (ffeinfo_basictype (i
) == FFEINFO_basictypeREAL
);
920 abt
= FFEINFO_basictypeREAL
;
925 || (ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
926 || (ffeinfo_basictype (i
) == FFEINFO_basictypeLOGICAL
);
931 || (ffeinfo_basictype (i
) == FFEINFO_basictypeCOMPLEX
)
932 || (ffeinfo_basictype (i
) == FFEINFO_basictypeREAL
);
937 || (ffeinfo_basictype (i
) == FFEINFO_basictypeCOMPLEX
)
938 || (ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
939 || (ffeinfo_basictype (i
) == FFEINFO_basictypeREAL
);
944 || (ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
945 || (ffeinfo_basictype (i
) == FFEINFO_basictypeREAL
);
949 okay
= ((ffebld_op (a
) == FFEBLD_opLABTER
)
950 || (ffebld_op (a
) == FFEBLD_opLABTOK
));
956 okay
= (((((ffeinfo_basictype (i
) == FFEINFO_basictypeNONE
)
957 && (ffeinfo_kindtype (i
) == FFEINFO_kindtypeNONE
)
958 && (ffeinfo_kind (i
) == FFEINFO_kindSUBROUTINE
))
959 || ((ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
960 && (ffeinfo_kindtype (i
) == FFEINFO_kindtypeINTEGERDEFAULT
)
961 && (ffeinfo_kind (i
) == FFEINFO_kindFUNCTION
))
962 || (ffeinfo_kind (i
) == FFEINFO_kindNONE
))
963 && ((ffeinfo_where (i
) == FFEINFO_whereDUMMY
)
964 || (ffeinfo_where (i
) == FFEINFO_whereGLOBAL
)))
965 || ((ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
966 && (ffeinfo_kind (i
) == FFEINFO_kindENTITY
)));
979 case '1': case '2': case '3': case '4': case '5':
980 case '6': case '7': case '8': case '9':
982 if ((ffeinfo_basictype (i
) == FFEINFO_basictypeINTEGER
)
983 || (ffeinfo_basictype (i
) == FFEINFO_basictypeLOGICAL
))
986 { /* Translate to internal kinds for now! */
1007 akt
= ffecom_pointer_kind ();
1011 okay
&= anynum
|| (ffeinfo_kindtype (i
) == akt
);
1015 okay
&= anynum
|| (ffeinfo_kindtype (i
) == firstarg_kt
);
1016 akt
= (firstarg_kt
== FFEINFO_kindtype
) ? FFEINFO_kindtypeNONE
1033 if (ffeinfo_rank (i
) != 0)
1038 if ((ffeinfo_rank (i
) != 1)
1039 || (ffebld_op (a
) != FFEBLD_opSYMTER
)
1040 || ((b
= ffesymbol_arraysize (ffebld_symter (a
))) == NULL
)
1041 || (ffebld_op (b
) != FFEBLD_opCONTER
)
1042 || (ffeinfo_basictype (ffebld_info (b
)) != FFEINFO_basictypeINTEGER
)
1043 || (ffeinfo_kindtype (ffebld_info (b
)) != FFEINFO_kindtypeINTEGERDEFAULT
)
1044 || (ffebld_constant_integer1 (ffebld_conter (b
)) != elements
))
1052 if ((ffeinfo_kind (i
) != FFEINFO_kindENTITY
)
1053 || ((ffebld_op (a
) != FFEBLD_opSYMTER
)
1054 && (ffebld_op (a
) != FFEBLD_opSUBSTR
)
1055 && (ffebld_op (a
) != FFEBLD_opARRAYREF
)))
1061 if ((ffeinfo_kind (i
) != FFEINFO_kindENTITY
)
1062 || ((ffebld_op (a
) != FFEBLD_opSYMTER
)
1063 && (ffebld_op (a
) != FFEBLD_opARRAYREF
)
1064 && (ffebld_op (a
) != FFEBLD_opSUBSTR
)))
1073 if (ffeinfo_kind (i
) != FFEINFO_kindENTITY
)
1078 if ((optional
== '!')
1084 /* If it wasn't optional, it's an error,
1085 else maybe it could match a later argspec. */
1086 if (optional
== '\0')
1087 return FFEBAD_INTRINSIC_REF
;
1088 break; /* Try next argspec. */
1092 = (ffeinfo_basictype (i
) == FFEINFO_basictypeCOMPLEX
);
1094 if (anynum
&& commit
)
1096 /* If we know dummy arg type, convert to that now. */
1098 if (abt
== FFEINFO_basictypeNONE
)
1099 abt
= FFEINFO_basictypeINTEGER
;
1100 if (akt
== FFEINFO_kindtypeNONE
)
1101 akt
= FFEINFO_kindtypeINTEGER1
;
1103 /* We have a known type, convert hollerith/typeless to it. */
1105 a
= ffeexpr_convert (a
, t
, NULL
,
1107 FFETARGET_charactersizeNONE
,
1108 FFEEXPR_contextLET
);
1109 ffebld_set_head (arg
, a
);
1111 else if ((c
[colon
+ 1] == '*') && commit
)
1113 /* This is where we promote types to the consensus
1114 type for the COL. Maybe this is where -fpedantic
1115 should issue a warning as well. */
1117 a
= ffeexpr_convert (a
, t
, NULL
,
1120 FFEEXPR_contextLET
);
1121 ffebld_set_head (arg
, a
);
1124 arg
= ffebld_trail (arg
); /* Arg accepted, now move on. */
1126 if (optional
== '*')
1127 continue; /* Go ahead and try another arg. */
1128 if (required
== '\0')
1130 if ((required
== 'n')
1131 || (required
== '+'))
1136 else if (required
== 'p')
1148 ffeintrin_check_any_ (ffebld arglist
)
1152 for (; arglist
!= NULL
; arglist
= ffebld_trail (arglist
))
1154 item
= ffebld_head (arglist
);
1156 && (ffebld_op (item
) == FFEBLD_opANY
))
1163 /* Compare name to intrinsic's name. Uses strcmp on arguments' names. */
1166 ffeintrin_cmp_name_ (const void *name
, const void *intrinsic
)
1168 const char *uc
= ((const struct _ffeintrin_name_
*) intrinsic
)->name_uc
;
1169 const char *lc
= ((const struct _ffeintrin_name_
*) intrinsic
)->name_lc
;
1170 const char *ic
= ((const struct _ffeintrin_name_
*) intrinsic
)->name_ic
;
1172 return ffesrc_strcmp_2c (ffe_case_intrin (), name
, uc
, lc
, ic
);
1175 /* Return basic type of intrinsic implementation, based on its
1176 run-time implementation *only*. (This is used only when
1177 the type of an intrinsic name is needed without having a
1178 list of arguments, i.e. an interface signature, such as when
1179 passing the intrinsic itself, or really the run-time-library
1180 function, as an argument.)
1182 If there's no eligible intrinsic implementation, there must be
1183 a bug somewhere else; no such reference should have been permitted
1184 to go this far. (Well, this might be wrong.) */
1187 ffeintrin_basictype (ffeintrinSpec spec
)
1192 assert (spec
< FFEINTRIN_spec
);
1193 imp
= ffeintrin_specs_
[spec
].implementation
;
1194 assert (imp
< FFEINTRIN_imp
);
1197 gfrt
= ffeintrin_imps_
[imp
].gfrt_f2c
;
1199 gfrt
= ffeintrin_imps_
[imp
].gfrt_gnu
;
1201 assert (gfrt
!= FFECOM_gfrt
);
1203 return ffecom_gfrt_basictype (gfrt
);
1206 /* Return family to which specific intrinsic belongs. */
1209 ffeintrin_family (ffeintrinSpec spec
)
1211 if (spec
>= FFEINTRIN_spec
)
1213 return ffeintrin_specs_
[spec
].family
;
1216 /* Check and fill in info on func/subr ref node.
1218 ffebld expr; // FUNCREF or SUBRREF with no info (caller
1219 // gets it from the modified info structure).
1220 ffeinfo info; // Already filled in, will be overwritten.
1221 ffelexToken token; // Used for error message.
1222 ffeintrin_fulfill_generic (&expr, &info, token);
1224 Based on the generic id, figure out which specific procedure is meant and
1225 pick that one. Else return an error, a la _specific. */
1228 ffeintrin_fulfill_generic (ffebld
*expr
, ffeinfo
*info
, ffelexToken t
)
1233 ffeintrinSpec spec
= FFEINTRIN_specNONE
;
1234 ffeinfoBasictype bt
= FFEINFO_basictypeNONE
;
1235 ffeinfoKindtype kt
= FFEINFO_kindtypeNONE
;
1236 ffetargetCharacterSize sz
= FFETARGET_charactersizeNONE
;
1238 ffeintrinSpec tspec
;
1239 ffeintrinImp nimp
= FFEINTRIN_impNONE
;
1242 bool highly_specific
= FALSE
;
1245 op
= ffebld_op (*expr
);
1246 assert ((op
== FFEBLD_opFUNCREF
) || (op
== FFEBLD_opSUBRREF
));
1247 assert (ffebld_op (ffebld_left (*expr
)) == FFEBLD_opSYMTER
);
1249 gen
= ffebld_symter_generic (ffebld_left (*expr
));
1250 assert (gen
!= FFEINTRIN_genNONE
);
1252 imp
= FFEINTRIN_impNONE
;
1255 any
= ffeintrin_check_any_ (ffebld_right (*expr
));
1258 (((size_t) i
) < ARRAY_SIZE (ffeintrin_gens_
[gen
].specs
))
1259 && ((tspec
= ffeintrin_gens_
[gen
].specs
[i
]) != FFEINTRIN_specNONE
)
1263 ffeintrinImp timp
= ffeintrin_specs_
[tspec
].implementation
;
1264 ffeinfoBasictype tbt
;
1265 ffeinfoKindtype tkt
;
1266 ffetargetCharacterSize tsz
;
1267 ffeIntrinsicState state
1268 = ffeintrin_state_family (ffeintrin_specs_
[tspec
].family
);
1271 if (state
== FFE_intrinsicstateDELETED
)
1274 if (timp
!= FFEINTRIN_impNONE
)
1276 if (!(ffeintrin_imps_
[timp
].control
[0] == '-')
1277 != !(ffebld_op (*expr
) == FFEBLD_opSUBRREF
))
1278 continue; /* Form of reference must match form of specific. */
1281 if (state
== FFE_intrinsicstateDISABLED
)
1282 terror
= FFEBAD_INTRINSIC_DISABLED
;
1283 else if (timp
== FFEINTRIN_impNONE
)
1284 terror
= FFEBAD_INTRINSIC_UNIMPL
;
1287 terror
= ffeintrin_check_ (timp
, ffebld_op (*expr
),
1288 ffebld_right (*expr
),
1289 &tbt
, &tkt
, &tsz
, NULL
, t
, FALSE
);
1290 if (terror
== FFEBAD
)
1292 if (imp
!= FFEINTRIN_impNONE
)
1294 ffebad_start (FFEBAD_INTRINSIC_AMBIG
);
1295 ffebad_here (0, ffelex_token_where_line (t
),
1296 ffelex_token_where_column (t
));
1297 ffebad_string (ffeintrin_gens_
[gen
].name
);
1298 ffebad_string (ffeintrin_specs_
[spec
].name
);
1299 ffebad_string (ffeintrin_specs_
[tspec
].name
);
1304 if (ffebld_symter_specific (ffebld_left (*expr
))
1306 highly_specific
= TRUE
;
1315 else if (terror
!= FFEBAD
)
1316 { /* This error has precedence over others. */
1317 if ((error
== FFEBAD_INTRINSIC_DISABLED
)
1318 || (error
== FFEBAD_INTRINSIC_UNIMPL
))
1323 if (error
== FFEBAD
)
1327 if (any
|| (imp
== FFEINTRIN_impNONE
))
1331 if (error
== FFEBAD
)
1332 error
= FFEBAD_INTRINSIC_REF
;
1333 ffebad_start (error
);
1334 ffebad_here (0, ffelex_token_where_line (t
),
1335 ffelex_token_where_column (t
));
1336 ffebad_string (ffeintrin_gens_
[gen
].name
);
1340 *expr
= ffebld_new_any ();
1341 *info
= ffeinfo_new_any ();
1345 if (!highly_specific
&& (nimp
!= FFEINTRIN_impNONE
))
1347 fprintf (stderr
, "lineno=%ld, gen=%s, imp=%s, timp=%s\n",
1349 ffeintrin_gens_
[gen
].name
,
1350 ffeintrin_imps_
[imp
].name
,
1351 ffeintrin_imps_
[nimp
].name
);
1352 assert ("Ambiguous generic reference" == NULL
);
1355 error
= ffeintrin_check_ (imp
, ffebld_op (*expr
),
1356 ffebld_right (*expr
),
1357 &bt
, &kt
, &sz
, NULL
, t
, TRUE
);
1358 assert (error
== FFEBAD
);
1359 *info
= ffeinfo_new (bt
,
1363 FFEINFO_whereFLEETING
,
1365 symter
= ffebld_left (*expr
);
1366 ffebld_symter_set_specific (symter
, spec
);
1367 ffebld_symter_set_implementation (symter
, imp
);
1368 ffebld_set_info (symter
,
1372 (bt
== FFEINFO_basictypeNONE
)
1373 ? FFEINFO_kindSUBROUTINE
1374 : FFEINFO_kindFUNCTION
,
1375 FFEINFO_whereINTRINSIC
,
1378 if ((ffesymbol_attrs (ffebld_symter (symter
)) & FFESYMBOL_attrsTYPE
)
1379 && (((bt
!= ffesymbol_basictype (ffebld_symter (symter
)))
1380 || (kt
!= ffesymbol_kindtype (ffebld_symter (symter
)))
1381 || ((sz
!= FFETARGET_charactersizeNONE
)
1382 && (sz
!= ffesymbol_size (ffebld_symter (symter
)))))))
1384 ffebad_start (FFEBAD_INTRINSIC_TYPE
);
1385 ffebad_here (0, ffelex_token_where_line (t
),
1386 ffelex_token_where_column (t
));
1387 ffebad_string (ffeintrin_gens_
[gen
].name
);
1390 if (ffeintrin_imps_
[imp
].y2kbad
)
1392 ffebad_start (FFEBAD_INTRINSIC_Y2KBAD
);
1393 ffebad_here (0, ffelex_token_where_line (t
),
1394 ffelex_token_where_column (t
));
1395 ffebad_string (ffeintrin_gens_
[gen
].name
);
1401 /* Check and fill in info on func/subr ref node.
1403 ffebld expr; // FUNCREF or SUBRREF with no info (caller
1404 // gets it from the modified info structure).
1405 ffeinfo info; // Already filled in, will be overwritten.
1406 bool check_intrin; // May be omitted, else set TRUE if intrinsic needs checking.
1407 ffelexToken token; // Used for error message.
1408 ffeintrin_fulfill_specific (&expr, &info, &check_intrin, token);
1410 Based on the specific id, determine whether the arg list is valid
1411 (number, type, rank, and kind of args) and fill in the info structure
1412 accordingly. Currently don't rewrite the expression, but perhaps
1413 someday do so for constant collapsing, except when an error occurs,
1414 in which case it is overwritten with ANY and info is also overwritten
1418 ffeintrin_fulfill_specific (ffebld
*expr
, ffeinfo
*info
,
1419 bool *check_intrin
, ffelexToken t
)
1426 ffeinfoBasictype bt
= FFEINFO_basictypeNONE
;
1427 ffeinfoKindtype kt
= FFEINFO_kindtypeNONE
;
1428 ffetargetCharacterSize sz
= FFETARGET_charactersizeNONE
;
1429 ffeIntrinsicState state
;
1434 op
= ffebld_op (*expr
);
1435 assert ((op
== FFEBLD_opFUNCREF
) || (op
== FFEBLD_opSUBRREF
));
1436 assert (ffebld_op (ffebld_left (*expr
)) == FFEBLD_opSYMTER
);
1438 gen
= ffebld_symter_generic (ffebld_left (*expr
));
1439 spec
= ffebld_symter_specific (ffebld_left (*expr
));
1440 assert (spec
!= FFEINTRIN_specNONE
);
1442 if (gen
!= FFEINTRIN_genNONE
)
1443 name
= ffeintrin_gens_
[gen
].name
;
1445 name
= ffeintrin_specs_
[spec
].name
;
1447 state
= ffeintrin_state_family (ffeintrin_specs_
[spec
].family
);
1449 imp
= ffeintrin_specs_
[spec
].implementation
;
1450 if (check_intrin
!= NULL
)
1451 *check_intrin
= FALSE
;
1453 any
= ffeintrin_check_any_ (ffebld_right (*expr
));
1455 if (state
== FFE_intrinsicstateDISABLED
)
1456 error
= FFEBAD_INTRINSIC_DISABLED
;
1457 else if (imp
== FFEINTRIN_impNONE
)
1458 error
= FFEBAD_INTRINSIC_UNIMPL
;
1461 error
= ffeintrin_check_ (imp
, ffebld_op (*expr
),
1462 ffebld_right (*expr
),
1463 &bt
, &kt
, &sz
, check_intrin
, t
, TRUE
);
1466 error
= FFEBAD
; /* Not really needed, but quiet -Wuninitialized. */
1468 if (any
|| (error
!= FFEBAD
))
1473 ffebad_start (error
);
1474 ffebad_here (0, ffelex_token_where_line (t
),
1475 ffelex_token_where_column (t
));
1476 ffebad_string (name
);
1480 *expr
= ffebld_new_any ();
1481 *info
= ffeinfo_new_any ();
1485 *info
= ffeinfo_new (bt
,
1489 FFEINFO_whereFLEETING
,
1491 symter
= ffebld_left (*expr
);
1492 ffebld_set_info (symter
,
1496 (bt
== FFEINFO_basictypeNONE
)
1497 ? FFEINFO_kindSUBROUTINE
1498 : FFEINFO_kindFUNCTION
,
1499 FFEINFO_whereINTRINSIC
,
1502 if ((ffesymbol_attrs (ffebld_symter (symter
)) & FFESYMBOL_attrsTYPE
)
1503 && (((bt
!= ffesymbol_basictype (ffebld_symter (symter
)))
1504 || (kt
!= ffesymbol_kindtype (ffebld_symter (symter
)))
1505 || (sz
!= ffesymbol_size (ffebld_symter (symter
))))))
1507 ffebad_start (FFEBAD_INTRINSIC_TYPE
);
1508 ffebad_here (0, ffelex_token_where_line (t
),
1509 ffelex_token_where_column (t
));
1510 ffebad_string (name
);
1513 if (ffeintrin_imps_
[imp
].y2kbad
)
1515 ffebad_start (FFEBAD_INTRINSIC_Y2KBAD
);
1516 ffebad_here (0, ffelex_token_where_line (t
),
1517 ffelex_token_where_column (t
));
1518 ffebad_string (name
);
1524 /* Return run-time index of intrinsic implementation as direct call. */
1526 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1528 ffeintrin_gfrt_direct (ffeintrinImp imp
)
1530 assert (imp
< FFEINTRIN_imp
);
1532 return ffeintrin_imps_
[imp
].gfrt_direct
;
1536 /* Return run-time index of intrinsic implementation as actual argument. */
1538 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1540 ffeintrin_gfrt_indirect (ffeintrinImp imp
)
1542 assert (imp
< FFEINTRIN_imp
);
1544 if (! ffe_is_f2c ())
1545 return ffeintrin_imps_
[imp
].gfrt_gnu
;
1546 return ffeintrin_imps_
[imp
].gfrt_f2c
;
1559 if (!ffe_is_do_internal_checks ())
1562 assert (FFEINTRIN_gen
== ARRAY_SIZE (ffeintrin_gens_
));
1563 assert (FFEINTRIN_imp
== ARRAY_SIZE (ffeintrin_imps_
));
1564 assert (FFEINTRIN_spec
== ARRAY_SIZE (ffeintrin_specs_
));
1566 for (i
= 1; ((size_t) i
) < ARRAY_SIZE (ffeintrin_names_
); ++i
)
1567 { /* Make sure binary-searched list is in alpha
1569 if (strcmp (ffeintrin_names_
[i
- 1].name_uc
,
1570 ffeintrin_names_
[i
].name_uc
) >= 0)
1571 assert ("name list out of order" == NULL
);
1574 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffeintrin_names_
); ++i
)
1576 assert ((ffeintrin_names_
[i
].generic
== FFEINTRIN_genNONE
)
1577 || (ffeintrin_names_
[i
].specific
== FFEINTRIN_specNONE
));
1579 p1
= ffeintrin_names_
[i
].name_uc
;
1580 p2
= ffeintrin_names_
[i
].name_lc
;
1581 p3
= ffeintrin_names_
[i
].name_ic
;
1582 for (; *p1
!= '\0' && *p2
!= '\0' && *p3
!= '\0'; ++p1
, ++p2
, ++p3
)
1584 if (! IN_CTYPE_DOMAIN (*p1
)
1585 || ! IN_CTYPE_DOMAIN (*p2
)
1586 || ! IN_CTYPE_DOMAIN (*p3
))
1588 if ((ISDIGIT (*p1
) || (*p1
== '_')) && (*p1
== *p2
) && (*p1
== *p3
))
1590 if (! ISUPPER ((unsigned char)*p1
) || ! ISLOWER ((unsigned char)*p2
)
1591 || (*p1
!= TOUPPER (*p2
))
1592 || ((*p3
!= *p1
) && (*p3
!= *p2
)))
1595 assert ((*p1
== *p2
) && (*p1
== *p3
) && (*p1
== '\0'));
1598 for (i
= 0; ((size_t) i
) < ARRAY_SIZE (ffeintrin_imps_
); ++i
)
1600 const char *c
= ffeintrin_imps_
[i
].control
;
1616 fprintf (stderr
, "%s: bad return-base-type\n",
1617 ffeintrin_imps_
[i
].name
);
1626 fprintf (stderr
, "%s: bad return-kind-type\n",
1627 ffeintrin_imps_
[i
].name
);
1636 fprintf (stderr
, "%s: bad return-modifier\n",
1637 ffeintrin_imps_
[i
].name
);
1642 if ((c
[colon
] != ':') || (c
[colon
+ 2] != ':'))
1644 fprintf (stderr
, "%s: bad control\n",
1645 ffeintrin_imps_
[i
].name
);
1648 if ((c
[colon
+ 1] != '-')
1649 && (c
[colon
+ 1] != '*')
1650 && ((c
[colon
+ 1] < '0')
1651 || (c
[colon
+ 1] > '9')))
1653 fprintf (stderr
, "%s: bad COL-spec\n",
1654 ffeintrin_imps_
[i
].name
);
1658 while (c
[0] != '\0')
1660 while ((c
[0] != '=')
1666 fprintf (stderr
, "%s: bad keyword\n",
1667 ffeintrin_imps_
[i
].name
);
1690 fprintf (stderr
, "%s: bad arg-base-type\n",
1691 ffeintrin_imps_
[i
].name
);
1699 fprintf (stderr
, "%s: bad arg-kind-type\n",
1700 ffeintrin_imps_
[i
].name
);
1705 if (((c
[4] < '0') || (c
[4] > '9'))
1707 && (++c
, (c
[4] < '0') || (c
[4] > '9')
1710 fprintf (stderr
, "%s: bad arg-len\n",
1711 ffeintrin_imps_
[i
].name
);
1718 if (((c
[4] < '0') || (c
[4] > '9'))
1720 && (++c
, (c
[4] < '0') || (c
[4] > '9')
1723 fprintf (stderr
, "%s: bad arg-rank\n",
1724 ffeintrin_imps_
[i
].name
);
1729 else if ((c
[3] == '&')
1744 fprintf (stderr
, "%s: bad arg-list\n",
1745 ffeintrin_imps_
[i
].name
);
1752 /* Determine whether intrinsic is okay as an actual argument. */
1755 ffeintrin_is_actualarg (ffeintrinSpec spec
)
1757 ffeIntrinsicState state
;
1759 if (spec
>= FFEINTRIN_spec
)
1762 state
= ffeintrin_state_family (ffeintrin_specs_
[spec
].family
);
1764 return (!ffe_is_pedantic () || ffeintrin_specs_
[spec
].is_actualarg
)
1765 #if FFECOM_targetCURRENT == FFECOM_targetGCC
1767 ? (ffeintrin_imps_
[ffeintrin_specs_
[spec
].implementation
].gfrt_f2c
1769 : (ffeintrin_imps_
[ffeintrin_specs_
[spec
].implementation
].gfrt_gnu
1772 && ((state
== FFE_intrinsicstateENABLED
)
1773 || (state
== FFE_intrinsicstateHIDDEN
));
1776 /* Determine if name is intrinsic, return info.
1778 const char *name; // C-string name of possible intrinsic.
1779 ffelexToken t; // NULL if no diagnostic to be given.
1780 bool explicit; // TRUE if INTRINSIC name.
1781 ffeintrinGen gen; // (TRUE only) Generic id of intrinsic.
1782 ffeintrinSpec spec; // (TRUE only) Specific id of intrinsic.
1783 ffeintrinImp imp; // (TRUE only) Implementation id of intrinsic.
1784 if (ffeintrin_is_intrinsic (name, t, explicit,
1786 // is an intrinsic, use gen, spec, imp, and
1787 // kind accordingly. */
1790 ffeintrin_is_intrinsic (const char *name
, ffelexToken t
, bool explicit,
1791 ffeintrinGen
*xgen
, ffeintrinSpec
*xspec
,
1794 struct _ffeintrin_name_
*intrinsic
;
1798 ffeIntrinsicState state
;
1799 bool disabled
= FALSE
;
1800 bool unimpl
= FALSE
;
1802 intrinsic
= bsearch (name
, &ffeintrin_names_
[0],
1803 ARRAY_SIZE (ffeintrin_names_
),
1804 sizeof (struct _ffeintrin_name_
),
1805 (void *) ffeintrin_cmp_name_
);
1807 if (intrinsic
== NULL
)
1810 gen
= intrinsic
->generic
;
1811 spec
= intrinsic
->specific
;
1812 imp
= ffeintrin_specs_
[spec
].implementation
;
1814 /* Generic is okay only if at least one of its specifics is okay. */
1816 if (gen
!= FFEINTRIN_genNONE
)
1819 ffeintrinSpec tspec
;
1822 name
= ffeintrin_gens_
[gen
].name
;
1825 (((size_t) i
) < ARRAY_SIZE (ffeintrin_gens_
[gen
].specs
))
1827 = ffeintrin_gens_
[gen
].specs
[i
]) != FFEINTRIN_specNONE
);
1830 state
= ffeintrin_state_family (ffeintrin_specs_
[tspec
].family
);
1832 if (state
== FFE_intrinsicstateDELETED
)
1835 if (state
== FFE_intrinsicstateDISABLED
)
1841 if (ffeintrin_specs_
[tspec
].implementation
== FFEINTRIN_impNONE
)
1847 if ((state
== FFE_intrinsicstateENABLED
)
1849 && (state
== FFE_intrinsicstateHIDDEN
)))
1856 gen
= FFEINTRIN_genNONE
;
1859 /* Specific is okay only if not: unimplemented, disabled, deleted, or
1860 hidden and not explicit. */
1862 if (spec
!= FFEINTRIN_specNONE
)
1864 if (gen
!= FFEINTRIN_genNONE
)
1865 name
= ffeintrin_gens_
[gen
].name
;
1867 name
= ffeintrin_specs_
[spec
].name
;
1869 if (((state
= ffeintrin_state_family (ffeintrin_specs_
[spec
].family
))
1870 == FFE_intrinsicstateDELETED
)
1872 && (state
== FFE_intrinsicstateHIDDEN
)))
1873 spec
= FFEINTRIN_specNONE
;
1874 else if (state
== FFE_intrinsicstateDISABLED
)
1877 spec
= FFEINTRIN_specNONE
;
1879 else if (imp
== FFEINTRIN_impNONE
)
1882 spec
= FFEINTRIN_specNONE
;
1886 /* If neither is okay, not an intrinsic. */
1888 if ((gen
== FFEINTRIN_genNONE
) && (spec
== FFEINTRIN_specNONE
))
1890 /* Here is where we produce a diagnostic about a reference to a
1891 disabled or unimplemented intrinsic, if the diagnostic is desired. */
1893 if ((disabled
|| unimpl
)
1896 ffebad_start (disabled
1897 ? FFEBAD_INTRINSIC_DISABLED
1898 : FFEBAD_INTRINSIC_UNIMPLW
);
1899 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
1900 ffebad_string (name
);
1907 /* Determine whether intrinsic is function or subroutine. If no specific
1908 id, scan list of possible specifics for generic to get consensus. If
1909 not unanimous, or clear from the context, return NONE. */
1911 if (spec
== FFEINTRIN_specNONE
)
1914 ffeintrinSpec tspec
;
1916 bool at_least_one_ok
= FALSE
;
1919 (((size_t) i
) < ARRAY_SIZE (ffeintrin_gens_
[gen
].specs
))
1921 = ffeintrin_gens_
[gen
].specs
[i
]) != FFEINTRIN_specNONE
);
1924 if (((state
= ffeintrin_state_family (ffeintrin_specs_
[tspec
].family
))
1925 == FFE_intrinsicstateDELETED
)
1926 || (state
== FFE_intrinsicstateDISABLED
))
1929 if ((timp
= ffeintrin_specs_
[tspec
].implementation
)
1930 == FFEINTRIN_impNONE
)
1933 at_least_one_ok
= TRUE
;
1937 if (!at_least_one_ok
)
1939 *xgen
= FFEINTRIN_genNONE
;
1940 *xspec
= FFEINTRIN_specNONE
;
1941 *ximp
= FFEINTRIN_impNONE
;
1952 /* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90). */
1955 ffeintrin_is_standard (ffeintrinGen gen
, ffeintrinSpec spec
)
1957 if (spec
== FFEINTRIN_specNONE
)
1959 if (gen
== FFEINTRIN_genNONE
)
1962 spec
= ffeintrin_gens_
[gen
].specs
[0];
1963 if (spec
== FFEINTRIN_specNONE
)
1967 if ((ffeintrin_specs_
[spec
].family
== FFEINTRIN_familyF77
)
1969 && ((ffeintrin_specs_
[spec
].family
== FFEINTRIN_familyF90
)
1970 || (ffeintrin_specs_
[spec
].family
== FFEINTRIN_familyMIL
)
1971 || (ffeintrin_specs_
[spec
].family
== FFEINTRIN_familyASC
))))
1976 /* Return kind type of intrinsic implementation. See ffeintrin_basictype,
1980 ffeintrin_kindtype (ffeintrinSpec spec
)
1985 assert (spec
< FFEINTRIN_spec
);
1986 imp
= ffeintrin_specs_
[spec
].implementation
;
1987 assert (imp
< FFEINTRIN_imp
);
1990 gfrt
= ffeintrin_imps_
[imp
].gfrt_f2c
;
1992 gfrt
= ffeintrin_imps_
[imp
].gfrt_gnu
;
1994 assert (gfrt
!= FFECOM_gfrt
);
1996 return ffecom_gfrt_kindtype (gfrt
);
1999 /* Return name of generic intrinsic. */
2002 ffeintrin_name_generic (ffeintrinGen gen
)
2004 assert (gen
< FFEINTRIN_gen
);
2005 return ffeintrin_gens_
[gen
].name
;
2008 /* Return name of intrinsic implementation. */
2011 ffeintrin_name_implementation (ffeintrinImp imp
)
2013 assert (imp
< FFEINTRIN_imp
);
2014 return ffeintrin_imps_
[imp
].name
;
2017 /* Return external/internal name of specific intrinsic. */
2020 ffeintrin_name_specific (ffeintrinSpec spec
)
2022 assert (spec
< FFEINTRIN_spec
);
2023 return ffeintrin_specs_
[spec
].name
;
2026 /* Return state of family. */
2029 ffeintrin_state_family (ffeintrinFamily family
)
2031 ffeIntrinsicState state
;
2035 case FFEINTRIN_familyNONE
:
2036 return FFE_intrinsicstateDELETED
;
2038 case FFEINTRIN_familyF77
:
2039 return FFE_intrinsicstateENABLED
;
2041 case FFEINTRIN_familyASC
:
2042 state
= ffe_intrinsic_state_f2c ();
2043 state
= ffe_state_max (state
, ffe_intrinsic_state_f90 ());
2046 case FFEINTRIN_familyMIL
:
2047 state
= ffe_intrinsic_state_vxt ();
2048 state
= ffe_state_max (state
, ffe_intrinsic_state_f90 ());
2049 state
= ffe_state_max (state
, ffe_intrinsic_state_mil ());
2052 case FFEINTRIN_familyGNU
:
2053 state
= ffe_intrinsic_state_gnu ();
2056 case FFEINTRIN_familyF90
:
2057 state
= ffe_intrinsic_state_f90 ();
2060 case FFEINTRIN_familyVXT
:
2061 state
= ffe_intrinsic_state_vxt ();
2064 case FFEINTRIN_familyFVZ
:
2065 state
= ffe_intrinsic_state_f2c ();
2066 state
= ffe_state_max (state
, ffe_intrinsic_state_vxt ());
2069 case FFEINTRIN_familyF2C
:
2070 state
= ffe_intrinsic_state_f2c ();
2073 case FFEINTRIN_familyF2U
:
2074 state
= ffe_intrinsic_state_unix ();
2077 case FFEINTRIN_familyBADU77
:
2078 state
= ffe_intrinsic_state_badu77 ();
2082 assert ("bad family" == NULL
);
2083 return FFE_intrinsicstateDELETED
;