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.
4
5 This file is part of GNU Fortran.
6
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)
10 any later version.
11
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.
16
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
20 02111-1307, USA.
21
22 */
23
24 #include "proj.h"
25 #include "intrin.h"
26 #include "expr.h"
27 #include "info.h"
28 #include "src.h"
29 #include "symbol.h"
30 #include "target.h"
31 #include "top.h"
32
33 struct _ffeintrin_name_
34 {
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;
40 };
41
42 struct _ffeintrin_gen_
43 {
44 const char *const name; /* Name as seen in program. */
45 const ffeintrinSpec specs[2];
46 };
47
48 struct _ffeintrin_spec_
49 {
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;
56 };
57
58 struct _ffeintrin_imp_
59 {
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;
65 const char y2kbad;
66 };
67
68 static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
69 ffebld args, ffeinfoBasictype *xbt,
70 ffeinfoKindtype *xkt,
71 ffetargetCharacterSize *xsz,
72 bool *check_intrin,
73 ffelexToken t,
74 bool commit);
75 static bool ffeintrin_check_any_ (ffebld arglist);
76 static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic);
77
78 static const struct _ffeintrin_name_ ffeintrin_names_[]
79 =
80 { /* Alpha order. */
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)
87 #include "intrin.def"
88 #undef DEFNAME
89 #undef DEFGEN
90 #undef DEFSPEC
91 #undef DEFIMP
92 #undef DEFIMPY
93 };
94
95 static const struct _ffeintrin_gen_ ffeintrin_gens_[]
96 =
97 {
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"
105 #undef DEFNAME
106 #undef DEFGEN
107 #undef DEFSPEC
108 #undef DEFIMP
109 #undef DEFIMPY
110 };
111
112 static const struct _ffeintrin_imp_ ffeintrin_imps_[]
113 =
114 {
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"
125 #undef DEFNAME
126 #undef DEFGEN
127 #undef DEFSPEC
128 #undef DEFIMP
129 #undef DEFIMPY
130 };
131
132 static const struct _ffeintrin_spec_ ffeintrin_specs_[]
133 =
134 {
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"
142 #undef DEFGEN
143 #undef DEFSPEC
144 #undef DEFIMP
145 #undef DEFIMPY
146 };
147
148
149 static ffebad
ffeintrin_check_(ffeintrinImp imp,ffebldOp op,ffebld args,ffeinfoBasictype * xbt,ffeinfoKindtype * xkt,ffetargetCharacterSize * xsz,bool * check_intrin,ffelexToken t,bool commit)150 ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
151 ffebld args, ffeinfoBasictype *xbt,
152 ffeinfoKindtype *xkt,
153 ffetargetCharacterSize *xsz,
154 bool *check_intrin,
155 ffelexToken t,
156 bool commit)
157 {
158 const char *c = ffeintrin_imps_[imp].control;
159 bool subr = (c[0] == '-');
160 const char *argc;
161 ffebld arg;
162 ffeinfoBasictype bt;
163 ffeinfoKindtype kt;
164 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
165 ffeinfoKindtype firstarg_kt;
166 bool need_col;
167 ffeinfoBasictype col_bt = FFEINFO_basictypeNONE;
168 ffeinfoKindtype col_kt = FFEINFO_kindtypeNONE;
169 int colon = (c[2] == ':') ? 2 : 3;
170 int argno;
171
172 /* Check procedure type (function vs. subroutine) against
173 invocation. */
174
175 if (op == FFEBLD_opSUBRREF)
176 {
177 if (!subr)
178 return FFEBAD_INTRINSIC_IS_FUNC;
179 }
180 else if (op == FFEBLD_opFUNCREF)
181 {
182 if (subr)
183 return FFEBAD_INTRINSIC_IS_SUBR;
184 }
185 else
186 return FFEBAD_INTRINSIC_REF;
187
188 /* Check the arglist for validity. */
189
190 if ((args != NULL)
191 && (ffebld_head (args) != NULL))
192 firstarg_kt = ffeinfo_kindtype (ffebld_info (ffebld_head (args)));
193 else
194 firstarg_kt = FFEINFO_kindtype;
195
196 for (argc = &c[colon + 3],
197 arg = args;
198 *argc != '\0';
199 )
200 {
201 char optional = '\0';
202 char required = '\0';
203 char extra = '\0';
204 char basic;
205 char kind;
206 int length;
207 int elements;
208 bool lastarg_complex = FALSE;
209
210 /* We don't do anything with keywords yet. */
211 do
212 {
213 } while (*(++argc) != '=');
214
215 ++argc;
216 if ((*argc == '?')
217 || (*argc == '!')
218 || (*argc == '*'))
219 optional = *(argc++);
220 if ((*argc == '+')
221 || (*argc == 'n')
222 || (*argc == 'p'))
223 required = *(argc++);
224 basic = *(argc++);
225 kind = *(argc++);
226 if (*argc == '[')
227 {
228 length = *++argc - '0';
229 if (*++argc != ']')
230 length = 10 * length + (*(argc++) - '0');
231 ++argc;
232 }
233 else
234 length = -1;
235 if (*argc == '(')
236 {
237 elements = *++argc - '0';
238 if (*++argc != ')')
239 elements = 10 * elements + (*(argc++) - '0');
240 ++argc;
241 }
242 else if (*argc == '&')
243 {
244 elements = -1;
245 ++argc;
246 }
247 else
248 elements = 0;
249 if ((*argc == '&')
250 || (*argc == 'i')
251 || (*argc == 'w')
252 || (*argc == 'x'))
253 extra = *(argc++);
254 if (*argc == ',')
255 ++argc;
256
257 /* Break out of this loop only when current arg spec completely
258 processed. */
259
260 do
261 {
262 bool okay;
263 ffebld a;
264 ffeinfo i;
265 bool anynum;
266 ffeinfoBasictype abt = FFEINFO_basictypeNONE;
267 ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
268
269 if ((arg == NULL)
270 || (ffebld_head (arg) == NULL))
271 {
272 if (required != '\0')
273 return FFEBAD_INTRINSIC_TOOFEW;
274 if (optional == '\0')
275 return FFEBAD_INTRINSIC_TOOFEW;
276 if (arg != NULL)
277 arg = ffebld_trail (arg);
278 break; /* Try next argspec. */
279 }
280
281 a = ffebld_head (arg);
282 i = ffebld_info (a);
283 anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
284 || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
285
286 /* See how well the arg matches up to the spec. */
287
288 switch (basic)
289 {
290 case 'A':
291 okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
292 && ((length == -1)
293 || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
294 break;
295
296 case 'C':
297 okay = anynum
298 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
299 abt = FFEINFO_basictypeCOMPLEX;
300 break;
301
302 case 'I':
303 okay = anynum
304 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
305 abt = FFEINFO_basictypeINTEGER;
306 break;
307
308 case 'L':
309 okay = anynum
310 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
311 abt = FFEINFO_basictypeLOGICAL;
312 break;
313
314 case 'R':
315 okay = anynum
316 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
317 abt = FFEINFO_basictypeREAL;
318 break;
319
320 case 'B':
321 okay = anynum
322 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
323 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
324 break;
325
326 case 'F':
327 okay = anynum
328 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
329 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
330 break;
331
332 case 'N':
333 okay = anynum
334 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
335 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
336 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
337 break;
338
339 case 'S':
340 okay = anynum
341 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
342 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
343 break;
344
345 case 'g':
346 okay = ((ffebld_op (a) == FFEBLD_opLABTER)
347 || (ffebld_op (a) == FFEBLD_opLABTOK));
348 elements = -1;
349 extra = '-';
350 break;
351
352 case 's':
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)));
364 elements = -1;
365 extra = '-';
366 break;
367
368 case '-':
369 default:
370 okay = TRUE;
371 break;
372 }
373
374 switch (kind)
375 {
376 case '1': case '2': case '3': case '4': case '5':
377 case '6': case '7': case '8': case '9':
378 akt = (kind - '0');
379 if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
380 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
381 {
382 switch (akt)
383 { /* Translate to internal kinds for now! */
384 default:
385 break;
386
387 case 2:
388 akt = 4;
389 break;
390
391 case 3:
392 akt = 2;
393 break;
394
395 case 4:
396 akt = 5;
397 break;
398
399 case 6:
400 akt = 3;
401 break;
402
403 case 7:
404 akt = ffecom_pointer_kind ();
405 break;
406 }
407 }
408 okay &= anynum || (ffeinfo_kindtype (i) == akt);
409 break;
410
411 case 'A':
412 okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
413 akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
414 : firstarg_kt;
415 break;
416
417 case 'N':
418 /* Accept integers and logicals not wider than the default integer/logical. */
419 if (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
420 {
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. */
425 }
426 else if (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL)
427 {
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. */
432 }
433 break;
434
435 case '*':
436 default:
437 break;
438 }
439
440 switch (elements)
441 {
442 ffebld b;
443
444 case -1:
445 break;
446
447 case 0:
448 if (ffeinfo_rank (i) != 0)
449 okay = FALSE;
450 break;
451
452 default:
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))
460 okay = FALSE;
461 break;
462 }
463
464 switch (extra)
465 {
466 case '&':
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)))
471 okay = FALSE;
472 break;
473
474 case 'w':
475 case 'x':
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)))
480 okay = FALSE;
481 break;
482
483 case '-':
484 case 'i':
485 break;
486
487 default:
488 if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
489 okay = FALSE;
490 break;
491 }
492
493 if ((optional == '!')
494 && lastarg_complex)
495 okay = FALSE;
496
497 if (!okay)
498 {
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. */
504 }
505
506 lastarg_complex
507 = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
508
509 if (anynum)
510 {
511 /* If we know dummy arg type, convert to that now. */
512
513 if ((abt != FFEINFO_basictypeNONE)
514 && (akt != FFEINFO_kindtypeNONE)
515 && commit)
516 {
517 /* We have a known type, convert hollerith/typeless
518 to it. */
519
520 a = ffeexpr_convert (a, t, NULL,
521 abt, akt, 0,
522 FFETARGET_charactersizeNONE,
523 FFEEXPR_contextLET);
524 ffebld_set_head (arg, a);
525 }
526 }
527
528 arg = ffebld_trail (arg); /* Arg accepted, now move on. */
529
530 if (optional == '*')
531 continue; /* Go ahead and try another arg. */
532 if (required == '\0')
533 break;
534 if ((required == 'n')
535 || (required == '+'))
536 {
537 optional = '*';
538 required = '\0';
539 }
540 else if (required == 'p')
541 required = 'n';
542 } while (TRUE);
543 }
544
545 if (arg != NULL)
546 return FFEBAD_INTRINSIC_TOOMANY;
547
548 /* Set up the initial type for the return value of the function. */
549
550 need_col = FALSE;
551 switch (c[0])
552 {
553 case 'A':
554 bt = FFEINFO_basictypeCHARACTER;
555 sz = (c[2] == '*') ? FFETARGET_charactersizeNONE : 1;
556 break;
557
558 case 'C':
559 bt = FFEINFO_basictypeCOMPLEX;
560 break;
561
562 case 'I':
563 bt = FFEINFO_basictypeINTEGER;
564 break;
565
566 case 'L':
567 bt = FFEINFO_basictypeLOGICAL;
568 break;
569
570 case 'R':
571 bt = FFEINFO_basictypeREAL;
572 break;
573
574 case 'B':
575 case 'F':
576 case 'N':
577 case 'S':
578 need_col = TRUE;
579 /* Fall through. */
580 case '-':
581 default:
582 bt = FFEINFO_basictypeNONE;
583 break;
584 }
585
586 switch (c[1])
587 {
588 case '1': case '2': case '3': case '4': case '5':
589 case '6': case '7': case '8': case '9':
590 kt = (c[1] - '0');
591 if ((bt == FFEINFO_basictypeINTEGER)
592 || (bt == FFEINFO_basictypeLOGICAL))
593 {
594 switch (kt)
595 { /* Translate to internal kinds for now! */
596 default:
597 break;
598
599 case 2:
600 kt = 4;
601 break;
602
603 case 3:
604 kt = 2;
605 break;
606
607 case 4:
608 kt = 5;
609 break;
610
611 case 6:
612 kt = 3;
613 break;
614
615 case 7:
616 kt = ffecom_pointer_kind ();
617 break;
618 }
619 }
620 break;
621
622 case 'C':
623 if (ffe_is_90 ())
624 need_col = TRUE;
625 kt = 1;
626 break;
627
628 case '=':
629 need_col = TRUE;
630 /* Fall through. */
631 case '-':
632 default:
633 kt = FFEINFO_kindtypeNONE;
634 break;
635 }
636
637 /* Determine collective type of COL, if there is one. */
638
639 if (need_col || c[colon + 1] != '-')
640 {
641 bool okay = TRUE;
642 bool have_anynum = FALSE;
643 int arg_count=0;
644
645 for (arg = args, arg_count=0;
646 arg != NULL;
647 arg = ffebld_trail (arg), arg_count++ )
648 {
649 ffebld a = ffebld_head (arg);
650 ffeinfo i;
651 bool anynum;
652
653 if (a == NULL)
654 continue;
655 i = ffebld_info (a);
656
657 if ( c[colon+1] != '*' && (c[colon+1]-'0') != arg_count )
658 continue;
659
660 anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
661 || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
662 if (anynum)
663 {
664 have_anynum = TRUE;
665 continue;
666 }
667
668 if ((col_bt == FFEINFO_basictypeNONE)
669 && (col_kt == FFEINFO_kindtypeNONE))
670 {
671 col_bt = ffeinfo_basictype (i);
672 col_kt = ffeinfo_kindtype (i);
673 }
674 else
675 {
676 ffeexpr_type_combine (&col_bt, &col_kt,
677 col_bt, col_kt,
678 ffeinfo_basictype (i),
679 ffeinfo_kindtype (i),
680 NULL);
681 if ((col_bt == FFEINFO_basictypeNONE)
682 || (col_kt == FFEINFO_kindtypeNONE))
683 return FFEBAD_INTRINSIC_REF;
684 }
685 }
686
687 if (have_anynum
688 && ((col_bt == FFEINFO_basictypeNONE)
689 || (col_kt == FFEINFO_kindtypeNONE)))
690 {
691 /* No type, but have hollerith/typeless. Use type of return
692 value to determine type of COL. */
693
694 switch (c[0])
695 {
696 case 'A':
697 return FFEBAD_INTRINSIC_REF;
698
699 case 'B':
700 case 'I':
701 case 'L':
702 if ((col_bt != FFEINFO_basictypeNONE)
703 && (col_bt != FFEINFO_basictypeINTEGER))
704 return FFEBAD_INTRINSIC_REF;
705 /* Fall through. */
706 case 'N':
707 case 'S':
708 case '-':
709 default:
710 col_bt = FFEINFO_basictypeINTEGER;
711 col_kt = FFEINFO_kindtypeINTEGER1;
712 break;
713
714 case 'C':
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;
720 break;
721
722 case 'R':
723 if ((col_bt != FFEINFO_basictypeNONE)
724 && (col_bt != FFEINFO_basictypeREAL))
725 return FFEBAD_INTRINSIC_REF;
726 /* Fall through. */
727 case 'F':
728 col_bt = FFEINFO_basictypeREAL;
729 col_kt = FFEINFO_kindtypeREAL1;
730 break;
731 }
732 }
733
734 switch (c[0])
735 {
736 case 'B':
737 okay = (col_bt == FFEINFO_basictypeINTEGER)
738 || (col_bt == FFEINFO_basictypeLOGICAL);
739 if (need_col)
740 bt = col_bt;
741 break;
742
743 case 'F':
744 okay = (col_bt == FFEINFO_basictypeCOMPLEX)
745 || (col_bt == FFEINFO_basictypeREAL);
746 if (need_col)
747 bt = col_bt;
748 break;
749
750 case 'N':
751 okay = (col_bt == FFEINFO_basictypeCOMPLEX)
752 || (col_bt == FFEINFO_basictypeINTEGER)
753 || (col_bt == FFEINFO_basictypeREAL);
754 if (need_col)
755 bt = col_bt;
756 break;
757
758 case 'S':
759 okay = (col_bt == FFEINFO_basictypeINTEGER)
760 || (col_bt == FFEINFO_basictypeREAL)
761 || (col_bt == FFEINFO_basictypeCOMPLEX);
762 if (need_col)
763 bt = ((col_bt != FFEINFO_basictypeCOMPLEX) ? col_bt
764 : FFEINFO_basictypeREAL);
765 break;
766 }
767
768 switch (c[1])
769 {
770 case '=':
771 if (need_col)
772 kt = col_kt;
773 break;
774
775 case 'C':
776 if (col_bt == FFEINFO_basictypeCOMPLEX)
777 {
778 if (col_kt != FFEINFO_kindtypeREALDEFAULT)
779 *check_intrin = TRUE;
780 if (need_col)
781 kt = col_kt;
782 }
783 break;
784 }
785
786 if (!okay)
787 return FFEBAD_INTRINSIC_REF;
788 }
789
790 /* Now, convert args in the arglist to the final type of the COL. */
791
792 for (argno = 0, argc = &c[colon + 3],
793 arg = args;
794 *argc != '\0';
795 ++argno)
796 {
797 char optional = '\0';
798 char required = '\0';
799 char extra = '\0';
800 char basic;
801 char kind;
802 int length;
803 int elements;
804 bool lastarg_complex = FALSE;
805
806 /* We don't do anything with keywords yet. */
807 do
808 {
809 } while (*(++argc) != '=');
810
811 ++argc;
812 if ((*argc == '?')
813 || (*argc == '!')
814 || (*argc == '*'))
815 optional = *(argc++);
816 if ((*argc == '+')
817 || (*argc == 'n')
818 || (*argc == 'p'))
819 required = *(argc++);
820 basic = *(argc++);
821 kind = *(argc++);
822 if (*argc == '[')
823 {
824 length = *++argc - '0';
825 if (*++argc != ']')
826 length = 10 * length + (*(argc++) - '0');
827 ++argc;
828 }
829 else
830 length = -1;
831 if (*argc == '(')
832 {
833 elements = *++argc - '0';
834 if (*++argc != ')')
835 elements = 10 * elements + (*(argc++) - '0');
836 ++argc;
837 }
838 else if (*argc == '&')
839 {
840 elements = -1;
841 ++argc;
842 }
843 else
844 elements = 0;
845 if ((*argc == '&')
846 || (*argc == 'i')
847 || (*argc == 'w')
848 || (*argc == 'x'))
849 extra = *(argc++);
850 if (*argc == ',')
851 ++argc;
852
853 /* Break out of this loop only when current arg spec completely
854 processed. */
855
856 do
857 {
858 bool okay;
859 ffebld a;
860 ffeinfo i;
861 bool anynum;
862 ffeinfoBasictype abt = FFEINFO_basictypeNONE;
863 ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
864
865 if ((arg == NULL)
866 || (ffebld_head (arg) == NULL))
867 {
868 if (arg != NULL)
869 arg = ffebld_trail (arg);
870 break; /* Try next argspec. */
871 }
872
873 a = ffebld_head (arg);
874 i = ffebld_info (a);
875 anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
876 || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
877
878 /* Determine what the default type for anynum would be. */
879
880 if (anynum)
881 {
882 switch (c[colon + 1])
883 {
884 case '-':
885 break;
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'))
889 break;
890 case '*':
891 abt = col_bt;
892 akt = col_kt;
893 break;
894 }
895 }
896
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. */
901
902 switch (basic)
903 {
904 case 'A':
905 okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
906 && ((length == -1)
907 || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
908 break;
909
910 case 'C':
911 okay = anynum
912 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
913 abt = FFEINFO_basictypeCOMPLEX;
914 break;
915
916 case 'I':
917 okay = anynum
918 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
919 abt = FFEINFO_basictypeINTEGER;
920 break;
921
922 case 'L':
923 okay = anynum
924 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
925 abt = FFEINFO_basictypeLOGICAL;
926 break;
927
928 case 'R':
929 okay = anynum
930 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
931 abt = FFEINFO_basictypeREAL;
932 break;
933
934 case 'B':
935 okay = anynum
936 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
937 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
938 break;
939
940 case 'F':
941 okay = anynum
942 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
943 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
944 break;
945
946 case 'N':
947 okay = anynum
948 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
949 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
950 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
951 break;
952
953 case 'S':
954 okay = anynum
955 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
956 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
957 break;
958
959 case 'g':
960 okay = ((ffebld_op (a) == FFEBLD_opLABTER)
961 || (ffebld_op (a) == FFEBLD_opLABTOK));
962 elements = -1;
963 extra = '-';
964 break;
965
966 case 's':
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)));
978 elements = -1;
979 extra = '-';
980 break;
981
982 case '-':
983 default:
984 okay = TRUE;
985 break;
986 }
987
988 switch (kind)
989 {
990 case '1': case '2': case '3': case '4': case '5':
991 case '6': case '7': case '8': case '9':
992 akt = (kind - '0');
993 if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
994 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
995 {
996 switch (akt)
997 { /* Translate to internal kinds for now! */
998 default:
999 break;
1000
1001 case 2:
1002 akt = 4;
1003 break;
1004
1005 case 3:
1006 akt = 2;
1007 break;
1008
1009 case 4:
1010 akt = 5;
1011 break;
1012
1013 case 6:
1014 akt = 3;
1015 break;
1016
1017 case 7:
1018 akt = ffecom_pointer_kind ();
1019 break;
1020 }
1021 }
1022 okay &= anynum || (ffeinfo_kindtype (i) == akt);
1023 break;
1024
1025 case 'A':
1026 okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
1027 akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
1028 : firstarg_kt;
1029 break;
1030
1031 case '*':
1032 default:
1033 break;
1034 }
1035
1036 switch (elements)
1037 {
1038 ffebld b;
1039
1040 case -1:
1041 break;
1042
1043 case 0:
1044 if (ffeinfo_rank (i) != 0)
1045 okay = FALSE;
1046 break;
1047
1048 default:
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))
1056 okay = FALSE;
1057 break;
1058 }
1059
1060 switch (extra)
1061 {
1062 case '&':
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)))
1067 okay = FALSE;
1068 break;
1069
1070 case 'w':
1071 case 'x':
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)))
1076 okay = FALSE;
1077 break;
1078
1079 case '-':
1080 case 'i':
1081 break;
1082
1083 default:
1084 if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
1085 okay = FALSE;
1086 break;
1087 }
1088
1089 if ((optional == '!')
1090 && lastarg_complex)
1091 okay = FALSE;
1092
1093 if (!okay)
1094 {
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. */
1100 }
1101
1102 lastarg_complex
1103 = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
1104
1105 if (anynum && commit)
1106 {
1107 /* If we know dummy arg type, convert to that now. */
1108
1109 if (abt == FFEINFO_basictypeNONE)
1110 abt = FFEINFO_basictypeINTEGER;
1111 if (akt == FFEINFO_kindtypeNONE)
1112 akt = FFEINFO_kindtypeINTEGER1;
1113
1114 /* We have a known type, convert hollerith/typeless to it. */
1115
1116 a = ffeexpr_convert (a, t, NULL,
1117 abt, akt, 0,
1118 FFETARGET_charactersizeNONE,
1119 FFEEXPR_contextLET);
1120 ffebld_set_head (arg, a);
1121 }
1122 else if ((c[colon + 1] == '*') && commit)
1123 {
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. */
1127
1128 a = ffeexpr_convert (a, t, NULL,
1129 col_bt, col_kt, 0,
1130 ffeinfo_size (i),
1131 FFEEXPR_contextLET);
1132 ffebld_set_head (arg, a);
1133 }
1134
1135 arg = ffebld_trail (arg); /* Arg accepted, now move on. */
1136
1137 if (optional == '*')
1138 continue; /* Go ahead and try another arg. */
1139 if (required == '\0')
1140 break;
1141 if ((required == 'n')
1142 || (required == '+'))
1143 {
1144 optional = '*';
1145 required = '\0';
1146 }
1147 else if (required == 'p')
1148 required = 'n';
1149 } while (TRUE);
1150 }
1151
1152 *xbt = bt;
1153 *xkt = kt;
1154 *xsz = sz;
1155 return FFEBAD;
1156 }
1157
1158 static bool
ffeintrin_check_any_(ffebld arglist)1159 ffeintrin_check_any_ (ffebld arglist)
1160 {
1161 ffebld item;
1162
1163 for (; arglist != NULL; arglist = ffebld_trail (arglist))
1164 {
1165 item = ffebld_head (arglist);
1166 if ((item != NULL)
1167 && (ffebld_op (item) == FFEBLD_opANY))
1168 return TRUE;
1169 }
1170
1171 return FALSE;
1172 }
1173
1174 /* Compare a forced-to-uppercase name with a known-upper-case name. */
1175
1176 static int
upcasecmp_(const char * name,const char * ucname)1177 upcasecmp_ (const char *name, const char *ucname)
1178 {
1179 for ( ; *name != 0 && *ucname != 0; name++, ucname++)
1180 {
1181 int i = TOUPPER(*name) - *ucname;
1182
1183 if (i != 0)
1184 return i;
1185 }
1186
1187 return *name - *ucname;
1188 }
1189
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. */
1194
1195 static int
ffeintrin_cmp_name_(const void * name,const void * intrinsic)1196 ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
1197 {
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;
1201 int i;
1202
1203 if ((i = upcasecmp_ (name, uc)) == 0)
1204 {
1205 switch (ffe_case_intrin ())
1206 {
1207 case FFE_caseLOWER:
1208 return strcmp(name, lc);
1209 case FFE_caseINITCAP:
1210 return strcmp(name, ic);
1211 default:
1212 return 0;
1213 }
1214 }
1215
1216 return i;
1217 }
1218
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.)
1225
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.) */
1229
1230 ffeinfoBasictype
ffeintrin_basictype(ffeintrinSpec spec)1231 ffeintrin_basictype (ffeintrinSpec spec)
1232 {
1233 ffeintrinImp imp;
1234 ffecomGfrt gfrt;
1235
1236 assert (spec < FFEINTRIN_spec);
1237 imp = ffeintrin_specs_[spec].implementation;
1238 assert (imp < FFEINTRIN_imp);
1239
1240 if (ffe_is_f2c ())
1241 gfrt = ffeintrin_imps_[imp].gfrt_f2c;
1242 else
1243 gfrt = ffeintrin_imps_[imp].gfrt_gnu;
1244
1245 assert (gfrt != FFECOM_gfrt);
1246
1247 return ffecom_gfrt_basictype (gfrt);
1248 }
1249
1250 /* Return family to which specific intrinsic belongs. */
1251
1252 ffeintrinFamily
ffeintrin_family(ffeintrinSpec spec)1253 ffeintrin_family (ffeintrinSpec spec)
1254 {
1255 if (spec >= FFEINTRIN_spec)
1256 return FALSE;
1257 return ffeintrin_specs_[spec].family;
1258 }
1259
1260 /* Check and fill in info on func/subr ref node.
1261
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);
1267
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. */
1270
1271 void
ffeintrin_fulfill_generic(ffebld * expr,ffeinfo * info,ffelexToken t)1272 ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t)
1273 {
1274 ffebld symter;
1275 ffebldOp op;
1276 ffeintrinGen gen;
1277 ffeintrinSpec spec = FFEINTRIN_specNONE;
1278 ffeinfoBasictype bt = FFEINFO_basictypeNONE;
1279 ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
1280 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
1281 ffeintrinImp imp;
1282 ffeintrinSpec tspec;
1283 ffeintrinImp nimp = FFEINTRIN_impNONE;
1284 ffebad error;
1285 bool any = FALSE;
1286 bool highly_specific = FALSE;
1287 int i;
1288
1289 op = ffebld_op (*expr);
1290 assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
1291 assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
1292
1293 gen = ffebld_symter_generic (ffebld_left (*expr));
1294 assert (gen != FFEINTRIN_genNONE);
1295
1296 imp = FFEINTRIN_impNONE;
1297 error = FFEBAD;
1298
1299 any = ffeintrin_check_any_ (ffebld_right (*expr));
1300
1301 for (i = 0;
1302 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1303 && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE)
1304 && !any;
1305 ++i)
1306 {
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);
1313 ffebad terror;
1314
1315 if (state == FFE_intrinsicstateDELETED)
1316 continue;
1317
1318 if (timp != FFEINTRIN_impNONE)
1319 {
1320 if (!(ffeintrin_imps_[timp].control[0] == '-')
1321 != !(ffebld_op (*expr) == FFEBLD_opSUBRREF))
1322 continue; /* Form of reference must match form of specific. */
1323 }
1324
1325 if (state == FFE_intrinsicstateDISABLED)
1326 terror = FFEBAD_INTRINSIC_DISABLED;
1327 else if (timp == FFEINTRIN_impNONE)
1328 terror = FFEBAD_INTRINSIC_UNIMPL;
1329 else
1330 {
1331 terror = ffeintrin_check_ (timp, ffebld_op (*expr),
1332 ffebld_right (*expr),
1333 &tbt, &tkt, &tsz, NULL, t, FALSE);
1334 if (terror == FFEBAD)
1335 {
1336 if (imp != FFEINTRIN_impNONE)
1337 {
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);
1344 ffebad_finish ();
1345 }
1346 else
1347 {
1348 if (ffebld_symter_specific (ffebld_left (*expr))
1349 == tspec)
1350 highly_specific = TRUE;
1351 imp = timp;
1352 spec = tspec;
1353 bt = tbt;
1354 kt = tkt;
1355 sz = tkt;
1356 error = terror;
1357 }
1358 }
1359 else if (terror != FFEBAD)
1360 { /* This error has precedence over others. */
1361 if ((error == FFEBAD_INTRINSIC_DISABLED)
1362 || (error == FFEBAD_INTRINSIC_UNIMPL))
1363 error = FFEBAD;
1364 }
1365 }
1366
1367 if (error == FFEBAD)
1368 error = terror;
1369 }
1370
1371 if (any || (imp == FFEINTRIN_impNONE))
1372 {
1373 if (!any)
1374 {
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);
1381 ffebad_finish ();
1382 }
1383
1384 *expr = ffebld_new_any ();
1385 *info = ffeinfo_new_any ();
1386 }
1387 else
1388 {
1389 if (!highly_specific && (nimp != FFEINTRIN_impNONE))
1390 {
1391 fprintf (stderr, "lineno=%ld, gen=%s, imp=%s, timp=%s\n",
1392 (long) lineno,
1393 ffeintrin_gens_[gen].name,
1394 ffeintrin_imps_[imp].name,
1395 ffeintrin_imps_[nimp].name);
1396 assert ("Ambiguous generic reference" == NULL);
1397 abort ();
1398 }
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,
1404 kt,
1405 0,
1406 FFEINFO_kindENTITY,
1407 FFEINFO_whereFLEETING,
1408 sz);
1409 symter = ffebld_left (*expr);
1410 ffebld_symter_set_specific (symter, spec);
1411 ffebld_symter_set_implementation (symter, imp);
1412 ffebld_set_info (symter,
1413 ffeinfo_new (bt,
1414 kt,
1415 0,
1416 (bt == FFEINFO_basictypeNONE)
1417 ? FFEINFO_kindSUBROUTINE
1418 : FFEINFO_kindFUNCTION,
1419 FFEINFO_whereINTRINSIC,
1420 sz));
1421
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)))))))
1427 {
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);
1432 ffebad_finish ();
1433 }
1434 if (ffeintrin_imps_[imp].y2kbad)
1435 {
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);
1440 ffebad_finish ();
1441 }
1442 }
1443 }
1444
1445 /* Check and fill in info on func/subr ref node.
1446
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);
1453
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
1459 accordingly. */
1460
1461 void
ffeintrin_fulfill_specific(ffebld * expr,ffeinfo * info,bool * check_intrin,ffelexToken t)1462 ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
1463 bool *check_intrin, ffelexToken t)
1464 {
1465 ffebld symter;
1466 ffebldOp op;
1467 ffeintrinGen gen;
1468 ffeintrinSpec spec;
1469 ffeintrinImp imp;
1470 ffeinfoBasictype bt = FFEINFO_basictypeNONE;
1471 ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
1472 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
1473 ffeIntrinsicState state;
1474 ffebad error;
1475 bool any = FALSE;
1476 const char *name;
1477
1478 op = ffebld_op (*expr);
1479 assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
1480 assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
1481
1482 gen = ffebld_symter_generic (ffebld_left (*expr));
1483 spec = ffebld_symter_specific (ffebld_left (*expr));
1484 assert (spec != FFEINTRIN_specNONE);
1485
1486 if (gen != FFEINTRIN_genNONE)
1487 name = ffeintrin_gens_[gen].name;
1488 else
1489 name = ffeintrin_specs_[spec].name;
1490
1491 state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1492
1493 imp = ffeintrin_specs_[spec].implementation;
1494 if (check_intrin != NULL)
1495 *check_intrin = FALSE;
1496
1497 any = ffeintrin_check_any_ (ffebld_right (*expr));
1498
1499 if (state == FFE_intrinsicstateDISABLED)
1500 error = FFEBAD_INTRINSIC_DISABLED;
1501 else if (imp == FFEINTRIN_impNONE)
1502 error = FFEBAD_INTRINSIC_UNIMPL;
1503 else if (!any)
1504 {
1505 error = ffeintrin_check_ (imp, ffebld_op (*expr),
1506 ffebld_right (*expr),
1507 &bt, &kt, &sz, check_intrin, t, TRUE);
1508 }
1509 else
1510 error = FFEBAD; /* Not really needed, but quiet -Wuninitialized. */
1511
1512 if (any || (error != FFEBAD))
1513 {
1514 if (!any)
1515 {
1516
1517 ffebad_start (error);
1518 ffebad_here (0, ffelex_token_where_line (t),
1519 ffelex_token_where_column (t));
1520 ffebad_string (name);
1521 ffebad_finish ();
1522 }
1523
1524 *expr = ffebld_new_any ();
1525 *info = ffeinfo_new_any ();
1526 }
1527 else
1528 {
1529 *info = ffeinfo_new (bt,
1530 kt,
1531 0,
1532 FFEINFO_kindENTITY,
1533 FFEINFO_whereFLEETING,
1534 sz);
1535 symter = ffebld_left (*expr);
1536 ffebld_set_info (symter,
1537 ffeinfo_new (bt,
1538 kt,
1539 0,
1540 (bt == FFEINFO_basictypeNONE)
1541 ? FFEINFO_kindSUBROUTINE
1542 : FFEINFO_kindFUNCTION,
1543 FFEINFO_whereINTRINSIC,
1544 sz));
1545
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))))))
1550 {
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);
1555 ffebad_finish ();
1556 }
1557 if (ffeintrin_imps_[imp].y2kbad)
1558 {
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);
1563 ffebad_finish ();
1564 }
1565 }
1566 }
1567
1568 /* Return run-time index of intrinsic implementation as direct call. */
1569
1570 ffecomGfrt
ffeintrin_gfrt_direct(ffeintrinImp imp)1571 ffeintrin_gfrt_direct (ffeintrinImp imp)
1572 {
1573 assert (imp < FFEINTRIN_imp);
1574
1575 return ffeintrin_imps_[imp].gfrt_direct;
1576 }
1577
1578 /* Return run-time index of intrinsic implementation as actual argument. */
1579
1580 ffecomGfrt
ffeintrin_gfrt_indirect(ffeintrinImp imp)1581 ffeintrin_gfrt_indirect (ffeintrinImp imp)
1582 {
1583 assert (imp < FFEINTRIN_imp);
1584
1585 if (! ffe_is_f2c ())
1586 return ffeintrin_imps_[imp].gfrt_gnu;
1587 return ffeintrin_imps_[imp].gfrt_f2c;
1588 }
1589
1590 void
ffeintrin_init_0()1591 ffeintrin_init_0 ()
1592 {
1593 int i;
1594 const char *p1;
1595 const char *p2;
1596 const char *p3;
1597 int colon;
1598
1599 if (!ffe_is_do_internal_checks ())
1600 return;
1601
1602 assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_));
1603 assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_));
1604 assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_));
1605
1606 for (i = 1; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
1607 { /* Make sure binary-searched list is in alpha
1608 order. */
1609 if (strcmp (ffeintrin_names_[i - 1].name_uc,
1610 ffeintrin_names_[i].name_uc) >= 0)
1611 assert ("name list out of order" == NULL);
1612 }
1613
1614 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
1615 {
1616 assert ((ffeintrin_names_[i].generic == FFEINTRIN_genNONE)
1617 || (ffeintrin_names_[i].specific == FFEINTRIN_specNONE));
1618
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)
1623 {
1624 if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
1625 continue;
1626 if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2)
1627 || (*p1 != TOUPPER (*p2))
1628 || ((*p3 != *p1) && (*p3 != *p2)))
1629 break;
1630 }
1631 assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
1632 }
1633
1634 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i)
1635 {
1636 const char *c = ffeintrin_imps_[i].control;
1637
1638 if (c[0] == '\0')
1639 continue;
1640
1641 if ((c[0] != '-')
1642 && (c[0] != 'A')
1643 && (c[0] != 'C')
1644 && (c[0] != 'I')
1645 && (c[0] != 'L')
1646 && (c[0] != 'R')
1647 && (c[0] != 'B')
1648 && (c[0] != 'F')
1649 && (c[0] != 'N')
1650 && (c[0] != 'S'))
1651 {
1652 fprintf (stderr, "%s: bad return-base-type\n",
1653 ffeintrin_imps_[i].name);
1654 continue;
1655 }
1656 if ((c[1] != '-')
1657 && (c[1] != '=')
1658 && ((c[1] < '1')
1659 || (c[1] > '9'))
1660 && (c[1] != 'C'))
1661 {
1662 fprintf (stderr, "%s: bad return-kind-type\n",
1663 ffeintrin_imps_[i].name);
1664 continue;
1665 }
1666 if (c[2] == ':')
1667 colon = 2;
1668 else
1669 {
1670 if (c[2] != '*')
1671 {
1672 fprintf (stderr, "%s: bad return-modifier\n",
1673 ffeintrin_imps_[i].name);
1674 continue;
1675 }
1676 colon = 3;
1677 }
1678 if ((c[colon] != ':') || (c[colon + 2] != ':'))
1679 {
1680 fprintf (stderr, "%s: bad control\n",
1681 ffeintrin_imps_[i].name);
1682 continue;
1683 }
1684 if ((c[colon + 1] != '-')
1685 && (c[colon + 1] != '*')
1686 && (! ISDIGIT (c[colon + 1])))
1687 {
1688 fprintf (stderr, "%s: bad COL-spec\n",
1689 ffeintrin_imps_[i].name);
1690 continue;
1691 }
1692 c += (colon + 3);
1693 while (c[0] != '\0')
1694 {
1695 while ((c[0] != '=')
1696 && (c[0] != ',')
1697 && (c[0] != '\0'))
1698 ++c;
1699 if (c[0] != '=')
1700 {
1701 fprintf (stderr, "%s: bad keyword\n",
1702 ffeintrin_imps_[i].name);
1703 break;
1704 }
1705 if ((c[1] == '?')
1706 || (c[1] == '!')
1707 || (c[1] == '+')
1708 || (c[1] == '*')
1709 || (c[1] == 'n')
1710 || (c[1] == 'p'))
1711 ++c;
1712 if ((c[1] != '-')
1713 && (c[1] != 'A')
1714 && (c[1] != 'C')
1715 && (c[1] != 'I')
1716 && (c[1] != 'L')
1717 && (c[1] != 'R')
1718 && (c[1] != 'B')
1719 && (c[1] != 'F')
1720 && (c[1] != 'N')
1721 && (c[1] != 'S')
1722 && (c[1] != 'g')
1723 && (c[1] != 's'))
1724 {
1725 fprintf (stderr, "%s: bad arg-base-type\n",
1726 ffeintrin_imps_[i].name);
1727 break;
1728 }
1729 if ((c[2] != '*')
1730 && ((c[2] < '1')
1731 || (c[2] > '9'))
1732 && (c[2] != 'A'))
1733 {
1734 fprintf (stderr, "%s: bad arg-kind-type\n",
1735 ffeintrin_imps_[i].name);
1736 break;
1737 }
1738 if (c[3] == '[')
1739 {
1740 if ((! ISDIGIT (c[4]))
1741 || ((c[5] != ']')
1742 && (++c, ! ISDIGIT (c[4])
1743 || (c[5] != ']'))))
1744 {
1745 fprintf (stderr, "%s: bad arg-len\n",
1746 ffeintrin_imps_[i].name);
1747 break;
1748 }
1749 c += 3;
1750 }
1751 if (c[3] == '(')
1752 {
1753 if ((! ISDIGIT (c[4]))
1754 || ((c[5] != ')')
1755 && (++c, ! ISDIGIT (c[4])
1756 || (c[5] != ')'))))
1757 {
1758 fprintf (stderr, "%s: bad arg-rank\n",
1759 ffeintrin_imps_[i].name);
1760 break;
1761 }
1762 c += 3;
1763 }
1764 else if ((c[3] == '&')
1765 && (c[4] == '&'))
1766 ++c;
1767 if ((c[3] == '&')
1768 || (c[3] == 'i')
1769 || (c[3] == 'w')
1770 || (c[3] == 'x'))
1771 ++c;
1772 if (c[3] == ',')
1773 {
1774 c += 4;
1775 continue;
1776 }
1777 if (c[3] != '\0')
1778 {
1779 fprintf (stderr, "%s: bad arg-list\n",
1780 ffeintrin_imps_[i].name);
1781 }
1782 break;
1783 }
1784 }
1785 }
1786
1787 /* Determine whether intrinsic is okay as an actual argument. */
1788
1789 bool
ffeintrin_is_actualarg(ffeintrinSpec spec)1790 ffeintrin_is_actualarg (ffeintrinSpec spec)
1791 {
1792 ffeIntrinsicState state;
1793
1794 if (spec >= FFEINTRIN_spec)
1795 return FALSE;
1796
1797 state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1798
1799 return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
1800 && (ffe_is_f2c ()
1801 ? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
1802 != FFECOM_gfrt)
1803 : (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
1804 != FFECOM_gfrt))
1805 && ((state == FFE_intrinsicstateENABLED)
1806 || (state == FFE_intrinsicstateHIDDEN));
1807 }
1808
1809 /* Determine if name is intrinsic, return info.
1810
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,
1818 &gen, &spec, &imp))
1819 // is an intrinsic, use gen, spec, imp, and
1820 // kind accordingly. */
1821
1822 bool
ffeintrin_is_intrinsic(const char * name,ffelexToken t,bool explicit,ffeintrinGen * xgen,ffeintrinSpec * xspec,ffeintrinImp * ximp)1823 ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
1824 ffeintrinGen *xgen, ffeintrinSpec *xspec,
1825 ffeintrinImp *ximp)
1826 {
1827 struct _ffeintrin_name_ *intrinsic;
1828 ffeintrinGen gen;
1829 ffeintrinSpec spec;
1830 ffeintrinImp imp;
1831 ffeIntrinsicState state;
1832 bool disabled = FALSE;
1833 bool unimpl = FALSE;
1834
1835 intrinsic = bsearch (name, &ffeintrin_names_[0],
1836 ARRAY_SIZE (ffeintrin_names_),
1837 sizeof (struct _ffeintrin_name_),
1838 (void *) ffeintrin_cmp_name_);
1839
1840 if (intrinsic == NULL)
1841 return FALSE;
1842
1843 gen = intrinsic->generic;
1844 spec = intrinsic->specific;
1845 imp = ffeintrin_specs_[spec].implementation;
1846
1847 /* Generic is okay only if at least one of its specifics is okay. */
1848
1849 if (gen != FFEINTRIN_genNONE)
1850 {
1851 int i;
1852 ffeintrinSpec tspec;
1853 bool ok = FALSE;
1854
1855 name = ffeintrin_gens_[gen].name;
1856
1857 for (i = 0;
1858 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1859 && ((tspec
1860 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1861 ++i)
1862 {
1863 state = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
1864
1865 if (state == FFE_intrinsicstateDELETED)
1866 continue;
1867
1868 if (state == FFE_intrinsicstateDISABLED)
1869 {
1870 disabled = TRUE;
1871 continue;
1872 }
1873
1874 if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE)
1875 {
1876 unimpl = TRUE;
1877 continue;
1878 }
1879
1880 if ((state == FFE_intrinsicstateENABLED)
1881 || (explicit
1882 && (state == FFE_intrinsicstateHIDDEN)))
1883 {
1884 ok = TRUE;
1885 break;
1886 }
1887 }
1888 if (!ok)
1889 gen = FFEINTRIN_genNONE;
1890 }
1891
1892 /* Specific is okay only if not: unimplemented, disabled, deleted, or
1893 hidden and not explicit. */
1894
1895 if (spec != FFEINTRIN_specNONE)
1896 {
1897 if (gen != FFEINTRIN_genNONE)
1898 name = ffeintrin_gens_[gen].name;
1899 else
1900 name = ffeintrin_specs_[spec].name;
1901
1902 if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family))
1903 == FFE_intrinsicstateDELETED)
1904 || (!explicit
1905 && (state == FFE_intrinsicstateHIDDEN)))
1906 spec = FFEINTRIN_specNONE;
1907 else if (state == FFE_intrinsicstateDISABLED)
1908 {
1909 disabled = TRUE;
1910 spec = FFEINTRIN_specNONE;
1911 }
1912 else if (imp == FFEINTRIN_impNONE)
1913 {
1914 unimpl = TRUE;
1915 spec = FFEINTRIN_specNONE;
1916 }
1917 }
1918
1919 /* If neither is okay, not an intrinsic. */
1920
1921 if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
1922 {
1923 /* Here is where we produce a diagnostic about a reference to a
1924 disabled or unimplemented intrinsic, if the diagnostic is desired. */
1925
1926 if ((disabled || unimpl)
1927 && (t != NULL))
1928 {
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);
1934 ffebad_finish ();
1935 }
1936
1937 return FALSE;
1938 }
1939
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. */
1943
1944 if (spec == FFEINTRIN_specNONE)
1945 {
1946 int i;
1947 ffeintrinSpec tspec;
1948 ffeintrinImp timp;
1949 bool at_least_one_ok = FALSE;
1950
1951 for (i = 0;
1952 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1953 && ((tspec
1954 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1955 ++i)
1956 {
1957 if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family))
1958 == FFE_intrinsicstateDELETED)
1959 || (state == FFE_intrinsicstateDISABLED))
1960 continue;
1961
1962 if ((timp = ffeintrin_specs_[tspec].implementation)
1963 == FFEINTRIN_impNONE)
1964 continue;
1965
1966 at_least_one_ok = TRUE;
1967 break;
1968 }
1969
1970 if (!at_least_one_ok)
1971 {
1972 *xgen = FFEINTRIN_genNONE;
1973 *xspec = FFEINTRIN_specNONE;
1974 *ximp = FFEINTRIN_impNONE;
1975 return FALSE;
1976 }
1977 }
1978
1979 *xgen = gen;
1980 *xspec = spec;
1981 *ximp = imp;
1982 return TRUE;
1983 }
1984
1985 /* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90). */
1986
1987 bool
ffeintrin_is_standard(ffeintrinGen gen,ffeintrinSpec spec)1988 ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec)
1989 {
1990 if (spec == FFEINTRIN_specNONE)
1991 {
1992 if (gen == FFEINTRIN_genNONE)
1993 return FALSE;
1994
1995 spec = ffeintrin_gens_[gen].specs[0];
1996 if (spec == FFEINTRIN_specNONE)
1997 return FALSE;
1998 }
1999
2000 if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77)
2001 || (ffe_is_90 ()
2002 && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90)
2003 || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL)
2004 || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC))))
2005 return TRUE;
2006 return FALSE;
2007 }
2008
2009 /* Return kind type of intrinsic implementation. See ffeintrin_basictype,
2010 its sibling. */
2011
2012 ffeinfoKindtype
ffeintrin_kindtype(ffeintrinSpec spec)2013 ffeintrin_kindtype (ffeintrinSpec spec)
2014 {
2015 ffeintrinImp imp;
2016 ffecomGfrt gfrt;
2017
2018 assert (spec < FFEINTRIN_spec);
2019 imp = ffeintrin_specs_[spec].implementation;
2020 assert (imp < FFEINTRIN_imp);
2021
2022 if (ffe_is_f2c ())
2023 gfrt = ffeintrin_imps_[imp].gfrt_f2c;
2024 else
2025 gfrt = ffeintrin_imps_[imp].gfrt_gnu;
2026
2027 assert (gfrt != FFECOM_gfrt);
2028
2029 return ffecom_gfrt_kindtype (gfrt);
2030 }
2031
2032 /* Return name of generic intrinsic. */
2033
2034 const char *
ffeintrin_name_generic(ffeintrinGen gen)2035 ffeintrin_name_generic (ffeintrinGen gen)
2036 {
2037 assert (gen < FFEINTRIN_gen);
2038 return ffeintrin_gens_[gen].name;
2039 }
2040
2041 /* Return name of intrinsic implementation. */
2042
2043 const char *
ffeintrin_name_implementation(ffeintrinImp imp)2044 ffeintrin_name_implementation (ffeintrinImp imp)
2045 {
2046 assert (imp < FFEINTRIN_imp);
2047 return ffeintrin_imps_[imp].name;
2048 }
2049
2050 /* Return external/internal name of specific intrinsic. */
2051
2052 const char *
ffeintrin_name_specific(ffeintrinSpec spec)2053 ffeintrin_name_specific (ffeintrinSpec spec)
2054 {
2055 assert (spec < FFEINTRIN_spec);
2056 return ffeintrin_specs_[spec].name;
2057 }
2058
2059 /* Return state of family. */
2060
2061 ffeIntrinsicState
ffeintrin_state_family(ffeintrinFamily family)2062 ffeintrin_state_family (ffeintrinFamily family)
2063 {
2064 ffeIntrinsicState state;
2065
2066 switch (family)
2067 {
2068 case FFEINTRIN_familyNONE:
2069 return FFE_intrinsicstateDELETED;
2070
2071 case FFEINTRIN_familyF77:
2072 return FFE_intrinsicstateENABLED;
2073
2074 case FFEINTRIN_familyASC:
2075 state = ffe_intrinsic_state_f2c ();
2076 state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2077 return state;
2078
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 ());
2083 return state;
2084
2085 case FFEINTRIN_familyGNU:
2086 state = ffe_intrinsic_state_gnu ();
2087 return state;
2088
2089 case FFEINTRIN_familyF90:
2090 state = ffe_intrinsic_state_f90 ();
2091 return state;
2092
2093 case FFEINTRIN_familyVXT:
2094 state = ffe_intrinsic_state_vxt ();
2095 return state;
2096
2097 case FFEINTRIN_familyFVZ:
2098 state = ffe_intrinsic_state_f2c ();
2099 state = ffe_state_max (state, ffe_intrinsic_state_vxt ());
2100 return state;
2101
2102 case FFEINTRIN_familyF2C:
2103 state = ffe_intrinsic_state_f2c ();
2104 return state;
2105
2106 case FFEINTRIN_familyF2U:
2107 state = ffe_intrinsic_state_unix ();
2108 return state;
2109
2110 case FFEINTRIN_familyBADU77:
2111 state = ffe_intrinsic_state_badu77 ();
2112 return state;
2113
2114 default:
2115 assert ("bad family" == NULL);
2116 return FFE_intrinsicstateDELETED;
2117 }
2118 }
2119