?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* gcc.c (option_map): Remove --version.
[official-gcc.git] / gcc / f / intrin.c
blob393706aa3318d41d21b9ea0b7b196d05d040dd39
1 /* intrin.c -- Recognize references to intrinsics
2 Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 */
23
24 #include "proj.h"
25 #include "intrin.h"
26 #include "expr.h"
27 #include "info.h"
28 #include "src.h"
29 #include "symbol.h"
30 #include "target.h"
31 #include "top.h"
32
33 struct _ffeintrin_name_
34 {
35 const char *const name_uc;
36 const char *const name_lc;
37 const char *const name_ic;
38 const ffeintrinGen generic;
39 const ffeintrinSpec specific;
40 };
41
42 struct _ffeintrin_gen_
43 {
44 const char *const name; /* Name as seen in program. */
45 const ffeintrinSpec specs[2];
46 };
47
48 struct _ffeintrin_spec_
49 {
50 const char *const name; /* Uppercase name as seen in source code,
51 lowercase if no source name, "none" if no
52 name at all (NONE case). */
53 const bool is_actualarg; /* Ok to pass as actual arg if -pedantic. */
54 const ffeintrinFamily family;
55 const ffeintrinImp implementation;
56 };
57
58 struct _ffeintrin_imp_
59 {
60 const char *const name; /* Name of implementation. */
61 const ffecomGfrt gfrt_direct;/* library routine, direct-callable form. */
62 const ffecomGfrt gfrt_f2c; /* library routine, f2c-callable form. */
63 const ffecomGfrt gfrt_gnu; /* library routine, gnu-callable form. */
64 const char *const control;
65 const char y2kbad;
66 };
67
68 static ffebad ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
69 ffebld args, ffeinfoBasictype *xbt,
70 ffeinfoKindtype *xkt,
71 ffetargetCharacterSize *xsz,
72 bool *check_intrin,
73 ffelexToken t,
74 bool commit);
75 static bool ffeintrin_check_any_ (ffebld arglist);
76 static int ffeintrin_cmp_name_ (const void *name, const void *intrinsic);
77
78 static const struct _ffeintrin_name_ ffeintrin_names_[]
79 =
80 { /* Alpha order. */
81 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC) \
82 { UPPER, LOWER, MIXED, FFEINTRIN_ ## GEN, FFEINTRIN_ ## SPEC },
83 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
84 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
85 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
86 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
87 #include "intrin.def"
88 #undef DEFNAME
89 #undef DEFGEN
90 #undef DEFSPEC
91 #undef DEFIMP
92 #undef DEFIMPY
93 };
94
95 static const struct _ffeintrin_gen_ ffeintrin_gens_[]
96 =
97 {
98 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
99 #define DEFGEN(CODE,NAME,SPEC1,SPEC2) \
100 { NAME, { SPEC1, SPEC2, }, },
101 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
102 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
103 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
104 #include "intrin.def"
105 #undef DEFNAME
106 #undef DEFGEN
107 #undef DEFSPEC
108 #undef DEFIMP
109 #undef DEFIMPY
110 };
111
112 static const struct _ffeintrin_imp_ ffeintrin_imps_[]
113 =
114 {
115 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
116 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
117 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP)
118 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL) \
119 { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
120 FFECOM_gfrt ## GFRTGNU, CONTROL, FALSE },
121 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD) \
122 { NAME, FFECOM_gfrt ## GFRTDIRECT, FFECOM_gfrt ## GFRTF2C, \
123 FFECOM_gfrt ## GFRTGNU, CONTROL, Y2KBAD },
124 #include "intrin.def"
125 #undef DEFNAME
126 #undef DEFGEN
127 #undef DEFSPEC
128 #undef DEFIMP
129 #undef DEFIMPY
130 };
131
132 static const struct _ffeintrin_spec_ ffeintrin_specs_[]
133 =
134 {
135 #define DEFNAME(UPPER,LOWER,MIXED,GEN,SPEC)
136 #define DEFGEN(CODE,NAME,SPEC1,SPEC2)
137 #define DEFSPEC(CODE,NAME,CALLABLE,FAMILY,IMP) \
138 { NAME, CALLABLE, FAMILY, IMP, },
139 #define DEFIMP(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL)
140 #define DEFIMPY(CODE,NAME,GFRTDIRECT,GFRTF2C,GFRTGNU,CONTROL,Y2KBAD)
141 #include "intrin.def"
142 #undef DEFGEN
143 #undef DEFSPEC
144 #undef DEFIMP
145 #undef DEFIMPY
146 };
147 \f
148
149 static ffebad
150 ffeintrin_check_ (ffeintrinImp imp, ffebldOp op,
151 ffebld args, ffeinfoBasictype *xbt,
152 ffeinfoKindtype *xkt,
153 ffetargetCharacterSize *xsz,
154 bool *check_intrin,
155 ffelexToken t,
156 bool commit)
157 {
158 const char *c = ffeintrin_imps_[imp].control;
159 bool subr = (c[0] == '-');
160 const char *argc;
161 ffebld arg;
162 ffeinfoBasictype bt;
163 ffeinfoKindtype kt;
164 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
165 ffeinfoKindtype firstarg_kt;
166 bool need_col;
167 ffeinfoBasictype col_bt = FFEINFO_basictypeNONE;
168 ffeinfoKindtype col_kt = FFEINFO_kindtypeNONE;
169 int colon = (c[2] == ':') ? 2 : 3;
170 int argno;
171
172 /* Check procedure type (function vs. subroutine) against
173 invocation. */
174
175 if (op == FFEBLD_opSUBRREF)
176 {
177 if (!subr)
178 return FFEBAD_INTRINSIC_IS_FUNC;
179 }
180 else if (op == FFEBLD_opFUNCREF)
181 {
182 if (subr)
183 return FFEBAD_INTRINSIC_IS_SUBR;
184 }
185 else
186 return FFEBAD_INTRINSIC_REF;
187
188 /* Check the arglist for validity. */
189
190 if ((args != NULL)
191 && (ffebld_head (args) != NULL))
192 firstarg_kt = ffeinfo_kindtype (ffebld_info (ffebld_head (args)));
193 else
194 firstarg_kt = FFEINFO_kindtype;
195
196 for (argc = &c[colon + 3],
197 arg = args;
198 *argc != '\0';
199 )
200 {
201 char optional = '\0';
202 char required = '\0';
203 char extra = '\0';
204 char basic;
205 char kind;
206 int length;
207 int elements;
208 bool lastarg_complex = FALSE;
209
210 /* We don't do anything with keywords yet. */
211 do
212 {
213 } while (*(++argc) != '=');
214
215 ++argc;
216 if ((*argc == '?')
217 || (*argc == '!')
218 || (*argc == '*'))
219 optional = *(argc++);
220 if ((*argc == '+')
221 || (*argc == 'n')
222 || (*argc == 'p'))
223 required = *(argc++);
224 basic = *(argc++);
225 kind = *(argc++);
226 if (*argc == '[')
227 {
228 length = *++argc - '0';
229 if (*++argc != ']')
230 length = 10 * length + (*(argc++) - '0');
231 ++argc;
232 }
233 else
234 length = -1;
235 if (*argc == '(')
236 {
237 elements = *++argc - '0';
238 if (*++argc != ')')
239 elements = 10 * elements + (*(argc++) - '0');
240 ++argc;
241 }
242 else if (*argc == '&')
243 {
244 elements = -1;
245 ++argc;
246 }
247 else
248 elements = 0;
249 if ((*argc == '&')
250 || (*argc == 'i')
251 || (*argc == 'w')
252 || (*argc == 'x'))
253 extra = *(argc++);
254 if (*argc == ',')
255 ++argc;
256
257 /* Break out of this loop only when current arg spec completely
258 processed. */
259
260 do
261 {
262 bool okay;
263 ffebld a;
264 ffeinfo i;
265 bool anynum;
266 ffeinfoBasictype abt = FFEINFO_basictypeNONE;
267 ffeinfoKindtype akt = FFEINFO_kindtypeNONE;
268
269 if ((arg == NULL)
270 || (ffebld_head (arg) == NULL))
271 {
272 if (required != '\0')
273 return FFEBAD_INTRINSIC_TOOFEW;
274 if (optional == '\0')
275 return FFEBAD_INTRINSIC_TOOFEW;
276 if (arg != NULL)
277 arg = ffebld_trail (arg);
278 break; /* Try next argspec. */
279 }
280
281 a = ffebld_head (arg);
282 i = ffebld_info (a);
283 anynum = (ffeinfo_basictype (i) == FFEINFO_basictypeHOLLERITH)
284 || (ffeinfo_basictype (i) == FFEINFO_basictypeTYPELESS);
285
286 /* See how well the arg matches up to the spec. */
287
288 switch (basic)
289 {
290 case 'A':
291 okay = (ffeinfo_basictype (i) == FFEINFO_basictypeCHARACTER)
292 && ((length == -1)
293 || (ffeinfo_size (i) == (ffetargetCharacterSize) length));
294 break;
295
296 case 'C':
297 okay = anynum
298 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
299 abt = FFEINFO_basictypeCOMPLEX;
300 break;
301
302 case 'I':
303 okay = anynum
304 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER);
305 abt = FFEINFO_basictypeINTEGER;
306 break;
307
308 case 'L':
309 okay = anynum
310 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
311 abt = FFEINFO_basictypeLOGICAL;
312 break;
313
314 case 'R':
315 okay = anynum
316 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
317 abt = FFEINFO_basictypeREAL;
318 break;
319
320 case 'B':
321 okay = anynum
322 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
323 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL);
324 break;
325
326 case 'F':
327 okay = anynum
328 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
329 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
330 break;
331
332 case 'N':
333 okay = anynum
334 || (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX)
335 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
336 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
337 break;
338
339 case 'S':
340 okay = anynum
341 || (ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
342 || (ffeinfo_basictype (i) == FFEINFO_basictypeREAL);
343 break;
344
345 case 'g':
346 okay = ((ffebld_op (a) == FFEBLD_opLABTER)
347 || (ffebld_op (a) == FFEBLD_opLABTOK));
348 elements = -1;
349 extra = '-';
350 break;
351
352 case 's':
353 okay = (((((ffeinfo_basictype (i) == FFEINFO_basictypeNONE)
354 && (ffeinfo_kindtype (i) == FFEINFO_kindtypeNONE)
355 && (ffeinfo_kind (i) == FFEINFO_kindSUBROUTINE))
356 || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
357 && (ffeinfo_kindtype (i) == FFEINFO_kindtypeINTEGERDEFAULT)
358 && (ffeinfo_kind (i) == FFEINFO_kindFUNCTION))
359 || (ffeinfo_kind (i) == FFEINFO_kindNONE))
360 && ((ffeinfo_where (i) == FFEINFO_whereDUMMY)
361 || (ffeinfo_where (i) == FFEINFO_whereGLOBAL)))
362 || ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
363 && (ffeinfo_kind (i) == FFEINFO_kindENTITY)));
364 elements = -1;
365 extra = '-';
366 break;
367
368 case '-':
369 default:
370 okay = TRUE;
371 break;
372 }
373
374 switch (kind)
375 {
376 case '1': case '2': case '3': case '4': case '5':
377 case '6': case '7': case '8': case '9':
378 akt = (kind - '0');
379 if ((ffeinfo_basictype (i) == FFEINFO_basictypeINTEGER)
380 || (ffeinfo_basictype (i) == FFEINFO_basictypeLOGICAL))
381 {
382 switch (akt)
383 { /* Translate to internal kinds for now! */
384 default:
385 break;
386
387 case 2:
388 akt = 4;
389 break;
390
391 case 3:
392 akt = 2;
393 break;
394
395 case 4:
396 akt = 5;
397 break;
398
399 case 6:
400 akt = 3;
401 break;
402
403 case 7:
404 akt = ffecom_pointer_kind ();
405 break;
406 }
407 }
408 okay &= anynum || (ffeinfo_kindtype (i) == akt);
409 break;
410
411 case 'A':
412 okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
413 akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
414 : firstarg_kt;
415 break;
416
417 case '*':
418 default:
419 break;
420 }
421
422 switch (elements)
423 {
424 ffebld b;
425
426 case -1:
427 break;
428
429 case 0:
430 if (ffeinfo_rank (i) != 0)
431 okay = FALSE;
432 break;
433
434 default:
435 if ((ffeinfo_rank (i) != 1)
436 || (ffebld_op (a) != FFEBLD_opSYMTER)
437 || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
438 || (ffebld_op (b) != FFEBLD_opCONTER)
439 || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
440 || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
441 || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
442 okay = FALSE;
443 break;
444 }
445
446 switch (extra)
447 {
448 case '&':
449 if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
450 || ((ffebld_op (a) != FFEBLD_opSYMTER)
451 && (ffebld_op (a) != FFEBLD_opSUBSTR)
452 && (ffebld_op (a) != FFEBLD_opARRAYREF)))
453 okay = FALSE;
454 break;
455
456 case 'w':
457 case 'x':
458 if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
459 || ((ffebld_op (a) != FFEBLD_opSYMTER)
460 && (ffebld_op (a) != FFEBLD_opARRAYREF)
461 && (ffebld_op (a) != FFEBLD_opSUBSTR)))
462 okay = FALSE;
463 break;
464
465 case '-':
466 case 'i':
467 break;
468
469 default:
470 if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
471 okay = FALSE;
472 break;
473 }
474
475 if ((optional == '!')
476 && lastarg_complex)
477 okay = FALSE;
478
479 if (!okay)
480 {
481 /* If it wasn't optional, it's an error,
482 else maybe it could match a later argspec. */
483 if (optional == '\0')
484 return FFEBAD_INTRINSIC_REF;
485 break; /* Try next argspec. */
486 }
487
488 lastarg_complex
489 = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
490
491 if (anynum)
492 {
493 /* If we know dummy arg type, convert to that now. */
494
495 if ((abt != FFEINFO_basictypeNONE)
496 && (akt != FFEINFO_kindtypeNONE)
497 && commit)
498 {
499 /* We have a known type, convert hollerith/typeless
500 to it. */
501
502 a = ffeexpr_convert (a, t, NULL,
503 abt, akt, 0,
504 FFETARGET_charactersizeNONE,
505 FFEEXPR_contextLET);
506 ffebld_set_head (arg, a);
507 }
508 }
509
510 arg = ffebld_trail (arg); /* Arg accepted, now move on. */
511
512 if (optional == '*')
513 continue; /* Go ahead and try another arg. */
514 if (required == '\0')
515 break;
516 if ((required == 'n')
517 || (required == '+'))
518 {
519 optional = '*';
520 required = '\0';
521 }
522 else if (required == 'p')
523 required = 'n';
524 } while (TRUE);
525 }
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 case 7:
598 kt = ffecom_pointer_kind ();
599 break;
600 }
601 }
602 break;
603
604 case 'C':
605 if (ffe_is_90 ())
606 need_col = TRUE;
607 kt = 1;
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 case 7:
996 akt = ffecom_pointer_kind ();
997 break;
998 }
999 }
1000 okay &= anynum || (ffeinfo_kindtype (i) == akt);
1001 break;
1002
1003 case 'A':
1004 okay &= anynum || (ffeinfo_kindtype (i) == firstarg_kt);
1005 akt = (firstarg_kt == FFEINFO_kindtype) ? FFEINFO_kindtypeNONE
1006 : firstarg_kt;
1007 break;
1008
1009 case '*':
1010 default:
1011 break;
1012 }
1013
1014 switch (elements)
1015 {
1016 ffebld b;
1017
1018 case -1:
1019 break;
1020
1021 case 0:
1022 if (ffeinfo_rank (i) != 0)
1023 okay = FALSE;
1024 break;
1025
1026 default:
1027 if ((ffeinfo_rank (i) != 1)
1028 || (ffebld_op (a) != FFEBLD_opSYMTER)
1029 || ((b = ffesymbol_arraysize (ffebld_symter (a))) == NULL)
1030 || (ffebld_op (b) != FFEBLD_opCONTER)
1031 || (ffeinfo_basictype (ffebld_info (b)) != FFEINFO_basictypeINTEGER)
1032 || (ffeinfo_kindtype (ffebld_info (b)) != FFEINFO_kindtypeINTEGERDEFAULT)
1033 || (ffebld_constant_integer1 (ffebld_conter (b)) != elements))
1034 okay = FALSE;
1035 break;
1036 }
1037
1038 switch (extra)
1039 {
1040 case '&':
1041 if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
1042 || ((ffebld_op (a) != FFEBLD_opSYMTER)
1043 && (ffebld_op (a) != FFEBLD_opSUBSTR)
1044 && (ffebld_op (a) != FFEBLD_opARRAYREF)))
1045 okay = FALSE;
1046 break;
1047
1048 case 'w':
1049 case 'x':
1050 if ((ffeinfo_kind (i) != FFEINFO_kindENTITY)
1051 || ((ffebld_op (a) != FFEBLD_opSYMTER)
1052 && (ffebld_op (a) != FFEBLD_opARRAYREF)
1053 && (ffebld_op (a) != FFEBLD_opSUBSTR)))
1054 okay = FALSE;
1055 break;
1056
1057 case '-':
1058 case 'i':
1059 break;
1060
1061 default:
1062 if (ffeinfo_kind (i) != FFEINFO_kindENTITY)
1063 okay = FALSE;
1064 break;
1065 }
1066
1067 if ((optional == '!')
1068 && lastarg_complex)
1069 okay = FALSE;
1070
1071 if (!okay)
1072 {
1073 /* If it wasn't optional, it's an error,
1074 else maybe it could match a later argspec. */
1075 if (optional == '\0')
1076 return FFEBAD_INTRINSIC_REF;
1077 break; /* Try next argspec. */
1078 }
1079
1080 lastarg_complex
1081 = (ffeinfo_basictype (i) == FFEINFO_basictypeCOMPLEX);
1082
1083 if (anynum && commit)
1084 {
1085 /* If we know dummy arg type, convert to that now. */
1086
1087 if (abt == FFEINFO_basictypeNONE)
1088 abt = FFEINFO_basictypeINTEGER;
1089 if (akt == FFEINFO_kindtypeNONE)
1090 akt = FFEINFO_kindtypeINTEGER1;
1091
1092 /* We have a known type, convert hollerith/typeless to it. */
1093
1094 a = ffeexpr_convert (a, t, NULL,
1095 abt, akt, 0,
1096 FFETARGET_charactersizeNONE,
1097 FFEEXPR_contextLET);
1098 ffebld_set_head (arg, a);
1099 }
1100 else if ((c[colon + 1] == '*') && commit)
1101 {
1102 /* This is where we promote types to the consensus
1103 type for the COL. Maybe this is where -fpedantic
1104 should issue a warning as well. */
1105
1106 a = ffeexpr_convert (a, t, NULL,
1107 col_bt, col_kt, 0,
1108 ffeinfo_size (i),
1109 FFEEXPR_contextLET);
1110 ffebld_set_head (arg, a);
1111 }
1112
1113 arg = ffebld_trail (arg); /* Arg accepted, now move on. */
1114
1115 if (optional == '*')
1116 continue; /* Go ahead and try another arg. */
1117 if (required == '\0')
1118 break;
1119 if ((required == 'n')
1120 || (required == '+'))
1121 {
1122 optional = '*';
1123 required = '\0';
1124 }
1125 else if (required == 'p')
1126 required = 'n';
1127 } while (TRUE);
1128 }
1129
1130 *xbt = bt;
1131 *xkt = kt;
1132 *xsz = sz;
1133 return FFEBAD;
1134 }
1135
1136 static bool
1137 ffeintrin_check_any_ (ffebld arglist)
1138 {
1139 ffebld item;
1140
1141 for (; arglist != NULL; arglist = ffebld_trail (arglist))
1142 {
1143 item = ffebld_head (arglist);
1144 if ((item != NULL)
1145 && (ffebld_op (item) == FFEBLD_opANY))
1146 return TRUE;
1147 }
1148
1149 return FALSE;
1150 }
1151
1152 /* Compare name to intrinsic's name. Uses strcmp on arguments' names. */
1153
1154 static int
1155 ffeintrin_cmp_name_ (const void *name, const void *intrinsic)
1156 {
1157 const char *const uc = ((const struct _ffeintrin_name_ *) intrinsic)->name_uc;
1158 const char *const lc = ((const struct _ffeintrin_name_ *) intrinsic)->name_lc;
1159 const char *const ic = ((const struct _ffeintrin_name_ *) intrinsic)->name_ic;
1160
1161 return ffesrc_strcmp_2c (ffe_case_intrin (), name, uc, lc, ic);
1162 }
1163
1164 /* Return basic type of intrinsic implementation, based on its
1165 run-time implementation *only*. (This is used only when
1166 the type of an intrinsic name is needed without having a
1167 list of arguments, i.e. an interface signature, such as when
1168 passing the intrinsic itself, or really the run-time-library
1169 function, as an argument.)
1170
1171 If there's no eligible intrinsic implementation, there must be
1172 a bug somewhere else; no such reference should have been permitted
1173 to go this far. (Well, this might be wrong.) */
1174
1175 ffeinfoBasictype
1176 ffeintrin_basictype (ffeintrinSpec spec)
1177 {
1178 ffeintrinImp imp;
1179 ffecomGfrt gfrt;
1180
1181 assert (spec < FFEINTRIN_spec);
1182 imp = ffeintrin_specs_[spec].implementation;
1183 assert (imp < FFEINTRIN_imp);
1184
1185 if (ffe_is_f2c ())
1186 gfrt = ffeintrin_imps_[imp].gfrt_f2c;
1187 else
1188 gfrt = ffeintrin_imps_[imp].gfrt_gnu;
1189
1190 assert (gfrt != FFECOM_gfrt);
1191
1192 return ffecom_gfrt_basictype (gfrt);
1193 }
1194
1195 /* Return family to which specific intrinsic belongs. */
1196
1197 ffeintrinFamily
1198 ffeintrin_family (ffeintrinSpec spec)
1199 {
1200 if (spec >= FFEINTRIN_spec)
1201 return FALSE;
1202 return ffeintrin_specs_[spec].family;
1203 }
1204
1205 /* Check and fill in info on func/subr ref node.
1206
1207 ffebld expr; // FUNCREF or SUBRREF with no info (caller
1208 // gets it from the modified info structure).
1209 ffeinfo info; // Already filled in, will be overwritten.
1210 ffelexToken token; // Used for error message.
1211 ffeintrin_fulfill_generic (&expr, &info, token);
1212
1213 Based on the generic id, figure out which specific procedure is meant and
1214 pick that one. Else return an error, a la _specific. */
1215
1216 void
1217 ffeintrin_fulfill_generic (ffebld *expr, ffeinfo *info, ffelexToken t)
1218 {
1219 ffebld symter;
1220 ffebldOp op;
1221 ffeintrinGen gen;
1222 ffeintrinSpec spec = FFEINTRIN_specNONE;
1223 ffeinfoBasictype bt = FFEINFO_basictypeNONE;
1224 ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
1225 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
1226 ffeintrinImp imp;
1227 ffeintrinSpec tspec;
1228 ffeintrinImp nimp = FFEINTRIN_impNONE;
1229 ffebad error;
1230 bool any = FALSE;
1231 bool highly_specific = FALSE;
1232 int i;
1233
1234 op = ffebld_op (*expr);
1235 assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
1236 assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
1237
1238 gen = ffebld_symter_generic (ffebld_left (*expr));
1239 assert (gen != FFEINTRIN_genNONE);
1240
1241 imp = FFEINTRIN_impNONE;
1242 error = FFEBAD;
1243
1244 any = ffeintrin_check_any_ (ffebld_right (*expr));
1245
1246 for (i = 0;
1247 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1248 && ((tspec = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE)
1249 && !any;
1250 ++i)
1251 {
1252 ffeintrinImp timp = ffeintrin_specs_[tspec].implementation;
1253 ffeinfoBasictype tbt;
1254 ffeinfoKindtype tkt;
1255 ffetargetCharacterSize tsz;
1256 ffeIntrinsicState state
1257 = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
1258 ffebad terror;
1259
1260 if (state == FFE_intrinsicstateDELETED)
1261 continue;
1262
1263 if (timp != FFEINTRIN_impNONE)
1264 {
1265 if (!(ffeintrin_imps_[timp].control[0] == '-')
1266 != !(ffebld_op (*expr) == FFEBLD_opSUBRREF))
1267 continue; /* Form of reference must match form of specific. */
1268 }
1269
1270 if (state == FFE_intrinsicstateDISABLED)
1271 terror = FFEBAD_INTRINSIC_DISABLED;
1272 else if (timp == FFEINTRIN_impNONE)
1273 terror = FFEBAD_INTRINSIC_UNIMPL;
1274 else
1275 {
1276 terror = ffeintrin_check_ (timp, ffebld_op (*expr),
1277 ffebld_right (*expr),
1278 &tbt, &tkt, &tsz, NULL, t, FALSE);
1279 if (terror == FFEBAD)
1280 {
1281 if (imp != FFEINTRIN_impNONE)
1282 {
1283 ffebad_start (FFEBAD_INTRINSIC_AMBIG);
1284 ffebad_here (0, ffelex_token_where_line (t),
1285 ffelex_token_where_column (t));
1286 ffebad_string (ffeintrin_gens_[gen].name);
1287 ffebad_string (ffeintrin_specs_[spec].name);
1288 ffebad_string (ffeintrin_specs_[tspec].name);
1289 ffebad_finish ();
1290 }
1291 else
1292 {
1293 if (ffebld_symter_specific (ffebld_left (*expr))
1294 == tspec)
1295 highly_specific = TRUE;
1296 imp = timp;
1297 spec = tspec;
1298 bt = tbt;
1299 kt = tkt;
1300 sz = tkt;
1301 error = terror;
1302 }
1303 }
1304 else if (terror != FFEBAD)
1305 { /* This error has precedence over others. */
1306 if ((error == FFEBAD_INTRINSIC_DISABLED)
1307 || (error == FFEBAD_INTRINSIC_UNIMPL))
1308 error = FFEBAD;
1309 }
1310 }
1311
1312 if (error == FFEBAD)
1313 error = terror;
1314 }
1315
1316 if (any || (imp == FFEINTRIN_impNONE))
1317 {
1318 if (!any)
1319 {
1320 if (error == FFEBAD)
1321 error = FFEBAD_INTRINSIC_REF;
1322 ffebad_start (error);
1323 ffebad_here (0, ffelex_token_where_line (t),
1324 ffelex_token_where_column (t));
1325 ffebad_string (ffeintrin_gens_[gen].name);
1326 ffebad_finish ();
1327 }
1328
1329 *expr = ffebld_new_any ();
1330 *info = ffeinfo_new_any ();
1331 }
1332 else
1333 {
1334 if (!highly_specific && (nimp != FFEINTRIN_impNONE))
1335 {
1336 fprintf (stderr, "lineno=%ld, gen=%s, imp=%s, timp=%s\n",
1337 (long) lineno,
1338 ffeintrin_gens_[gen].name,
1339 ffeintrin_imps_[imp].name,
1340 ffeintrin_imps_[nimp].name);
1341 assert ("Ambiguous generic reference" == NULL);
1342 abort ();
1343 }
1344 error = ffeintrin_check_ (imp, ffebld_op (*expr),
1345 ffebld_right (*expr),
1346 &bt, &kt, &sz, NULL, t, TRUE);
1347 assert (error == FFEBAD);
1348 *info = ffeinfo_new (bt,
1349 kt,
1350 0,
1351 FFEINFO_kindENTITY,
1352 FFEINFO_whereFLEETING,
1353 sz);
1354 symter = ffebld_left (*expr);
1355 ffebld_symter_set_specific (symter, spec);
1356 ffebld_symter_set_implementation (symter, imp);
1357 ffebld_set_info (symter,
1358 ffeinfo_new (bt,
1359 kt,
1360 0,
1361 (bt == FFEINFO_basictypeNONE)
1362 ? FFEINFO_kindSUBROUTINE
1363 : FFEINFO_kindFUNCTION,
1364 FFEINFO_whereINTRINSIC,
1365 sz));
1366
1367 if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
1368 && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
1369 || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
1370 || ((sz != FFETARGET_charactersizeNONE)
1371 && (sz != ffesymbol_size (ffebld_symter (symter)))))))
1372 {
1373 ffebad_start (FFEBAD_INTRINSIC_TYPE);
1374 ffebad_here (0, ffelex_token_where_line (t),
1375 ffelex_token_where_column (t));
1376 ffebad_string (ffeintrin_gens_[gen].name);
1377 ffebad_finish ();
1378 }
1379 if (ffeintrin_imps_[imp].y2kbad)
1380 {
1381 ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
1382 ffebad_here (0, ffelex_token_where_line (t),
1383 ffelex_token_where_column (t));
1384 ffebad_string (ffeintrin_gens_[gen].name);
1385 ffebad_finish ();
1386 }
1387 }
1388 }
1389
1390 /* Check and fill in info on func/subr ref node.
1391
1392 ffebld expr; // FUNCREF or SUBRREF with no info (caller
1393 // gets it from the modified info structure).
1394 ffeinfo info; // Already filled in, will be overwritten.
1395 bool check_intrin; // May be omitted, else set TRUE if intrinsic needs checking.
1396 ffelexToken token; // Used for error message.
1397 ffeintrin_fulfill_specific (&expr, &info, &check_intrin, token);
1398
1399 Based on the specific id, determine whether the arg list is valid
1400 (number, type, rank, and kind of args) and fill in the info structure
1401 accordingly. Currently don't rewrite the expression, but perhaps
1402 someday do so for constant collapsing, except when an error occurs,
1403 in which case it is overwritten with ANY and info is also overwritten
1404 accordingly. */
1405
1406 void
1407 ffeintrin_fulfill_specific (ffebld *expr, ffeinfo *info,
1408 bool *check_intrin, ffelexToken t)
1409 {
1410 ffebld symter;
1411 ffebldOp op;
1412 ffeintrinGen gen;
1413 ffeintrinSpec spec;
1414 ffeintrinImp imp;
1415 ffeinfoBasictype bt = FFEINFO_basictypeNONE;
1416 ffeinfoKindtype kt = FFEINFO_kindtypeNONE;
1417 ffetargetCharacterSize sz = FFETARGET_charactersizeNONE;
1418 ffeIntrinsicState state;
1419 ffebad error;
1420 bool any = FALSE;
1421 const char *name;
1422
1423 op = ffebld_op (*expr);
1424 assert ((op == FFEBLD_opFUNCREF) || (op == FFEBLD_opSUBRREF));
1425 assert (ffebld_op (ffebld_left (*expr)) == FFEBLD_opSYMTER);
1426
1427 gen = ffebld_symter_generic (ffebld_left (*expr));
1428 spec = ffebld_symter_specific (ffebld_left (*expr));
1429 assert (spec != FFEINTRIN_specNONE);
1430
1431 if (gen != FFEINTRIN_genNONE)
1432 name = ffeintrin_gens_[gen].name;
1433 else
1434 name = ffeintrin_specs_[spec].name;
1435
1436 state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1437
1438 imp = ffeintrin_specs_[spec].implementation;
1439 if (check_intrin != NULL)
1440 *check_intrin = FALSE;
1441
1442 any = ffeintrin_check_any_ (ffebld_right (*expr));
1443
1444 if (state == FFE_intrinsicstateDISABLED)
1445 error = FFEBAD_INTRINSIC_DISABLED;
1446 else if (imp == FFEINTRIN_impNONE)
1447 error = FFEBAD_INTRINSIC_UNIMPL;
1448 else if (!any)
1449 {
1450 error = ffeintrin_check_ (imp, ffebld_op (*expr),
1451 ffebld_right (*expr),
1452 &bt, &kt, &sz, check_intrin, t, TRUE);
1453 }
1454 else
1455 error = FFEBAD; /* Not really needed, but quiet -Wuninitialized. */
1456
1457 if (any || (error != FFEBAD))
1458 {
1459 if (!any)
1460 {
1461
1462 ffebad_start (error);
1463 ffebad_here (0, ffelex_token_where_line (t),
1464 ffelex_token_where_column (t));
1465 ffebad_string (name);
1466 ffebad_finish ();
1467 }
1468
1469 *expr = ffebld_new_any ();
1470 *info = ffeinfo_new_any ();
1471 }
1472 else
1473 {
1474 *info = ffeinfo_new (bt,
1475 kt,
1476 0,
1477 FFEINFO_kindENTITY,
1478 FFEINFO_whereFLEETING,
1479 sz);
1480 symter = ffebld_left (*expr);
1481 ffebld_set_info (symter,
1482 ffeinfo_new (bt,
1483 kt,
1484 0,
1485 (bt == FFEINFO_basictypeNONE)
1486 ? FFEINFO_kindSUBROUTINE
1487 : FFEINFO_kindFUNCTION,
1488 FFEINFO_whereINTRINSIC,
1489 sz));
1490
1491 if ((ffesymbol_attrs (ffebld_symter (symter)) & FFESYMBOL_attrsTYPE)
1492 && (((bt != ffesymbol_basictype (ffebld_symter (symter)))
1493 || (kt != ffesymbol_kindtype (ffebld_symter (symter)))
1494 || (sz != ffesymbol_size (ffebld_symter (symter))))))
1495 {
1496 ffebad_start (FFEBAD_INTRINSIC_TYPE);
1497 ffebad_here (0, ffelex_token_where_line (t),
1498 ffelex_token_where_column (t));
1499 ffebad_string (name);
1500 ffebad_finish ();
1501 }
1502 if (ffeintrin_imps_[imp].y2kbad)
1503 {
1504 ffebad_start (FFEBAD_INTRINSIC_Y2KBAD);
1505 ffebad_here (0, ffelex_token_where_line (t),
1506 ffelex_token_where_column (t));
1507 ffebad_string (name);
1508 ffebad_finish ();
1509 }
1510 }
1511 }
1512
1513 /* Return run-time index of intrinsic implementation as direct call. */
1514
1515 ffecomGfrt
1516 ffeintrin_gfrt_direct (ffeintrinImp imp)
1517 {
1518 assert (imp < FFEINTRIN_imp);
1519
1520 return ffeintrin_imps_[imp].gfrt_direct;
1521 }
1522
1523 /* Return run-time index of intrinsic implementation as actual argument. */
1524
1525 ffecomGfrt
1526 ffeintrin_gfrt_indirect (ffeintrinImp imp)
1527 {
1528 assert (imp < FFEINTRIN_imp);
1529
1530 if (! ffe_is_f2c ())
1531 return ffeintrin_imps_[imp].gfrt_gnu;
1532 return ffeintrin_imps_[imp].gfrt_f2c;
1533 }
1534
1535 void
1536 ffeintrin_init_0 ()
1537 {
1538 int i;
1539 const char *p1;
1540 const char *p2;
1541 const char *p3;
1542 int colon;
1543
1544 if (!ffe_is_do_internal_checks ())
1545 return;
1546
1547 assert (FFEINTRIN_gen == ARRAY_SIZE (ffeintrin_gens_));
1548 assert (FFEINTRIN_imp == ARRAY_SIZE (ffeintrin_imps_));
1549 assert (FFEINTRIN_spec == ARRAY_SIZE (ffeintrin_specs_));
1550
1551 for (i = 1; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
1552 { /* Make sure binary-searched list is in alpha
1553 order. */
1554 if (strcmp (ffeintrin_names_[i - 1].name_uc,
1555 ffeintrin_names_[i].name_uc) >= 0)
1556 assert ("name list out of order" == NULL);
1557 }
1558
1559 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_names_); ++i)
1560 {
1561 assert ((ffeintrin_names_[i].generic == FFEINTRIN_genNONE)
1562 || (ffeintrin_names_[i].specific == FFEINTRIN_specNONE));
1563
1564 p1 = ffeintrin_names_[i].name_uc;
1565 p2 = ffeintrin_names_[i].name_lc;
1566 p3 = ffeintrin_names_[i].name_ic;
1567 for (; *p1 != '\0' && *p2 != '\0' && *p3 != '\0'; ++p1, ++p2, ++p3)
1568 {
1569 if ((ISDIGIT (*p1) || (*p1 == '_')) && (*p1 == *p2) && (*p1 == *p3))
1570 continue;
1571 if (! ISUPPER ((unsigned char)*p1) || ! ISLOWER ((unsigned char)*p2)
1572 || (*p1 != TOUPPER (*p2))
1573 || ((*p3 != *p1) && (*p3 != *p2)))
1574 break;
1575 }
1576 assert ((*p1 == *p2) && (*p1 == *p3) && (*p1 == '\0'));
1577 }
1578
1579 for (i = 0; ((size_t) i) < ARRAY_SIZE (ffeintrin_imps_); ++i)
1580 {
1581 const char *c = ffeintrin_imps_[i].control;
1582
1583 if (c[0] == '\0')
1584 continue;
1585
1586 if ((c[0] != '-')
1587 && (c[0] != 'A')
1588 && (c[0] != 'C')
1589 && (c[0] != 'I')
1590 && (c[0] != 'L')
1591 && (c[0] != 'R')
1592 && (c[0] != 'B')
1593 && (c[0] != 'F')
1594 && (c[0] != 'N')
1595 && (c[0] != 'S'))
1596 {
1597 fprintf (stderr, "%s: bad return-base-type\n",
1598 ffeintrin_imps_[i].name);
1599 continue;
1600 }
1601 if ((c[1] != '-')
1602 && (c[1] != '=')
1603 && ((c[1] < '1')
1604 || (c[1] > '9'))
1605 && (c[1] != 'C'))
1606 {
1607 fprintf (stderr, "%s: bad return-kind-type\n",
1608 ffeintrin_imps_[i].name);
1609 continue;
1610 }
1611 if (c[2] == ':')
1612 colon = 2;
1613 else
1614 {
1615 if (c[2] != '*')
1616 {
1617 fprintf (stderr, "%s: bad return-modifier\n",
1618 ffeintrin_imps_[i].name);
1619 continue;
1620 }
1621 colon = 3;
1622 }
1623 if ((c[colon] != ':') || (c[colon + 2] != ':'))
1624 {
1625 fprintf (stderr, "%s: bad control\n",
1626 ffeintrin_imps_[i].name);
1627 continue;
1628 }
1629 if ((c[colon + 1] != '-')
1630 && (c[colon + 1] != '*')
1631 && (! ISDIGIT (c[colon + 1])))
1632 {
1633 fprintf (stderr, "%s: bad COL-spec\n",
1634 ffeintrin_imps_[i].name);
1635 continue;
1636 }
1637 c += (colon + 3);
1638 while (c[0] != '\0')
1639 {
1640 while ((c[0] != '=')
1641 && (c[0] != ',')
1642 && (c[0] != '\0'))
1643 ++c;
1644 if (c[0] != '=')
1645 {
1646 fprintf (stderr, "%s: bad keyword\n",
1647 ffeintrin_imps_[i].name);
1648 break;
1649 }
1650 if ((c[1] == '?')
1651 || (c[1] == '!')
1652 || (c[1] == '+')
1653 || (c[1] == '*')
1654 || (c[1] == 'n')
1655 || (c[1] == 'p'))
1656 ++c;
1657 if ((c[1] != '-')
1658 && (c[1] != 'A')
1659 && (c[1] != 'C')
1660 && (c[1] != 'I')
1661 && (c[1] != 'L')
1662 && (c[1] != 'R')
1663 && (c[1] != 'B')
1664 && (c[1] != 'F')
1665 && (c[1] != 'N')
1666 && (c[1] != 'S')
1667 && (c[1] != 'g')
1668 && (c[1] != 's'))
1669 {
1670 fprintf (stderr, "%s: bad arg-base-type\n",
1671 ffeintrin_imps_[i].name);
1672 break;
1673 }
1674 if ((c[2] != '*')
1675 && ((c[2] < '1')
1676 || (c[2] > '9'))
1677 && (c[2] != 'A'))
1678 {
1679 fprintf (stderr, "%s: bad arg-kind-type\n",
1680 ffeintrin_imps_[i].name);
1681 break;
1682 }
1683 if (c[3] == '[')
1684 {
1685 if ((! ISDIGIT (c[4]))
1686 || ((c[5] != ']')
1687 && (++c, ! ISDIGIT (c[4])
1688 || (c[5] != ']'))))
1689 {
1690 fprintf (stderr, "%s: bad arg-len\n",
1691 ffeintrin_imps_[i].name);
1692 break;
1693 }
1694 c += 3;
1695 }
1696 if (c[3] == '(')
1697 {
1698 if ((! ISDIGIT (c[4]))
1699 || ((c[5] != ')')
1700 && (++c, ! ISDIGIT (c[4])
1701 || (c[5] != ')'))))
1702 {
1703 fprintf (stderr, "%s: bad arg-rank\n",
1704 ffeintrin_imps_[i].name);
1705 break;
1706 }
1707 c += 3;
1708 }
1709 else if ((c[3] == '&')
1710 && (c[4] == '&'))
1711 ++c;
1712 if ((c[3] == '&')
1713 || (c[3] == 'i')
1714 || (c[3] == 'w')
1715 || (c[3] == 'x'))
1716 ++c;
1717 if (c[3] == ',')
1718 {
1719 c += 4;
1720 continue;
1721 }
1722 if (c[3] != '\0')
1723 {
1724 fprintf (stderr, "%s: bad arg-list\n",
1725 ffeintrin_imps_[i].name);
1726 }
1727 break;
1728 }
1729 }
1730 }
1731
1732 /* Determine whether intrinsic is okay as an actual argument. */
1733
1734 bool
1735 ffeintrin_is_actualarg (ffeintrinSpec spec)
1736 {
1737 ffeIntrinsicState state;
1738
1739 if (spec >= FFEINTRIN_spec)
1740 return FALSE;
1741
1742 state = ffeintrin_state_family (ffeintrin_specs_[spec].family);
1743
1744 return (!ffe_is_pedantic () || ffeintrin_specs_[spec].is_actualarg)
1745 && (ffe_is_f2c ()
1746 ? (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_f2c
1747 != FFECOM_gfrt)
1748 : (ffeintrin_imps_[ffeintrin_specs_[spec].implementation].gfrt_gnu
1749 != FFECOM_gfrt))
1750 && ((state == FFE_intrinsicstateENABLED)
1751 || (state == FFE_intrinsicstateHIDDEN));
1752 }
1753
1754 /* Determine if name is intrinsic, return info.
1755
1756 const char *name; // C-string name of possible intrinsic.
1757 ffelexToken t; // NULL if no diagnostic to be given.
1758 bool explicit; // TRUE if INTRINSIC name.
1759 ffeintrinGen gen; // (TRUE only) Generic id of intrinsic.
1760 ffeintrinSpec spec; // (TRUE only) Specific id of intrinsic.
1761 ffeintrinImp imp; // (TRUE only) Implementation id of intrinsic.
1762 if (ffeintrin_is_intrinsic (name, t, explicit,
1763 &gen, &spec, &imp))
1764 // is an intrinsic, use gen, spec, imp, and
1765 // kind accordingly. */
1766
1767 bool
1768 ffeintrin_is_intrinsic (const char *name, ffelexToken t, bool explicit,
1769 ffeintrinGen *xgen, ffeintrinSpec *xspec,
1770 ffeintrinImp *ximp)
1771 {
1772 struct _ffeintrin_name_ *intrinsic;
1773 ffeintrinGen gen;
1774 ffeintrinSpec spec;
1775 ffeintrinImp imp;
1776 ffeIntrinsicState state;
1777 bool disabled = FALSE;
1778 bool unimpl = FALSE;
1779
1780 intrinsic = bsearch (name, &ffeintrin_names_[0],
1781 ARRAY_SIZE (ffeintrin_names_),
1782 sizeof (struct _ffeintrin_name_),
1783 (void *) ffeintrin_cmp_name_);
1784
1785 if (intrinsic == NULL)
1786 return FALSE;
1787
1788 gen = intrinsic->generic;
1789 spec = intrinsic->specific;
1790 imp = ffeintrin_specs_[spec].implementation;
1791
1792 /* Generic is okay only if at least one of its specifics is okay. */
1793
1794 if (gen != FFEINTRIN_genNONE)
1795 {
1796 int i;
1797 ffeintrinSpec tspec;
1798 bool ok = FALSE;
1799
1800 name = ffeintrin_gens_[gen].name;
1801
1802 for (i = 0;
1803 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1804 && ((tspec
1805 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1806 ++i)
1807 {
1808 state = ffeintrin_state_family (ffeintrin_specs_[tspec].family);
1809
1810 if (state == FFE_intrinsicstateDELETED)
1811 continue;
1812
1813 if (state == FFE_intrinsicstateDISABLED)
1814 {
1815 disabled = TRUE;
1816 continue;
1817 }
1818
1819 if (ffeintrin_specs_[tspec].implementation == FFEINTRIN_impNONE)
1820 {
1821 unimpl = TRUE;
1822 continue;
1823 }
1824
1825 if ((state == FFE_intrinsicstateENABLED)
1826 || (explicit
1827 && (state == FFE_intrinsicstateHIDDEN)))
1828 {
1829 ok = TRUE;
1830 break;
1831 }
1832 }
1833 if (!ok)
1834 gen = FFEINTRIN_genNONE;
1835 }
1836
1837 /* Specific is okay only if not: unimplemented, disabled, deleted, or
1838 hidden and not explicit. */
1839
1840 if (spec != FFEINTRIN_specNONE)
1841 {
1842 if (gen != FFEINTRIN_genNONE)
1843 name = ffeintrin_gens_[gen].name;
1844 else
1845 name = ffeintrin_specs_[spec].name;
1846
1847 if (((state = ffeintrin_state_family (ffeintrin_specs_[spec].family))
1848 == FFE_intrinsicstateDELETED)
1849 || (!explicit
1850 && (state == FFE_intrinsicstateHIDDEN)))
1851 spec = FFEINTRIN_specNONE;
1852 else if (state == FFE_intrinsicstateDISABLED)
1853 {
1854 disabled = TRUE;
1855 spec = FFEINTRIN_specNONE;
1856 }
1857 else if (imp == FFEINTRIN_impNONE)
1858 {
1859 unimpl = TRUE;
1860 spec = FFEINTRIN_specNONE;
1861 }
1862 }
1863
1864 /* If neither is okay, not an intrinsic. */
1865
1866 if ((gen == FFEINTRIN_genNONE) && (spec == FFEINTRIN_specNONE))
1867 {
1868 /* Here is where we produce a diagnostic about a reference to a
1869 disabled or unimplemented intrinsic, if the diagnostic is desired. */
1870
1871 if ((disabled || unimpl)
1872 && (t != NULL))
1873 {
1874 ffebad_start (disabled
1875 ? FFEBAD_INTRINSIC_DISABLED
1876 : FFEBAD_INTRINSIC_UNIMPLW);
1877 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
1878 ffebad_string (name);
1879 ffebad_finish ();
1880 }
1881
1882 return FALSE;
1883 }
1884
1885 /* Determine whether intrinsic is function or subroutine. If no specific
1886 id, scan list of possible specifics for generic to get consensus. If
1887 not unanimous, or clear from the context, return NONE. */
1888
1889 if (spec == FFEINTRIN_specNONE)
1890 {
1891 int i;
1892 ffeintrinSpec tspec;
1893 ffeintrinImp timp;
1894 bool at_least_one_ok = FALSE;
1895
1896 for (i = 0;
1897 (((size_t) i) < ARRAY_SIZE (ffeintrin_gens_[gen].specs))
1898 && ((tspec
1899 = ffeintrin_gens_[gen].specs[i]) != FFEINTRIN_specNONE);
1900 ++i)
1901 {
1902 if (((state = ffeintrin_state_family (ffeintrin_specs_[tspec].family))
1903 == FFE_intrinsicstateDELETED)
1904 || (state == FFE_intrinsicstateDISABLED))
1905 continue;
1906
1907 if ((timp = ffeintrin_specs_[tspec].implementation)
1908 == FFEINTRIN_impNONE)
1909 continue;
1910
1911 at_least_one_ok = TRUE;
1912 break;
1913 }
1914
1915 if (!at_least_one_ok)
1916 {
1917 *xgen = FFEINTRIN_genNONE;
1918 *xspec = FFEINTRIN_specNONE;
1919 *ximp = FFEINTRIN_impNONE;
1920 return FALSE;
1921 }
1922 }
1923
1924 *xgen = gen;
1925 *xspec = spec;
1926 *ximp = imp;
1927 return TRUE;
1928 }
1929
1930 /* Return TRUE if intrinsic is standard F77 (or, if -ff90, F90). */
1931
1932 bool
1933 ffeintrin_is_standard (ffeintrinGen gen, ffeintrinSpec spec)
1934 {
1935 if (spec == FFEINTRIN_specNONE)
1936 {
1937 if (gen == FFEINTRIN_genNONE)
1938 return FALSE;
1939
1940 spec = ffeintrin_gens_[gen].specs[0];
1941 if (spec == FFEINTRIN_specNONE)
1942 return FALSE;
1943 }
1944
1945 if ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF77)
1946 || (ffe_is_90 ()
1947 && ((ffeintrin_specs_[spec].family == FFEINTRIN_familyF90)
1948 || (ffeintrin_specs_[spec].family == FFEINTRIN_familyMIL)
1949 || (ffeintrin_specs_[spec].family == FFEINTRIN_familyASC))))
1950 return TRUE;
1951 return FALSE;
1952 }
1953
1954 /* Return kind type of intrinsic implementation. See ffeintrin_basictype,
1955 its sibling. */
1956
1957 ffeinfoKindtype
1958 ffeintrin_kindtype (ffeintrinSpec spec)
1959 {
1960 ffeintrinImp imp;
1961 ffecomGfrt gfrt;
1962
1963 assert (spec < FFEINTRIN_spec);
1964 imp = ffeintrin_specs_[spec].implementation;
1965 assert (imp < FFEINTRIN_imp);
1966
1967 if (ffe_is_f2c ())
1968 gfrt = ffeintrin_imps_[imp].gfrt_f2c;
1969 else
1970 gfrt = ffeintrin_imps_[imp].gfrt_gnu;
1971
1972 assert (gfrt != FFECOM_gfrt);
1973
1974 return ffecom_gfrt_kindtype (gfrt);
1975 }
1976
1977 /* Return name of generic intrinsic. */
1978
1979 const char *
1980 ffeintrin_name_generic (ffeintrinGen gen)
1981 {
1982 assert (gen < FFEINTRIN_gen);
1983 return ffeintrin_gens_[gen].name;
1984 }
1985
1986 /* Return name of intrinsic implementation. */
1987
1988 const char *
1989 ffeintrin_name_implementation (ffeintrinImp imp)
1990 {
1991 assert (imp < FFEINTRIN_imp);
1992 return ffeintrin_imps_[imp].name;
1993 }
1994
1995 /* Return external/internal name of specific intrinsic. */
1996
1997 const char *
1998 ffeintrin_name_specific (ffeintrinSpec spec)
1999 {
2000 assert (spec < FFEINTRIN_spec);
2001 return ffeintrin_specs_[spec].name;
2002 }
2003
2004 /* Return state of family. */
2005
2006 ffeIntrinsicState
2007 ffeintrin_state_family (ffeintrinFamily family)
2008 {
2009 ffeIntrinsicState state;
2010
2011 switch (family)
2012 {
2013 case FFEINTRIN_familyNONE:
2014 return FFE_intrinsicstateDELETED;
2015
2016 case FFEINTRIN_familyF77:
2017 return FFE_intrinsicstateENABLED;
2018
2019 case FFEINTRIN_familyASC:
2020 state = ffe_intrinsic_state_f2c ();
2021 state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2022 return state;
2023
2024 case FFEINTRIN_familyMIL:
2025 state = ffe_intrinsic_state_vxt ();
2026 state = ffe_state_max (state, ffe_intrinsic_state_f90 ());
2027 state = ffe_state_max (state, ffe_intrinsic_state_mil ());
2028 return state;
2029
2030 case FFEINTRIN_familyGNU:
2031 state = ffe_intrinsic_state_gnu ();
2032 return state;
2033
2034 case FFEINTRIN_familyF90:
2035 state = ffe_intrinsic_state_f90 ();
2036 return state;
2037
2038 case FFEINTRIN_familyVXT:
2039 state = ffe_intrinsic_state_vxt ();
2040 return state;
2041
2042 case FFEINTRIN_familyFVZ:
2043 state = ffe_intrinsic_state_f2c ();
2044 state = ffe_state_max (state, ffe_intrinsic_state_vxt ());
2045 return state;
2046
2047 case FFEINTRIN_familyF2C:
2048 state = ffe_intrinsic_state_f2c ();
2049 return state;
2050
2051 case FFEINTRIN_familyF2U:
2052 state = ffe_intrinsic_state_unix ();
2053 return state;
2054
2055 case FFEINTRIN_familyBADU77:
2056 state = ffe_intrinsic_state_badu77 ();
2057 return state;
2058
2059 default:
2060 assert ("bad family" == NULL);
2061 return FFE_intrinsicstateDELETED;
2062 }
2063 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org