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