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