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