1 /* Build up a list of intrinsic subroutines and functions for the 2 name-resolution stage. 3 Copyright (C) 2000-2020 Free Software Foundation, Inc. 4 Contributed by Andy Vaught & Katherine Holcomb 5 6 This file is part of GCC. 7 8 GCC is free software; you can redistribute it and/or modify it under 9 the terms of the GNU General Public License as published by the Free 10 Software Foundation; either version 3, or (at your option) any later 11 version. 12 13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY 14 WARRANTY; without even the implied warranty of MERCHANTABILITY or 15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 16 for more details. 17 18 You should have received a copy of the GNU General Public License 19 along with GCC; see the file COPYING3. If not see 20 <http://www.gnu.org/licenses/>. */ 21 22 #include "config.h" 23 #include "system.h" 24 #include "coretypes.h" 25 #include "options.h" 26 #include "gfortran.h" 27 #include "intrinsic.h" 28 29 /* Namespace to hold the resolved symbols for intrinsic subroutines. */ 30 static gfc_namespace *gfc_intrinsic_namespace; 31 32 bool gfc_init_expr_flag = false; 33 34 /* Pointers to an intrinsic function and its argument names that are being 35 checked. */ 36 37 const char *gfc_current_intrinsic; 38 gfc_intrinsic_arg *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS]; 39 locus *gfc_current_intrinsic_where; 40 41 static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym; 42 static gfc_intrinsic_sym *char_conversions; 43 static gfc_intrinsic_arg *next_arg; 44 45 static int nfunc, nsub, nargs, nconv, ncharconv; 46 47 static enum 48 { SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS } 49 sizing; 50 51 enum klass 52 { CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL, 53 CLASS_INQUIRY, CLASS_TRANSFORMATIONAL, CLASS_ATOMIC }; 54 55 #define ACTUAL_NO 0 56 #define ACTUAL_YES 1 57 58 #define REQUIRED 0 59 #define OPTIONAL 1 60 61 62 /* Return a letter based on the passed type. Used to construct the 63 name of a type-dependent subroutine. If logical_equals_int is 64 true, we can treat a logical like an int. */ 65 66 char 67 gfc_type_letter (bt type, bool logical_equals_int) 68 { 69 char c; 70 71 switch (type) 72 { 73 case BT_LOGICAL: 74 if (logical_equals_int) 75 c = 'i'; 76 else 77 c = 'l'; 78 79 break; 80 case BT_CHARACTER: 81 c = 's'; 82 break; 83 case BT_INTEGER: 84 c = 'i'; 85 break; 86 case BT_REAL: 87 c = 'r'; 88 break; 89 case BT_COMPLEX: 90 c = 'c'; 91 break; 92 93 case BT_HOLLERITH: 94 c = 'h'; 95 break; 96 97 default: 98 c = 'u'; 99 break; 100 } 101 102 return c; 103 } 104 105 106 /* Get a symbol for a resolved name. Note, if needed be, the elemental 107 attribute has be added afterwards. */ 108 109 gfc_symbol * 110 gfc_get_intrinsic_sub_symbol (const char *name) 111 { 112 gfc_symbol *sym; 113 114 gfc_get_symbol (name, gfc_intrinsic_namespace, &sym); 115 sym->attr.always_explicit = 1; 116 sym->attr.subroutine = 1; 117 sym->attr.flavor = FL_PROCEDURE; 118 sym->attr.proc = PROC_INTRINSIC; 119 120 gfc_commit_symbol (sym); 121 122 return sym; 123 } 124 125 126 /* Return a pointer to the name of a conversion function given two 127 typespecs. */ 128 129 static const char * 130 conv_name (gfc_typespec *from, gfc_typespec *to) 131 { 132 return gfc_get_string ("__convert_%c%d_%c%d", 133 gfc_type_letter (from->type), from->kind, 134 gfc_type_letter (to->type), to->kind); 135 } 136 137 138 /* Given a pair of typespecs, find the gfc_intrinsic_sym node that 139 corresponds to the conversion. Returns NULL if the conversion 140 isn't found. */ 141 142 static gfc_intrinsic_sym * 143 find_conv (gfc_typespec *from, gfc_typespec *to) 144 { 145 gfc_intrinsic_sym *sym; 146 const char *target; 147 int i; 148 149 target = conv_name (from, to); 150 sym = conversion; 151 152 for (i = 0; i < nconv; i++, sym++) 153 if (target == sym->name) 154 return sym; 155 156 return NULL; 157 } 158 159 160 /* Given a pair of CHARACTER typespecs, find the gfc_intrinsic_sym node 161 that corresponds to the conversion. Returns NULL if the conversion 162 isn't found. */ 163 164 static gfc_intrinsic_sym * 165 find_char_conv (gfc_typespec *from, gfc_typespec *to) 166 { 167 gfc_intrinsic_sym *sym; 168 const char *target; 169 int i; 170 171 target = conv_name (from, to); 172 sym = char_conversions; 173 174 for (i = 0; i < ncharconv; i++, sym++) 175 if (target == sym->name) 176 return sym; 177 178 return NULL; 179 } 180 181 182 /* Check TS29113, C407b for assumed type and C535b for assumed-rank, 183 and a likewise check for NO_ARG_CHECK. */ 184 185 static bool 186 do_ts29113_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) 187 { 188 gfc_actual_arglist *a; 189 190 for (a = arg; a; a = a->next) 191 { 192 if (!a->expr) 193 continue; 194 195 if (a->expr->expr_type == EXPR_VARIABLE 196 && (a->expr->symtree->n.sym->attr.ext_attr 197 & (1 << EXT_ATTR_NO_ARG_CHECK)) 198 && specific->id != GFC_ISYM_C_LOC 199 && specific->id != GFC_ISYM_PRESENT) 200 { 201 gfc_error ("Variable with NO_ARG_CHECK attribute at %L is only " 202 "permitted as argument to the intrinsic functions " 203 "C_LOC and PRESENT", &a->expr->where); 204 return false; 205 } 206 else if (a->expr->ts.type == BT_ASSUMED 207 && specific->id != GFC_ISYM_LBOUND 208 && specific->id != GFC_ISYM_PRESENT 209 && specific->id != GFC_ISYM_RANK 210 && specific->id != GFC_ISYM_SHAPE 211 && specific->id != GFC_ISYM_SIZE 212 && specific->id != GFC_ISYM_SIZEOF 213 && specific->id != GFC_ISYM_UBOUND 214 && specific->id != GFC_ISYM_IS_CONTIGUOUS 215 && specific->id != GFC_ISYM_C_LOC) 216 { 217 gfc_error ("Assumed-type argument at %L is not permitted as actual" 218 " argument to the intrinsic %s", &a->expr->where, 219 gfc_current_intrinsic); 220 return false; 221 } 222 else if (a->expr->ts.type == BT_ASSUMED && a != arg) 223 { 224 gfc_error ("Assumed-type argument at %L is only permitted as " 225 "first actual argument to the intrinsic %s", 226 &a->expr->where, gfc_current_intrinsic); 227 return false; 228 } 229 if (a->expr->rank == -1 && !specific->inquiry) 230 { 231 gfc_error ("Assumed-rank argument at %L is only permitted as actual " 232 "argument to intrinsic inquiry functions", 233 &a->expr->where); 234 return false; 235 } 236 if (a->expr->rank == -1 && arg != a) 237 { 238 gfc_error ("Assumed-rank argument at %L is only permitted as first " 239 "actual argument to the intrinsic inquiry function %s", 240 &a->expr->where, gfc_current_intrinsic); 241 return false; 242 } 243 } 244 245 return true; 246 } 247 248 249 /* Interface to the check functions. We break apart an argument list 250 and call the proper check function rather than forcing each 251 function to manipulate the argument list. */ 252 253 static bool 254 do_check (gfc_intrinsic_sym *specific, gfc_actual_arglist *arg) 255 { 256 gfc_expr *a1, *a2, *a3, *a4, *a5; 257 258 if (arg == NULL) 259 return (*specific->check.f0) (); 260 261 a1 = arg->expr; 262 arg = arg->next; 263 if (arg == NULL) 264 return (*specific->check.f1) (a1); 265 266 a2 = arg->expr; 267 arg = arg->next; 268 if (arg == NULL) 269 return (*specific->check.f2) (a1, a2); 270 271 a3 = arg->expr; 272 arg = arg->next; 273 if (arg == NULL) 274 return (*specific->check.f3) (a1, a2, a3); 275 276 a4 = arg->expr; 277 arg = arg->next; 278 if (arg == NULL) 279 return (*specific->check.f4) (a1, a2, a3, a4); 280 281 a5 = arg->expr; 282 arg = arg->next; 283 if (arg == NULL) 284 return (*specific->check.f5) (a1, a2, a3, a4, a5); 285 286 gfc_internal_error ("do_check(): too many args"); 287 } 288 289 290 /*********** Subroutines to build the intrinsic list ****************/ 291 292 /* Add a single intrinsic symbol to the current list. 293 294 Argument list: 295 char * name of function 296 int whether function is elemental 297 int If the function can be used as an actual argument [1] 298 bt return type of function 299 int kind of return type of function 300 int Fortran standard version 301 check pointer to check function 302 simplify pointer to simplification function 303 resolve pointer to resolution function 304 305 Optional arguments come in multiples of five: 306 char * name of argument 307 bt type of argument 308 int kind of argument 309 int arg optional flag (1=optional, 0=required) 310 sym_intent intent of argument 311 312 The sequence is terminated by a NULL name. 313 314 315 [1] Whether a function can or cannot be used as an actual argument is 316 determined by its presence on the 13.6 list in Fortran 2003. The 317 following intrinsics, which are GNU extensions, are considered allowed 318 as actual arguments: ACOSH ATANH DACOSH DASINH DATANH DCONJG DIMAG 319 ZABS ZCOS ZEXP ZLOG ZSIN ZSQRT. */ 320 321 static void 322 add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, int kind, 323 int standard, gfc_check_f check, gfc_simplify_f simplify, 324 gfc_resolve_f resolve, ...) 325 { 326 char buf[GFC_MAX_SYMBOL_LEN + 11]; /* 10 for '_gfortran_', 1 for '\0' */ 327 int optional, first_flag; 328 sym_intent intent; 329 va_list argp; 330 331 switch (sizing) 332 { 333 case SZ_SUBS: 334 nsub++; 335 break; 336 337 case SZ_FUNCS: 338 nfunc++; 339 break; 340 341 case SZ_NOTHING: 342 next_sym->name = gfc_get_string ("%s", name); 343 344 strcpy (buf, "_gfortran_"); 345 strcat (buf, name); 346 next_sym->lib_name = gfc_get_string ("%s", buf); 347 348 next_sym->pure = (cl != CLASS_IMPURE); 349 next_sym->elemental = (cl == CLASS_ELEMENTAL); 350 next_sym->inquiry = (cl == CLASS_INQUIRY); 351 next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL); 352 next_sym->actual_ok = actual_ok; 353 next_sym->ts.type = type; 354 next_sym->ts.kind = kind; 355 next_sym->standard = standard; 356 next_sym->simplify = simplify; 357 next_sym->check = check; 358 next_sym->resolve = resolve; 359 next_sym->specific = 0; 360 next_sym->generic = 0; 361 next_sym->conversion = 0; 362 next_sym->id = id; 363 break; 364 365 default: 366 gfc_internal_error ("add_sym(): Bad sizing mode"); 367 } 368 369 va_start (argp, resolve); 370 371 first_flag = 1; 372 373 for (;;) 374 { 375 name = va_arg (argp, char *); 376 if (name == NULL) 377 break; 378 379 type = (bt) va_arg (argp, int); 380 kind = va_arg (argp, int); 381 optional = va_arg (argp, int); 382 intent = (sym_intent) va_arg (argp, int); 383 384 if (sizing != SZ_NOTHING) 385 nargs++; 386 else 387 { 388 next_arg++; 389 390 if (first_flag) 391 next_sym->formal = next_arg; 392 else 393 (next_arg - 1)->next = next_arg; 394 395 first_flag = 0; 396 397 strcpy (next_arg->name, name); 398 next_arg->ts.type = type; 399 next_arg->ts.kind = kind; 400 next_arg->optional = optional; 401 next_arg->value = 0; 402 next_arg->intent = intent; 403 } 404 } 405 406 va_end (argp); 407 408 next_sym++; 409 } 410 411 412 /* Add a symbol to the function list where the function takes 413 0 arguments. */ 414 415 static void 416 add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, 417 int kind, int standard, 418 bool (*check) (void), 419 gfc_expr *(*simplify) (void), 420 void (*resolve) (gfc_expr *)) 421 { 422 gfc_simplify_f sf; 423 gfc_check_f cf; 424 gfc_resolve_f rf; 425 426 cf.f0 = check; 427 sf.f0 = simplify; 428 rf.f0 = resolve; 429 430 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 431 (void *) 0); 432 } 433 434 435 /* Add a symbol to the subroutine list where the subroutine takes 436 0 arguments. */ 437 438 static void 439 add_sym_0s (const char *name, gfc_isym_id id, int standard, 440 void (*resolve) (gfc_code *)) 441 { 442 gfc_check_f cf; 443 gfc_simplify_f sf; 444 gfc_resolve_f rf; 445 446 cf.f1 = NULL; 447 sf.f1 = NULL; 448 rf.s1 = resolve; 449 450 add_sym (name, id, CLASS_IMPURE, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, 451 rf, (void *) 0); 452 } 453 454 455 /* Add a symbol to the function list where the function takes 456 1 arguments. */ 457 458 static void 459 add_sym_1 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, 460 int kind, int standard, 461 bool (*check) (gfc_expr *), 462 gfc_expr *(*simplify) (gfc_expr *), 463 void (*resolve) (gfc_expr *, gfc_expr *), 464 const char *a1, bt type1, int kind1, int optional1) 465 { 466 gfc_check_f cf; 467 gfc_simplify_f sf; 468 gfc_resolve_f rf; 469 470 cf.f1 = check; 471 sf.f1 = simplify; 472 rf.f1 = resolve; 473 474 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 475 a1, type1, kind1, optional1, INTENT_IN, 476 (void *) 0); 477 } 478 479 480 /* Add a symbol to the function list where the function takes 481 1 arguments, specifying the intent of the argument. */ 482 483 static void 484 add_sym_1_intent (const char *name, gfc_isym_id id, enum klass cl, 485 int actual_ok, bt type, int kind, int standard, 486 bool (*check) (gfc_expr *), 487 gfc_expr *(*simplify) (gfc_expr *), 488 void (*resolve) (gfc_expr *, gfc_expr *), 489 const char *a1, bt type1, int kind1, int optional1, 490 sym_intent intent1) 491 { 492 gfc_check_f cf; 493 gfc_simplify_f sf; 494 gfc_resolve_f rf; 495 496 cf.f1 = check; 497 sf.f1 = simplify; 498 rf.f1 = resolve; 499 500 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 501 a1, type1, kind1, optional1, intent1, 502 (void *) 0); 503 } 504 505 506 /* Add a symbol to the subroutine list where the subroutine takes 507 1 arguments, specifying the intent of the argument. */ 508 509 static void 510 add_sym_1s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, 511 int standard, bool (*check) (gfc_expr *), 512 gfc_expr *(*simplify) (gfc_expr *), void (*resolve) (gfc_code *), 513 const char *a1, bt type1, int kind1, int optional1, 514 sym_intent intent1) 515 { 516 gfc_check_f cf; 517 gfc_simplify_f sf; 518 gfc_resolve_f rf; 519 520 cf.f1 = check; 521 sf.f1 = simplify; 522 rf.s1 = resolve; 523 524 add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, 525 a1, type1, kind1, optional1, intent1, 526 (void *) 0); 527 } 528 529 /* Add a symbol to the subroutine ilst where the subroutine takes one 530 printf-style character argument and a variable number of arguments 531 to follow. */ 532 533 static void 534 add_sym_1p (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, 535 int standard, bool (*check) (gfc_actual_arglist *), 536 gfc_expr *(*simplify) (gfc_expr*), void (*resolve) (gfc_code *), 537 const char *a1, bt type1, int kind1, int optional1, sym_intent intent1) 538 { 539 gfc_check_f cf; 540 gfc_simplify_f sf; 541 gfc_resolve_f rf; 542 543 cf.f1m = check; 544 sf.f1 = simplify; 545 rf.s1 = resolve; 546 547 add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, 548 a1, type1, kind1, optional1, intent1, 549 (void *) 0); 550 } 551 552 553 /* Add a symbol from the MAX/MIN family of intrinsic functions to the 554 function. MAX et al take 2 or more arguments. */ 555 556 static void 557 add_sym_1m (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, 558 int kind, int standard, 559 bool (*check) (gfc_actual_arglist *), 560 gfc_expr *(*simplify) (gfc_expr *), 561 void (*resolve) (gfc_expr *, gfc_actual_arglist *), 562 const char *a1, bt type1, int kind1, int optional1, 563 const char *a2, bt type2, int kind2, int optional2) 564 { 565 gfc_check_f cf; 566 gfc_simplify_f sf; 567 gfc_resolve_f rf; 568 569 cf.f1m = check; 570 sf.f1 = simplify; 571 rf.f1m = resolve; 572 573 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 574 a1, type1, kind1, optional1, INTENT_IN, 575 a2, type2, kind2, optional2, INTENT_IN, 576 (void *) 0); 577 } 578 579 580 /* Add a symbol to the function list where the function takes 581 2 arguments. */ 582 583 static void 584 add_sym_2 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, 585 int kind, int standard, 586 bool (*check) (gfc_expr *, gfc_expr *), 587 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), 588 void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), 589 const char *a1, bt type1, int kind1, int optional1, 590 const char *a2, bt type2, int kind2, int optional2) 591 { 592 gfc_check_f cf; 593 gfc_simplify_f sf; 594 gfc_resolve_f rf; 595 596 cf.f2 = check; 597 sf.f2 = simplify; 598 rf.f2 = resolve; 599 600 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 601 a1, type1, kind1, optional1, INTENT_IN, 602 a2, type2, kind2, optional2, INTENT_IN, 603 (void *) 0); 604 } 605 606 607 /* Add a symbol to the function list where the function takes 608 2 arguments; same as add_sym_2 - but allows to specify the intent. */ 609 610 static void 611 add_sym_2_intent (const char *name, gfc_isym_id id, enum klass cl, 612 int actual_ok, bt type, int kind, int standard, 613 bool (*check) (gfc_expr *, gfc_expr *), 614 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), 615 void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *), 616 const char *a1, bt type1, int kind1, int optional1, 617 sym_intent intent1, const char *a2, bt type2, int kind2, 618 int optional2, sym_intent intent2) 619 { 620 gfc_check_f cf; 621 gfc_simplify_f sf; 622 gfc_resolve_f rf; 623 624 cf.f2 = check; 625 sf.f2 = simplify; 626 rf.f2 = resolve; 627 628 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 629 a1, type1, kind1, optional1, intent1, 630 a2, type2, kind2, optional2, intent2, 631 (void *) 0); 632 } 633 634 635 /* Add a symbol to the subroutine list where the subroutine takes 636 2 arguments, specifying the intent of the arguments. */ 637 638 static void 639 add_sym_2s (const char *name, gfc_isym_id id, enum klass cl, bt type, 640 int kind, int standard, 641 bool (*check) (gfc_expr *, gfc_expr *), 642 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *), 643 void (*resolve) (gfc_code *), 644 const char *a1, bt type1, int kind1, int optional1, 645 sym_intent intent1, const char *a2, bt type2, int kind2, 646 int optional2, sym_intent intent2) 647 { 648 gfc_check_f cf; 649 gfc_simplify_f sf; 650 gfc_resolve_f rf; 651 652 cf.f2 = check; 653 sf.f2 = simplify; 654 rf.s1 = resolve; 655 656 add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, 657 a1, type1, kind1, optional1, intent1, 658 a2, type2, kind2, optional2, intent2, 659 (void *) 0); 660 } 661 662 663 /* Add a symbol to the function list where the function takes 664 3 arguments. */ 665 666 static void 667 add_sym_3 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, 668 int kind, int standard, 669 bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *), 670 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), 671 void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), 672 const char *a1, bt type1, int kind1, int optional1, 673 const char *a2, bt type2, int kind2, int optional2, 674 const char *a3, bt type3, int kind3, int optional3) 675 { 676 gfc_check_f cf; 677 gfc_simplify_f sf; 678 gfc_resolve_f rf; 679 680 cf.f3 = check; 681 sf.f3 = simplify; 682 rf.f3 = resolve; 683 684 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 685 a1, type1, kind1, optional1, INTENT_IN, 686 a2, type2, kind2, optional2, INTENT_IN, 687 a3, type3, kind3, optional3, INTENT_IN, 688 (void *) 0); 689 } 690 691 692 /* MINLOC and MAXLOC get special treatment because their 693 argument might have to be reordered. */ 694 695 static void 696 add_sym_5ml (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, 697 int kind, int standard, 698 bool (*check) (gfc_actual_arglist *), 699 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, 700 gfc_expr *, gfc_expr *), 701 void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, 702 gfc_expr *, gfc_expr *), 703 const char *a1, bt type1, int kind1, int optional1, 704 const char *a2, bt type2, int kind2, int optional2, 705 const char *a3, bt type3, int kind3, int optional3, 706 const char *a4, bt type4, int kind4, int optional4, 707 const char *a5, bt type5, int kind5, int optional5) 708 { 709 gfc_check_f cf; 710 gfc_simplify_f sf; 711 gfc_resolve_f rf; 712 713 cf.f5ml = check; 714 sf.f5 = simplify; 715 rf.f5 = resolve; 716 717 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 718 a1, type1, kind1, optional1, INTENT_IN, 719 a2, type2, kind2, optional2, INTENT_IN, 720 a3, type3, kind3, optional3, INTENT_IN, 721 a4, type4, kind4, optional4, INTENT_IN, 722 a5, type5, kind5, optional5, INTENT_IN, 723 (void *) 0); 724 } 725 726 /* Similar for FINDLOC. */ 727 728 static void 729 add_sym_6fl (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, 730 bt type, int kind, int standard, 731 bool (*check) (gfc_actual_arglist *), 732 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, 733 gfc_expr *, gfc_expr *, gfc_expr *), 734 void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, 735 gfc_expr *, gfc_expr *, gfc_expr *), 736 const char *a1, bt type1, int kind1, int optional1, 737 const char *a2, bt type2, int kind2, int optional2, 738 const char *a3, bt type3, int kind3, int optional3, 739 const char *a4, bt type4, int kind4, int optional4, 740 const char *a5, bt type5, int kind5, int optional5, 741 const char *a6, bt type6, int kind6, int optional6) 742 743 { 744 gfc_check_f cf; 745 gfc_simplify_f sf; 746 gfc_resolve_f rf; 747 748 cf.f6fl = check; 749 sf.f6 = simplify; 750 rf.f6 = resolve; 751 752 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 753 a1, type1, kind1, optional1, INTENT_IN, 754 a2, type2, kind2, optional2, INTENT_IN, 755 a3, type3, kind3, optional3, INTENT_IN, 756 a4, type4, kind4, optional4, INTENT_IN, 757 a5, type5, kind5, optional5, INTENT_IN, 758 a6, type6, kind6, optional6, INTENT_IN, 759 (void *) 0); 760 } 761 762 763 /* MINVAL, MAXVAL, PRODUCT, and SUM also get special treatment because 764 their argument also might have to be reordered. */ 765 766 static void 767 add_sym_3red (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, 768 int kind, int standard, 769 bool (*check) (gfc_actual_arglist *), 770 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), 771 void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), 772 const char *a1, bt type1, int kind1, int optional1, 773 const char *a2, bt type2, int kind2, int optional2, 774 const char *a3, bt type3, int kind3, int optional3) 775 { 776 gfc_check_f cf; 777 gfc_simplify_f sf; 778 gfc_resolve_f rf; 779 780 cf.f3red = check; 781 sf.f3 = simplify; 782 rf.f3 = resolve; 783 784 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 785 a1, type1, kind1, optional1, INTENT_IN, 786 a2, type2, kind2, optional2, INTENT_IN, 787 a3, type3, kind3, optional3, INTENT_IN, 788 (void *) 0); 789 } 790 791 792 /* Add a symbol to the subroutine list where the subroutine takes 793 3 arguments, specifying the intent of the arguments. */ 794 795 static void 796 add_sym_3s (const char *name, gfc_isym_id id, enum klass cl, bt type, 797 int kind, int standard, 798 bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *), 799 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *), 800 void (*resolve) (gfc_code *), 801 const char *a1, bt type1, int kind1, int optional1, 802 sym_intent intent1, const char *a2, bt type2, int kind2, 803 int optional2, sym_intent intent2, const char *a3, bt type3, 804 int kind3, int optional3, sym_intent intent3) 805 { 806 gfc_check_f cf; 807 gfc_simplify_f sf; 808 gfc_resolve_f rf; 809 810 cf.f3 = check; 811 sf.f3 = simplify; 812 rf.s1 = resolve; 813 814 add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, 815 a1, type1, kind1, optional1, intent1, 816 a2, type2, kind2, optional2, intent2, 817 a3, type3, kind3, optional3, intent3, 818 (void *) 0); 819 } 820 821 822 /* Add a symbol to the function list where the function takes 823 4 arguments. */ 824 825 static void 826 add_sym_4 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type, 827 int kind, int standard, 828 bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), 829 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, 830 gfc_expr *), 831 void (*resolve) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, 832 gfc_expr *), 833 const char *a1, bt type1, int kind1, int optional1, 834 const char *a2, bt type2, int kind2, int optional2, 835 const char *a3, bt type3, int kind3, int optional3, 836 const char *a4, bt type4, int kind4, int optional4 ) 837 { 838 gfc_check_f cf; 839 gfc_simplify_f sf; 840 gfc_resolve_f rf; 841 842 cf.f4 = check; 843 sf.f4 = simplify; 844 rf.f4 = resolve; 845 846 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 847 a1, type1, kind1, optional1, INTENT_IN, 848 a2, type2, kind2, optional2, INTENT_IN, 849 a3, type3, kind3, optional3, INTENT_IN, 850 a4, type4, kind4, optional4, INTENT_IN, 851 (void *) 0); 852 } 853 854 /* Add a symbol to the function list where the function takes 4 855 arguments and resolution may need to change the number or 856 arrangement of arguments. This is the case for INDEX, which needs 857 its KIND argument removed. */ 858 859 static void 860 add_sym_4ind (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, 861 bt type, int kind, int standard, 862 bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), 863 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, 864 gfc_expr *), 865 void (*resolve) (gfc_expr *, gfc_actual_arglist *), 866 const char *a1, bt type1, int kind1, int optional1, 867 const char *a2, bt type2, int kind2, int optional2, 868 const char *a3, bt type3, int kind3, int optional3, 869 const char *a4, bt type4, int kind4, int optional4 ) 870 { 871 gfc_check_f cf; 872 gfc_simplify_f sf; 873 gfc_resolve_f rf; 874 875 cf.f4 = check; 876 sf.f4 = simplify; 877 rf.f1m = resolve; 878 879 add_sym (name, id, cl, actual_ok, type, kind, standard, cf, sf, rf, 880 a1, type1, kind1, optional1, INTENT_IN, 881 a2, type2, kind2, optional2, INTENT_IN, 882 a3, type3, kind3, optional3, INTENT_IN, 883 a4, type4, kind4, optional4, INTENT_IN, 884 (void *) 0); 885 } 886 887 888 /* Add a symbol to the subroutine list where the subroutine takes 889 4 arguments. */ 890 891 static void 892 add_sym_4s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, 893 int standard, 894 bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *), 895 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, 896 gfc_expr *), 897 void (*resolve) (gfc_code *), 898 const char *a1, bt type1, int kind1, int optional1, 899 sym_intent intent1, const char *a2, bt type2, int kind2, 900 int optional2, sym_intent intent2, const char *a3, bt type3, 901 int kind3, int optional3, sym_intent intent3, const char *a4, 902 bt type4, int kind4, int optional4, sym_intent intent4) 903 { 904 gfc_check_f cf; 905 gfc_simplify_f sf; 906 gfc_resolve_f rf; 907 908 cf.f4 = check; 909 sf.f4 = simplify; 910 rf.s1 = resolve; 911 912 add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, 913 a1, type1, kind1, optional1, intent1, 914 a2, type2, kind2, optional2, intent2, 915 a3, type3, kind3, optional3, intent3, 916 a4, type4, kind4, optional4, intent4, 917 (void *) 0); 918 } 919 920 921 /* Add a symbol to the subroutine list where the subroutine takes 922 5 arguments. */ 923 924 static void 925 add_sym_5s (const char *name, gfc_isym_id id, enum klass cl, bt type, int kind, 926 int standard, 927 bool (*check) (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *, 928 gfc_expr *), 929 gfc_expr *(*simplify) (gfc_expr *, gfc_expr *, gfc_expr *, 930 gfc_expr *, gfc_expr *), 931 void (*resolve) (gfc_code *), 932 const char *a1, bt type1, int kind1, int optional1, 933 sym_intent intent1, const char *a2, bt type2, int kind2, 934 int optional2, sym_intent intent2, const char *a3, bt type3, 935 int kind3, int optional3, sym_intent intent3, const char *a4, 936 bt type4, int kind4, int optional4, sym_intent intent4, 937 const char *a5, bt type5, int kind5, int optional5, 938 sym_intent intent5) 939 { 940 gfc_check_f cf; 941 gfc_simplify_f sf; 942 gfc_resolve_f rf; 943 944 cf.f5 = check; 945 sf.f5 = simplify; 946 rf.s1 = resolve; 947 948 add_sym (name, id, cl, ACTUAL_NO, type, kind, standard, cf, sf, rf, 949 a1, type1, kind1, optional1, intent1, 950 a2, type2, kind2, optional2, intent2, 951 a3, type3, kind3, optional3, intent3, 952 a4, type4, kind4, optional4, intent4, 953 a5, type5, kind5, optional5, intent5, 954 (void *) 0); 955 } 956 957 958 /* Locate an intrinsic symbol given a base pointer, number of elements 959 in the table and a pointer to a name. Returns the NULL pointer if 960 a name is not found. */ 961 962 static gfc_intrinsic_sym * 963 find_sym (gfc_intrinsic_sym *start, int n, const char *name) 964 { 965 /* name may be a user-supplied string, so we must first make sure 966 that we're comparing against a pointer into the global string 967 table. */ 968 const char *p = gfc_get_string ("%s", name); 969 970 while (n > 0) 971 { 972 if (p == start->name) 973 return start; 974 975 start++; 976 n--; 977 } 978 979 return NULL; 980 } 981 982 983 gfc_isym_id 984 gfc_isym_id_by_intmod (intmod_id from_intmod, int intmod_sym_id) 985 { 986 if (from_intmod == INTMOD_NONE) 987 return (gfc_isym_id) intmod_sym_id; 988 else if (from_intmod == INTMOD_ISO_C_BINDING) 989 return (gfc_isym_id) c_interop_kinds_table[intmod_sym_id].value; 990 else if (from_intmod == INTMOD_ISO_FORTRAN_ENV) 991 switch (intmod_sym_id) 992 { 993 #define NAMED_SUBROUTINE(a,b,c,d) \ 994 case a: \ 995 return (gfc_isym_id) c; 996 #define NAMED_FUNCTION(a,b,c,d) \ 997 case a: \ 998 return (gfc_isym_id) c; 999 #include "iso-fortran-env.def" 1000 default: 1001 gcc_unreachable (); 1002 } 1003 else 1004 gcc_unreachable (); 1005 return (gfc_isym_id) 0; 1006 } 1007 1008 1009 gfc_isym_id 1010 gfc_isym_id_by_intmod_sym (gfc_symbol *sym) 1011 { 1012 return gfc_isym_id_by_intmod (sym->from_intmod, sym->intmod_sym_id); 1013 } 1014 1015 1016 gfc_intrinsic_sym * 1017 gfc_intrinsic_subroutine_by_id (gfc_isym_id id) 1018 { 1019 gfc_intrinsic_sym *start = subroutines; 1020 int n = nsub; 1021 1022 while (true) 1023 { 1024 gcc_assert (n > 0); 1025 if (id == start->id) 1026 return start; 1027 1028 start++; 1029 n--; 1030 } 1031 } 1032 1033 1034 gfc_intrinsic_sym * 1035 gfc_intrinsic_function_by_id (gfc_isym_id id) 1036 { 1037 gfc_intrinsic_sym *start = functions; 1038 int n = nfunc; 1039 1040 while (true) 1041 { 1042 gcc_assert (n > 0); 1043 if (id == start->id) 1044 return start; 1045 1046 start++; 1047 n--; 1048 } 1049 } 1050 1051 1052 /* Given a name, find a function in the intrinsic function table. 1053 Returns NULL if not found. */ 1054 1055 gfc_intrinsic_sym * 1056 gfc_find_function (const char *name) 1057 { 1058 gfc_intrinsic_sym *sym; 1059 1060 sym = find_sym (functions, nfunc, name); 1061 if (!sym || sym->from_module) 1062 sym = find_sym (conversion, nconv, name); 1063 1064 return (!sym || sym->from_module) ? NULL : sym; 1065 } 1066 1067 1068 /* Given a name, find a function in the intrinsic subroutine table. 1069 Returns NULL if not found. */ 1070 1071 gfc_intrinsic_sym * 1072 gfc_find_subroutine (const char *name) 1073 { 1074 gfc_intrinsic_sym *sym; 1075 sym = find_sym (subroutines, nsub, name); 1076 return (!sym || sym->from_module) ? NULL : sym; 1077 } 1078 1079 1080 /* Given a string, figure out if it is the name of a generic intrinsic 1081 function or not. */ 1082 1083 int 1084 gfc_generic_intrinsic (const char *name) 1085 { 1086 gfc_intrinsic_sym *sym; 1087 1088 sym = gfc_find_function (name); 1089 return (!sym || sym->from_module) ? 0 : sym->generic; 1090 } 1091 1092 1093 /* Given a string, figure out if it is the name of a specific 1094 intrinsic function or not. */ 1095 1096 int 1097 gfc_specific_intrinsic (const char *name) 1098 { 1099 gfc_intrinsic_sym *sym; 1100 1101 sym = gfc_find_function (name); 1102 return (!sym || sym->from_module) ? 0 : sym->specific; 1103 } 1104 1105 1106 /* Given a string, figure out if it is the name of an intrinsic function 1107 or subroutine allowed as an actual argument or not. */ 1108 int 1109 gfc_intrinsic_actual_ok (const char *name, const bool subroutine_flag) 1110 { 1111 gfc_intrinsic_sym *sym; 1112 1113 /* Intrinsic subroutines are not allowed as actual arguments. */ 1114 if (subroutine_flag) 1115 return 0; 1116 else 1117 { 1118 sym = gfc_find_function (name); 1119 return (sym == NULL) ? 0 : sym->actual_ok; 1120 } 1121 } 1122 1123 1124 /* Given a symbol, find out if it is (and is to be treated as) an intrinsic. 1125 If its name refers to an intrinsic, but this intrinsic is not included in 1126 the selected standard, this returns FALSE and sets the symbol's external 1127 attribute. */ 1128 1129 bool 1130 gfc_is_intrinsic (gfc_symbol* sym, int subroutine_flag, locus loc) 1131 { 1132 gfc_intrinsic_sym* isym; 1133 const char* symstd; 1134 1135 /* If INTRINSIC attribute is already known, return. */ 1136 if (sym->attr.intrinsic) 1137 return true; 1138 1139 /* Check for attributes which prevent the symbol from being INTRINSIC. */ 1140 if (sym->attr.external || sym->attr.contained 1141 || sym->attr.recursive 1142 || sym->attr.if_source == IFSRC_IFBODY) 1143 return false; 1144 1145 if (subroutine_flag) 1146 isym = gfc_find_subroutine (sym->name); 1147 else 1148 isym = gfc_find_function (sym->name); 1149 1150 /* No such intrinsic available at all? */ 1151 if (!isym) 1152 return false; 1153 1154 /* See if this intrinsic is allowed in the current standard. */ 1155 if (!gfc_check_intrinsic_standard (isym, &symstd, false, loc) 1156 && !sym->attr.artificial) 1157 { 1158 if (sym->attr.proc == PROC_UNKNOWN && warn_intrinsics_std) 1159 gfc_warning_now (OPT_Wintrinsics_std, "The intrinsic %qs at %L is not " 1160 "included in the selected standard but %s and %qs will" 1161 " be treated as if declared EXTERNAL. Use an" 1162 " appropriate %<-std=%>* option or define" 1163 " %<-fall-intrinsics%> to allow this intrinsic.", 1164 sym->name, &loc, symstd, sym->name); 1165 1166 return false; 1167 } 1168 1169 return true; 1170 } 1171 1172 1173 /* Collect a set of intrinsic functions into a generic collection. 1174 The first argument is the name of the generic function, which is 1175 also the name of a specific function. The rest of the specifics 1176 currently in the table are placed into the list of specific 1177 functions associated with that generic. 1178 1179 PR fortran/32778 1180 FIXME: Remove the argument STANDARD if no regressions are 1181 encountered. Change all callers (approx. 360). 1182 */ 1183 1184 static void 1185 make_generic (const char *name, gfc_isym_id id, int standard ATTRIBUTE_UNUSED) 1186 { 1187 gfc_intrinsic_sym *g; 1188 1189 if (sizing != SZ_NOTHING) 1190 return; 1191 1192 g = gfc_find_function (name); 1193 if (g == NULL) 1194 gfc_internal_error ("make_generic(): Cannot find generic symbol %qs", 1195 name); 1196 1197 gcc_assert (g->id == id); 1198 1199 g->generic = 1; 1200 g->specific = 1; 1201 if ((g + 1)->name != NULL) 1202 g->specific_head = g + 1; 1203 g++; 1204 1205 while (g->name != NULL) 1206 { 1207 g->next = g + 1; 1208 g->specific = 1; 1209 g++; 1210 } 1211 1212 g--; 1213 g->next = NULL; 1214 } 1215 1216 1217 /* Create a duplicate intrinsic function entry for the current 1218 function, the only differences being the alternate name and 1219 a different standard if necessary. Note that we use argument 1220 lists more than once, but all argument lists are freed as a 1221 single block. */ 1222 1223 static void 1224 make_alias (const char *name, int standard) 1225 { 1226 switch (sizing) 1227 { 1228 case SZ_FUNCS: 1229 nfunc++; 1230 break; 1231 1232 case SZ_SUBS: 1233 nsub++; 1234 break; 1235 1236 case SZ_NOTHING: 1237 next_sym[0] = next_sym[-1]; 1238 next_sym->name = gfc_get_string ("%s", name); 1239 next_sym->standard = standard; 1240 next_sym++; 1241 break; 1242 1243 default: 1244 break; 1245 } 1246 } 1247 1248 1249 /* Make the current subroutine noreturn. */ 1250 1251 static void 1252 make_noreturn (void) 1253 { 1254 if (sizing == SZ_NOTHING) 1255 next_sym[-1].noreturn = 1; 1256 } 1257 1258 1259 /* Mark current intrinsic as module intrinsic. */ 1260 static void 1261 make_from_module (void) 1262 { 1263 if (sizing == SZ_NOTHING) 1264 next_sym[-1].from_module = 1; 1265 } 1266 1267 1268 /* Mark the current subroutine as having a variable number of 1269 arguments. */ 1270 1271 static void 1272 make_vararg (void) 1273 { 1274 if (sizing == SZ_NOTHING) 1275 next_sym[-1].vararg = 1; 1276 } 1277 1278 /* Set the attr.value of the current procedure. */ 1279 1280 static void 1281 set_attr_value (int n, ...) 1282 { 1283 gfc_intrinsic_arg *arg; 1284 va_list argp; 1285 int i; 1286 1287 if (sizing != SZ_NOTHING) 1288 return; 1289 1290 va_start (argp, n); 1291 arg = next_sym[-1].formal; 1292 1293 for (i = 0; i < n; i++) 1294 { 1295 gcc_assert (arg != NULL); 1296 arg->value = va_arg (argp, int); 1297 arg = arg->next; 1298 } 1299 va_end (argp); 1300 } 1301 1302 1303 /* Add intrinsic functions. */ 1304 1305 static void 1306 add_functions (void) 1307 { 1308 /* Argument names. These are used as argument keywords and so need to 1309 match the documentation. Please keep this list in sorted order. */ 1310 const char 1311 *a = "a", *a1 = "a1", *a2 = "a2", *ar = "array", *b = "b", 1312 *bck = "back", *bd = "boundary", *c = "c", *c_ptr_1 = "c_ptr_1", 1313 *c_ptr_2 = "c_ptr_2", *ca = "coarray", *com = "command", 1314 *dist = "distance", *dm = "dim", *f = "field", *failed="failed", 1315 *fs = "fsource", *han = "handler", *i = "i", 1316 *image = "image", *j = "j", *kind = "kind", 1317 *l = "l", *ln = "len", *level = "level", *m = "matrix", *ma = "matrix_a", 1318 *mb = "matrix_b", *md = "mode", *mo = "mold", *msk = "mask", 1319 *n = "n", *ncopies= "ncopies", *nm = "name", *num = "number", 1320 *ord = "order", *p = "p", *p1 = "path1", *p2 = "path2", 1321 *pad = "pad", *pid = "pid", *pos = "pos", *pt = "pointer", 1322 *r = "r", *s = "s", *set = "set", *sh = "shift", *shp = "shape", 1323 *sig = "sig", *src = "source", *ssg = "substring", 1324 *sta = "string_a", *stb = "string_b", *stg = "string", 1325 *sub = "sub", *sz = "size", *tg = "target", *team = "team", *tm = "time", 1326 *ts = "tsource", *ut = "unit", *v = "vector", *va = "vector_a", 1327 *vb = "vector_b", *vl = "values", *val = "value", *x = "x", *y = "y", 1328 *z = "z"; 1329 1330 int di, dr, dd, dl, dc, dz, ii; 1331 1332 di = gfc_default_integer_kind; 1333 dr = gfc_default_real_kind; 1334 dd = gfc_default_double_kind; 1335 dl = gfc_default_logical_kind; 1336 dc = gfc_default_character_kind; 1337 dz = gfc_default_complex_kind; 1338 ii = gfc_index_integer_kind; 1339 1340 add_sym_1 ("abs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1341 gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs, 1342 a, BT_REAL, dr, REQUIRED); 1343 1344 if (flag_dec_intrinsic_ints) 1345 { 1346 make_alias ("babs", GFC_STD_GNU); 1347 make_alias ("iiabs", GFC_STD_GNU); 1348 make_alias ("jiabs", GFC_STD_GNU); 1349 make_alias ("kiabs", GFC_STD_GNU); 1350 } 1351 1352 add_sym_1 ("iabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, 1353 NULL, gfc_simplify_abs, gfc_resolve_abs, 1354 a, BT_INTEGER, di, REQUIRED); 1355 1356 add_sym_1 ("dabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1357 gfc_check_fn_d, gfc_simplify_abs, gfc_resolve_abs, 1358 a, BT_REAL, dd, REQUIRED); 1359 1360 add_sym_1 ("cabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1361 NULL, gfc_simplify_abs, gfc_resolve_abs, 1362 a, BT_COMPLEX, dz, REQUIRED); 1363 1364 add_sym_1 ("zabs", GFC_ISYM_ABS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, 1365 NULL, gfc_simplify_abs, gfc_resolve_abs, 1366 a, BT_COMPLEX, dd, REQUIRED); 1367 1368 make_alias ("cdabs", GFC_STD_GNU); 1369 1370 make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77); 1371 1372 /* The checking function for ACCESS is called gfc_check_access_func 1373 because the name gfc_check_access is already used in module.c. */ 1374 add_sym_2 ("access", GFC_ISYM_ACCESS, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 1375 di, GFC_STD_GNU, gfc_check_access_func, NULL, gfc_resolve_access, 1376 nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED); 1377 1378 make_generic ("access", GFC_ISYM_ACCESS, GFC_STD_GNU); 1379 1380 add_sym_2 ("achar", GFC_ISYM_ACHAR, CLASS_ELEMENTAL, ACTUAL_NO, 1381 BT_CHARACTER, dc, GFC_STD_F95, 1382 gfc_check_achar, gfc_simplify_achar, gfc_resolve_achar, 1383 i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 1384 1385 make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95); 1386 1387 add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1388 gfc_check_fn_rc2008, gfc_simplify_acos, gfc_resolve_acos, 1389 x, BT_REAL, dr, REQUIRED); 1390 1391 add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1392 gfc_check_fn_d, gfc_simplify_acos, gfc_resolve_acos, 1393 x, BT_REAL, dd, REQUIRED); 1394 1395 make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77); 1396 1397 add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, 1398 GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_acosh, 1399 gfc_resolve_acosh, x, BT_REAL, dr, REQUIRED); 1400 1401 add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, 1402 gfc_check_fn_d, gfc_simplify_acosh, gfc_resolve_acosh, 1403 x, BT_REAL, dd, REQUIRED); 1404 1405 make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_F2008); 1406 1407 add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, 1408 BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustl, 1409 gfc_resolve_adjustl, stg, BT_CHARACTER, 0, REQUIRED); 1410 1411 make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95); 1412 1413 add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, 1414 BT_CHARACTER, dc, GFC_STD_F95, NULL, gfc_simplify_adjustr, 1415 gfc_resolve_adjustr, stg, BT_CHARACTER, 0, REQUIRED); 1416 1417 make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95); 1418 1419 add_sym_1 ("aimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1420 gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag, 1421 z, BT_COMPLEX, dz, REQUIRED); 1422 1423 make_alias ("imag", GFC_STD_GNU); 1424 make_alias ("imagpart", GFC_STD_GNU); 1425 1426 add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, 1427 NULL, gfc_simplify_aimag, gfc_resolve_aimag, 1428 z, BT_COMPLEX, dd, REQUIRED); 1429 1430 make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77); 1431 1432 add_sym_2 ("aint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1433 gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint, 1434 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 1435 1436 add_sym_1 ("dint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1437 NULL, gfc_simplify_dint, gfc_resolve_dint, 1438 a, BT_REAL, dd, REQUIRED); 1439 1440 make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77); 1441 1442 add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, 1443 gfc_check_all_any, gfc_simplify_all, gfc_resolve_all, 1444 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); 1445 1446 make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95); 1447 1448 add_sym_1 ("allocated", GFC_ISYM_ALLOCATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, 1449 gfc_check_allocated, NULL, NULL, 1450 ar, BT_UNKNOWN, 0, REQUIRED); 1451 1452 make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95); 1453 1454 add_sym_2 ("anint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1455 gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint, 1456 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 1457 1458 add_sym_1 ("dnint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1459 NULL, gfc_simplify_dnint, gfc_resolve_dnint, 1460 a, BT_REAL, dd, REQUIRED); 1461 1462 make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77); 1463 1464 add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, 1465 gfc_check_all_any, gfc_simplify_any, gfc_resolve_any, 1466 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); 1467 1468 make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95); 1469 1470 add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1471 gfc_check_fn_rc2008, gfc_simplify_asin, gfc_resolve_asin, 1472 x, BT_REAL, dr, REQUIRED); 1473 1474 add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1475 gfc_check_fn_d, gfc_simplify_asin, gfc_resolve_asin, 1476 x, BT_REAL, dd, REQUIRED); 1477 1478 make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77); 1479 1480 add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, 1481 GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_asinh, 1482 gfc_resolve_asinh, x, BT_REAL, dr, REQUIRED); 1483 1484 add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, 1485 gfc_check_fn_d, gfc_simplify_asinh, gfc_resolve_asinh, 1486 x, BT_REAL, dd, REQUIRED); 1487 1488 make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_F2008); 1489 1490 add_sym_2 ("associated", GFC_ISYM_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, 1491 GFC_STD_F95, gfc_check_associated, NULL, NULL, 1492 pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL); 1493 1494 make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95); 1495 1496 add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1497 gfc_check_fn_rc2008, gfc_simplify_atan, gfc_resolve_atan, 1498 x, BT_REAL, dr, REQUIRED); 1499 1500 add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1501 gfc_check_fn_d, gfc_simplify_atan, gfc_resolve_atan, 1502 x, BT_REAL, dd, REQUIRED); 1503 1504 /* Two-argument version of atan, equivalent to atan2. */ 1505 add_sym_2 ("atan", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F2008, 1506 gfc_check_atan_2, gfc_simplify_atan2, gfc_resolve_atan2, 1507 y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); 1508 1509 make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77); 1510 1511 add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, 1512 GFC_STD_F2008, gfc_check_fn_rc2008, gfc_simplify_atanh, 1513 gfc_resolve_atanh, x, BT_REAL, dr, REQUIRED); 1514 1515 add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU, 1516 gfc_check_fn_d, gfc_simplify_atanh, gfc_resolve_atanh, 1517 x, BT_REAL, dd, REQUIRED); 1518 1519 make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_F2008); 1520 1521 add_sym_2 ("atan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1522 gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2, 1523 y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED); 1524 1525 add_sym_2 ("datan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1526 gfc_check_datan2, gfc_simplify_atan2, gfc_resolve_atan2, 1527 y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED); 1528 1529 make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77); 1530 1531 /* Bessel and Neumann functions for G77 compatibility. */ 1532 add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 1533 gfc_check_fn_r, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, 1534 x, BT_REAL, dr, REQUIRED); 1535 1536 make_alias ("bessel_j0", GFC_STD_F2008); 1537 1538 add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, 1539 gfc_check_fn_d, gfc_simplify_bessel_j0, gfc_resolve_g77_math1, 1540 x, BT_REAL, dd, REQUIRED); 1541 1542 make_generic ("bessel_j0", GFC_ISYM_J0, GFC_STD_F2008); 1543 1544 add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 1545 gfc_check_fn_r, gfc_simplify_bessel_j1, gfc_resolve_g77_math1, 1546 x, BT_REAL, dr, REQUIRED); 1547 1548 make_alias ("bessel_j1", GFC_STD_F2008); 1549 1550 add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, 1551 gfc_check_fn_d, gfc_simplify_bessel_j1, gfc_resolve_g77_math1, 1552 x, BT_REAL, dd, REQUIRED); 1553 1554 make_generic ("bessel_j1", GFC_ISYM_J1, GFC_STD_F2008); 1555 1556 add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 1557 gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, 1558 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED); 1559 1560 make_alias ("bessel_jn", GFC_STD_F2008); 1561 1562 add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, 1563 gfc_check_besn, gfc_simplify_bessel_jn, gfc_resolve_besn, 1564 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); 1565 1566 add_sym_3 ("bessel_jn", GFC_ISYM_JN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, 1567 gfc_check_bessel_n2, gfc_simplify_bessel_jn2, gfc_resolve_bessel_n2, 1568 "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED, 1569 x, BT_REAL, dr, REQUIRED); 1570 set_attr_value (3, true, true, true); 1571 1572 make_generic ("bessel_jn", GFC_ISYM_JN, GFC_STD_F2008); 1573 1574 add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 1575 gfc_check_fn_r, gfc_simplify_bessel_y0, gfc_resolve_g77_math1, 1576 x, BT_REAL, dr, REQUIRED); 1577 1578 make_alias ("bessel_y0", GFC_STD_F2008); 1579 1580 add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, 1581 gfc_check_fn_d, gfc_simplify_bessel_y0, gfc_resolve_g77_math1, 1582 x, BT_REAL, dd, REQUIRED); 1583 1584 make_generic ("bessel_y0", GFC_ISYM_Y0, GFC_STD_F2008); 1585 1586 add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 1587 gfc_check_fn_r, gfc_simplify_bessel_y1, gfc_resolve_g77_math1, 1588 x, BT_REAL, dr, REQUIRED); 1589 1590 make_alias ("bessel_y1", GFC_STD_F2008); 1591 1592 add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, 1593 gfc_check_fn_d, gfc_simplify_bessel_y1, gfc_resolve_g77_math1, 1594 x, BT_REAL, dd, REQUIRED); 1595 1596 make_generic ("bessel_y1", GFC_ISYM_Y1, GFC_STD_F2008); 1597 1598 add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 1599 gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, 1600 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED); 1601 1602 make_alias ("bessel_yn", GFC_STD_F2008); 1603 1604 add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, 1605 gfc_check_besn, gfc_simplify_bessel_yn, gfc_resolve_besn, 1606 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED); 1607 1608 add_sym_3 ("bessel_yn", GFC_ISYM_YN2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, 1609 gfc_check_bessel_n2, gfc_simplify_bessel_yn2, gfc_resolve_bessel_n2, 1610 "n1", BT_INTEGER, di, REQUIRED,"n2", BT_INTEGER, di, REQUIRED, 1611 x, BT_REAL, dr, REQUIRED); 1612 set_attr_value (3, true, true, true); 1613 1614 make_generic ("bessel_yn", GFC_ISYM_YN, GFC_STD_F2008); 1615 1616 add_sym_2 ("bge", GFC_ISYM_BGE, CLASS_ELEMENTAL, ACTUAL_NO, 1617 BT_LOGICAL, dl, GFC_STD_F2008, 1618 gfc_check_bge_bgt_ble_blt, gfc_simplify_bge, NULL, 1619 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); 1620 1621 make_generic ("bge", GFC_ISYM_BGE, GFC_STD_F2008); 1622 1623 add_sym_2 ("bgt", GFC_ISYM_BGT, CLASS_ELEMENTAL, ACTUAL_NO, 1624 BT_LOGICAL, dl, GFC_STD_F2008, 1625 gfc_check_bge_bgt_ble_blt, gfc_simplify_bgt, NULL, 1626 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); 1627 1628 make_generic ("bgt", GFC_ISYM_BGT, GFC_STD_F2008); 1629 1630 add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 1631 gfc_check_i, gfc_simplify_bit_size, NULL, 1632 i, BT_INTEGER, di, REQUIRED); 1633 1634 make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95); 1635 1636 add_sym_2 ("ble", GFC_ISYM_BLE, CLASS_ELEMENTAL, ACTUAL_NO, 1637 BT_LOGICAL, dl, GFC_STD_F2008, 1638 gfc_check_bge_bgt_ble_blt, gfc_simplify_ble, NULL, 1639 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); 1640 1641 make_generic ("ble", GFC_ISYM_BLE, GFC_STD_F2008); 1642 1643 add_sym_2 ("blt", GFC_ISYM_BLT, CLASS_ELEMENTAL, ACTUAL_NO, 1644 BT_LOGICAL, dl, GFC_STD_F2008, 1645 gfc_check_bge_bgt_ble_blt, gfc_simplify_blt, NULL, 1646 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); 1647 1648 make_generic ("blt", GFC_ISYM_BLT, GFC_STD_F2008); 1649 1650 add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, 1651 gfc_check_bitfcn, gfc_simplify_btest, gfc_resolve_btest, 1652 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); 1653 1654 if (flag_dec_intrinsic_ints) 1655 { 1656 make_alias ("bbtest", GFC_STD_GNU); 1657 make_alias ("bitest", GFC_STD_GNU); 1658 make_alias ("bjtest", GFC_STD_GNU); 1659 make_alias ("bktest", GFC_STD_GNU); 1660 } 1661 1662 make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95); 1663 1664 add_sym_2 ("ceiling", GFC_ISYM_CEILING, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 1665 gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling, 1666 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 1667 1668 make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95); 1669 1670 add_sym_2 ("char", GFC_ISYM_CHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F77, 1671 gfc_check_char, gfc_simplify_char, gfc_resolve_char, 1672 i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 1673 1674 make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77); 1675 1676 add_sym_1 ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, 1677 GFC_STD_GNU, gfc_check_chdir, NULL, gfc_resolve_chdir, 1678 nm, BT_CHARACTER, dc, REQUIRED); 1679 1680 make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU); 1681 1682 add_sym_2 ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 1683 di, GFC_STD_GNU, gfc_check_chmod, NULL, gfc_resolve_chmod, 1684 nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED); 1685 1686 make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU); 1687 1688 add_sym_3 ("cmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_F77, 1689 gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx, 1690 x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL, 1691 kind, BT_INTEGER, di, OPTIONAL); 1692 1693 make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77); 1694 1695 add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY, 1696 ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL); 1697 1698 make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, 1699 GFC_STD_F2003); 1700 1701 add_sym_2 ("complex", GFC_ISYM_COMPLEX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU, 1702 gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex, 1703 x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED); 1704 1705 make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU); 1706 1707 /* Making dcmplx a specific of cmplx causes cmplx to return a double 1708 complex instead of the default complex. */ 1709 1710 add_sym_2 ("dcmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dd, GFC_STD_GNU, 1711 gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx, 1712 x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL); 1713 1714 make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU); 1715 1716 add_sym_1 ("conjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, 1717 gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg, 1718 z, BT_COMPLEX, dz, REQUIRED); 1719 1720 add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, 1721 NULL, gfc_simplify_conjg, gfc_resolve_conjg, 1722 z, BT_COMPLEX, dd, REQUIRED); 1723 1724 make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77); 1725 1726 add_sym_1 ("cos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1727 gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos, 1728 x, BT_REAL, dr, REQUIRED); 1729 1730 add_sym_1 ("dcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1731 gfc_check_fn_d, gfc_simplify_cos, gfc_resolve_cos, 1732 x, BT_REAL, dd, REQUIRED); 1733 1734 add_sym_1 ("ccos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, 1735 NULL, gfc_simplify_cos, gfc_resolve_cos, 1736 x, BT_COMPLEX, dz, REQUIRED); 1737 1738 add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, 1739 NULL, gfc_simplify_cos, gfc_resolve_cos, 1740 x, BT_COMPLEX, dd, REQUIRED); 1741 1742 make_alias ("cdcos", GFC_STD_GNU); 1743 1744 make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77); 1745 1746 add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1747 gfc_check_fn_rc2008, gfc_simplify_cosh, gfc_resolve_cosh, 1748 x, BT_REAL, dr, REQUIRED); 1749 1750 add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1751 gfc_check_fn_d, gfc_simplify_cosh, gfc_resolve_cosh, 1752 x, BT_REAL, dd, REQUIRED); 1753 1754 make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77); 1755 1756 add_sym_3 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, 1757 BT_INTEGER, di, GFC_STD_F95, 1758 gfc_check_count, gfc_simplify_count, gfc_resolve_count, 1759 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 1760 kind, BT_INTEGER, di, OPTIONAL); 1761 1762 make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95); 1763 1764 add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, 1765 BT_REAL, dr, GFC_STD_F95, 1766 gfc_check_cshift, gfc_simplify_cshift, gfc_resolve_cshift, 1767 ar, BT_REAL, dr, REQUIRED, 1768 sh, BT_INTEGER, di, REQUIRED, 1769 dm, BT_INTEGER, ii, OPTIONAL); 1770 1771 make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95); 1772 1773 add_sym_1 ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, 1774 0, GFC_STD_GNU, gfc_check_ctime, NULL, gfc_resolve_ctime, 1775 tm, BT_INTEGER, di, REQUIRED); 1776 1777 make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU); 1778 1779 add_sym_1 ("dble", GFC_ISYM_DBLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, 1780 gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble, 1781 a, BT_REAL, dr, REQUIRED); 1782 1783 make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77); 1784 1785 add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 1786 gfc_check_digits, gfc_simplify_digits, NULL, 1787 x, BT_UNKNOWN, dr, REQUIRED); 1788 1789 make_generic ("digits", GFC_ISYM_DIGITS, GFC_STD_F95); 1790 1791 add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1792 gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim, 1793 x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); 1794 1795 add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, 1796 NULL, gfc_simplify_dim, gfc_resolve_dim, 1797 x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED); 1798 1799 add_sym_2 ("ddim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1800 gfc_check_x_yd, gfc_simplify_dim, gfc_resolve_dim, 1801 x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED); 1802 1803 make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77); 1804 1805 add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, 1806 GFC_STD_F95, gfc_check_dot_product, gfc_simplify_dot_product, gfc_resolve_dot_product, 1807 va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED); 1808 1809 make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95); 1810 1811 add_sym_2 ("dprod", GFC_ISYM_DPROD,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1812 gfc_check_dprod, gfc_simplify_dprod, gfc_resolve_dprod, 1813 x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); 1814 1815 make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77); 1816 1817 add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, 1818 BT_REAL, dd, GFC_STD_GNU, NULL, gfc_simplify_dreal, NULL, 1819 a, BT_COMPLEX, dd, REQUIRED); 1820 1821 make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU); 1822 1823 add_sym_3 ("dshiftl", GFC_ISYM_DSHIFTL, CLASS_ELEMENTAL, ACTUAL_NO, 1824 BT_INTEGER, di, GFC_STD_F2008, 1825 gfc_check_dshift, gfc_simplify_dshiftl, gfc_resolve_dshift, 1826 i, BT_INTEGER, di, REQUIRED, 1827 j, BT_INTEGER, di, REQUIRED, 1828 sh, BT_INTEGER, di, REQUIRED); 1829 1830 make_generic ("dshiftl", GFC_ISYM_DSHIFTL, GFC_STD_F2008); 1831 1832 add_sym_3 ("dshiftr", GFC_ISYM_DSHIFTR, CLASS_ELEMENTAL, ACTUAL_NO, 1833 BT_INTEGER, di, GFC_STD_F2008, 1834 gfc_check_dshift, gfc_simplify_dshiftr, gfc_resolve_dshift, 1835 i, BT_INTEGER, di, REQUIRED, 1836 j, BT_INTEGER, di, REQUIRED, 1837 sh, BT_INTEGER, di, REQUIRED); 1838 1839 make_generic ("dshiftr", GFC_ISYM_DSHIFTR, GFC_STD_F2008); 1840 1841 add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 1842 gfc_check_eoshift, gfc_simplify_eoshift, gfc_resolve_eoshift, 1843 ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, ii, REQUIRED, 1844 bd, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL); 1845 1846 make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95); 1847 1848 add_sym_1 ("epsilon", GFC_ISYM_EPSILON, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, 1849 GFC_STD_F95, gfc_check_fn_r, gfc_simplify_epsilon, NULL, 1850 x, BT_REAL, dr, REQUIRED); 1851 1852 make_generic ("epsilon", GFC_ISYM_EPSILON, GFC_STD_F95); 1853 1854 /* G77 compatibility for the ERF() and ERFC() functions. */ 1855 add_sym_1 ("erf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, 1856 GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erf, 1857 gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); 1858 1859 add_sym_1 ("derf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, 1860 GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erf, 1861 gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); 1862 1863 make_generic ("erf", GFC_ISYM_ERF, GFC_STD_F2008); 1864 1865 add_sym_1 ("erfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, 1866 GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_erfc, 1867 gfc_resolve_g77_math1, x, BT_REAL, dr, REQUIRED); 1868 1869 add_sym_1 ("derfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, 1870 GFC_STD_GNU, gfc_check_fn_d, gfc_simplify_erfc, 1871 gfc_resolve_g77_math1, x, BT_REAL, dd, REQUIRED); 1872 1873 make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_F2008); 1874 1875 add_sym_1 ("erfc_scaled", GFC_ISYM_ERFC_SCALED, CLASS_ELEMENTAL, ACTUAL_NO, 1876 BT_REAL, dr, GFC_STD_F2008, gfc_check_fn_r, 1877 gfc_simplify_erfc_scaled, gfc_resolve_g77_math1, x, BT_REAL, 1878 dr, REQUIRED); 1879 1880 make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008); 1881 1882 /* G77 compatibility */ 1883 add_sym_1 ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL, 1884 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL, 1885 x, BT_REAL, 4, REQUIRED); 1886 1887 make_generic ("dtime", GFC_ISYM_DTIME, GFC_STD_GNU); 1888 1889 add_sym_1 ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL, 1890 4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL, 1891 x, BT_REAL, 4, REQUIRED); 1892 1893 make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU); 1894 1895 add_sym_1 ("exp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 1896 gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp, 1897 x, BT_REAL, dr, REQUIRED); 1898 1899 add_sym_1 ("dexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 1900 gfc_check_fn_d, gfc_simplify_exp, gfc_resolve_exp, 1901 x, BT_REAL, dd, REQUIRED); 1902 1903 add_sym_1 ("cexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, 1904 NULL, gfc_simplify_exp, gfc_resolve_exp, 1905 x, BT_COMPLEX, dz, REQUIRED); 1906 1907 add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, 1908 NULL, gfc_simplify_exp, gfc_resolve_exp, 1909 x, BT_COMPLEX, dd, REQUIRED); 1910 1911 make_alias ("cdexp", GFC_STD_GNU); 1912 1913 make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77); 1914 1915 add_sym_1 ("exponent", GFC_ISYM_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, 1916 GFC_STD_F95, gfc_check_fn_r, gfc_simplify_exponent, gfc_resolve_exponent, 1917 x, BT_REAL, dr, REQUIRED); 1918 1919 make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95); 1920 1921 add_sym_2 ("extends_type_of", GFC_ISYM_EXTENDS_TYPE_OF, CLASS_INQUIRY, 1922 ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, 1923 gfc_check_same_type_as, gfc_simplify_extends_type_of, 1924 gfc_resolve_extends_type_of, 1925 a, BT_UNKNOWN, 0, REQUIRED, 1926 mo, BT_UNKNOWN, 0, REQUIRED); 1927 1928 add_sym_2 ("failed_images", GFC_ISYM_FAILED_IMAGES, CLASS_TRANSFORMATIONAL, 1929 ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2018, 1930 gfc_check_failed_or_stopped_images, 1931 gfc_simplify_failed_or_stopped_images, 1932 gfc_resolve_failed_images, team, BT_VOID, di, OPTIONAL, 1933 kind, BT_INTEGER, di, OPTIONAL); 1934 1935 add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, 1936 dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate); 1937 1938 make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU); 1939 1940 add_sym_2 ("floor", GFC_ISYM_FLOOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 1941 gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor, 1942 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 1943 1944 make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95); 1945 1946 /* G77 compatible fnum */ 1947 add_sym_1 ("fnum", GFC_ISYM_FNUM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 1948 di, GFC_STD_GNU, gfc_check_fnum, NULL, gfc_resolve_fnum, 1949 ut, BT_INTEGER, di, REQUIRED); 1950 1951 make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU); 1952 1953 add_sym_1 ("fraction", GFC_ISYM_FRACTION, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, 1954 GFC_STD_F95, gfc_check_fn_r, gfc_simplify_fraction, gfc_resolve_fraction, 1955 x, BT_REAL, dr, REQUIRED); 1956 1957 make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95); 1958 1959 add_sym_2_intent ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, ACTUAL_NO, 1960 BT_INTEGER, di, GFC_STD_GNU, 1961 gfc_check_fstat, NULL, gfc_resolve_fstat, 1962 ut, BT_INTEGER, di, REQUIRED, INTENT_IN, 1963 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); 1964 1965 make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU); 1966 1967 add_sym_1 ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 1968 ii, GFC_STD_GNU, gfc_check_ftell, NULL, gfc_resolve_ftell, 1969 ut, BT_INTEGER, di, REQUIRED); 1970 1971 make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU); 1972 1973 add_sym_2_intent ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, ACTUAL_NO, 1974 BT_INTEGER, di, GFC_STD_GNU, 1975 gfc_check_fgetputc, NULL, gfc_resolve_fgetc, 1976 ut, BT_INTEGER, di, REQUIRED, INTENT_IN, 1977 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 1978 1979 make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU); 1980 1981 add_sym_1_intent ("fget", GFC_ISYM_FGET, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 1982 di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fget, 1983 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 1984 1985 make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU); 1986 1987 add_sym_2 ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 1988 di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fputc, 1989 ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED); 1990 1991 make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU); 1992 1993 add_sym_1 ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 1994 di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fput, 1995 c, BT_CHARACTER, dc, REQUIRED); 1996 1997 make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU); 1998 1999 add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, 2000 GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma, 2001 gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED); 2002 2003 add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 2004 gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma, 2005 x, BT_REAL, dr, REQUIRED); 2006 2007 make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008); 2008 2009 /* Unix IDs (g77 compatibility) */ 2010 add_sym_1 ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2011 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getcwd, 2012 c, BT_CHARACTER, dc, REQUIRED); 2013 2014 make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU); 2015 2016 add_sym_0 ("getgid", GFC_ISYM_GETGID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2017 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getgid); 2018 2019 make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU); 2020 2021 add_sym_0 ("getpid", GFC_ISYM_GETPID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2022 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getpid); 2023 2024 make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU); 2025 2026 add_sym_1 ("get_team", GFC_ISYM_GET_TEAM, CLASS_TRANSFORMATIONAL, 2027 ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, 2028 gfc_check_get_team, NULL, gfc_resolve_get_team, 2029 level, BT_INTEGER, di, OPTIONAL); 2030 2031 add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2032 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid); 2033 2034 make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU); 2035 2036 add_sym_1_intent ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, ACTUAL_NO, 2037 BT_INTEGER, di, GFC_STD_GNU, 2038 gfc_check_hostnm, NULL, gfc_resolve_hostnm, 2039 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 2040 2041 make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU); 2042 2043 add_sym_1 ("huge", GFC_ISYM_HUGE, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2044 gfc_check_huge, gfc_simplify_huge, NULL, 2045 x, BT_UNKNOWN, dr, REQUIRED); 2046 2047 make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95); 2048 2049 add_sym_2 ("hypot", GFC_ISYM_HYPOT, CLASS_ELEMENTAL, ACTUAL_NO, 2050 BT_REAL, dr, GFC_STD_F2008, 2051 gfc_check_hypot, gfc_simplify_hypot, gfc_resolve_hypot, 2052 x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED); 2053 2054 make_generic ("hypot", GFC_ISYM_HYPOT, GFC_STD_F2008); 2055 2056 add_sym_2 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO, 2057 BT_INTEGER, di, GFC_STD_F95, 2058 gfc_check_ichar_iachar, gfc_simplify_iachar, gfc_resolve_iachar, 2059 c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 2060 2061 make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95); 2062 2063 add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, 2064 GFC_STD_F95, 2065 gfc_check_iand_ieor_ior, gfc_simplify_iand, gfc_resolve_iand, 2066 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); 2067 2068 if (flag_dec_intrinsic_ints) 2069 { 2070 make_alias ("biand", GFC_STD_GNU); 2071 make_alias ("iiand", GFC_STD_GNU); 2072 make_alias ("jiand", GFC_STD_GNU); 2073 make_alias ("kiand", GFC_STD_GNU); 2074 } 2075 2076 make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95); 2077 2078 add_sym_2 ("and", GFC_ISYM_AND, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, 2079 dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_and, gfc_resolve_and, 2080 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); 2081 2082 make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU); 2083 2084 add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, 2085 gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall, 2086 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2087 msk, BT_LOGICAL, dl, OPTIONAL); 2088 2089 make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008); 2090 2091 add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, 2092 gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany, 2093 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2094 msk, BT_LOGICAL, dl, OPTIONAL); 2095 2096 make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008); 2097 2098 add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2099 di, GFC_STD_GNU, NULL, NULL, NULL); 2100 2101 make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU); 2102 2103 add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2104 gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr, 2105 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); 2106 2107 if (flag_dec_intrinsic_ints) 2108 { 2109 make_alias ("bbclr", GFC_STD_GNU); 2110 make_alias ("iibclr", GFC_STD_GNU); 2111 make_alias ("jibclr", GFC_STD_GNU); 2112 make_alias ("kibclr", GFC_STD_GNU); 2113 } 2114 2115 make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95); 2116 2117 add_sym_3 ("ibits", GFC_ISYM_IBITS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2118 gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits, 2119 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED, 2120 ln, BT_INTEGER, di, REQUIRED); 2121 2122 if (flag_dec_intrinsic_ints) 2123 { 2124 make_alias ("bbits", GFC_STD_GNU); 2125 make_alias ("iibits", GFC_STD_GNU); 2126 make_alias ("jibits", GFC_STD_GNU); 2127 make_alias ("kibits", GFC_STD_GNU); 2128 } 2129 2130 make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95); 2131 2132 add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2133 gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset, 2134 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED); 2135 2136 if (flag_dec_intrinsic_ints) 2137 { 2138 make_alias ("bbset", GFC_STD_GNU); 2139 make_alias ("iibset", GFC_STD_GNU); 2140 make_alias ("jibset", GFC_STD_GNU); 2141 make_alias ("kibset", GFC_STD_GNU); 2142 } 2143 2144 make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95); 2145 2146 add_sym_2 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO, 2147 BT_INTEGER, di, GFC_STD_F77, 2148 gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar, 2149 c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 2150 2151 make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77); 2152 2153 add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, 2154 GFC_STD_F95, 2155 gfc_check_iand_ieor_ior, gfc_simplify_ieor, gfc_resolve_ieor, 2156 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); 2157 2158 if (flag_dec_intrinsic_ints) 2159 { 2160 make_alias ("bieor", GFC_STD_GNU); 2161 make_alias ("iieor", GFC_STD_GNU); 2162 make_alias ("jieor", GFC_STD_GNU); 2163 make_alias ("kieor", GFC_STD_GNU); 2164 } 2165 2166 make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95); 2167 2168 add_sym_2 ("xor", GFC_ISYM_XOR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, 2169 dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_xor, gfc_resolve_xor, 2170 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); 2171 2172 make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU); 2173 2174 add_sym_0 ("ierrno", GFC_ISYM_IERRNO, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2175 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_ierrno); 2176 2177 make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU); 2178 2179 add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, 2180 gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index, 2181 ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED); 2182 2183 add_sym_2 ("image_status", GFC_ISYM_IMAGE_STATUS, CLASS_ELEMENTAL, ACTUAL_NO, 2184 BT_INTEGER, di, GFC_STD_F2018, gfc_check_image_status, 2185 gfc_simplify_image_status, gfc_resolve_image_status, image, 2186 BT_INTEGER, di, REQUIRED, team, BT_VOID, di, OPTIONAL); 2187 2188 /* The resolution function for INDEX is called gfc_resolve_index_func 2189 because the name gfc_resolve_index is already used in resolve.c. */ 2190 add_sym_4ind ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, 2191 BT_INTEGER, di, GFC_STD_F77, 2192 gfc_check_index, gfc_simplify_index, gfc_resolve_index_func, 2193 stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED, 2194 bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); 2195 2196 make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77); 2197 2198 add_sym_2 ("int", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, 2199 gfc_check_int, gfc_simplify_int, gfc_resolve_int, 2200 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 2201 2202 add_sym_1 ("ifix", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, 2203 NULL, gfc_simplify_ifix, NULL, 2204 a, BT_REAL, dr, REQUIRED); 2205 2206 add_sym_1 ("idint", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, 2207 NULL, gfc_simplify_idint, NULL, 2208 a, BT_REAL, dd, REQUIRED); 2209 2210 make_generic ("int", GFC_ISYM_INT, GFC_STD_F77); 2211 2212 add_sym_1 ("int2", GFC_ISYM_INT2, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, 2213 gfc_check_intconv, gfc_simplify_int2, gfc_resolve_int2, 2214 a, BT_REAL, dr, REQUIRED); 2215 2216 make_alias ("short", GFC_STD_GNU); 2217 2218 make_generic ("int2", GFC_ISYM_INT2, GFC_STD_GNU); 2219 2220 add_sym_1 ("int8", GFC_ISYM_INT8, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, 2221 gfc_check_intconv, gfc_simplify_int8, gfc_resolve_int8, 2222 a, BT_REAL, dr, REQUIRED); 2223 2224 make_generic ("int8", GFC_ISYM_INT8, GFC_STD_GNU); 2225 2226 add_sym_1 ("long", GFC_ISYM_LONG, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU, 2227 gfc_check_intconv, gfc_simplify_long, gfc_resolve_long, 2228 a, BT_REAL, dr, REQUIRED); 2229 2230 make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU); 2231 2232 add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, 2233 GFC_STD_F95, 2234 gfc_check_iand_ieor_ior, gfc_simplify_ior, gfc_resolve_ior, 2235 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED); 2236 2237 if (flag_dec_intrinsic_ints) 2238 { 2239 make_alias ("bior", GFC_STD_GNU); 2240 make_alias ("iior", GFC_STD_GNU); 2241 make_alias ("jior", GFC_STD_GNU); 2242 make_alias ("kior", GFC_STD_GNU); 2243 } 2244 2245 make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95); 2246 2247 add_sym_2 ("or", GFC_ISYM_OR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, 2248 dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_or, gfc_resolve_or, 2249 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED); 2250 2251 make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU); 2252 2253 add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008, 2254 gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity, 2255 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2256 msk, BT_LOGICAL, dl, OPTIONAL); 2257 2258 make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008); 2259 2260 /* The following function is for G77 compatibility. */ 2261 add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2262 4, GFC_STD_GNU, gfc_check_irand, NULL, NULL, 2263 i, BT_INTEGER, 4, OPTIONAL); 2264 2265 make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU); 2266 2267 add_sym_1 ("isatty", GFC_ISYM_ISATTY, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL, 2268 dl, GFC_STD_GNU, gfc_check_isatty, NULL, gfc_resolve_isatty, 2269 ut, BT_INTEGER, di, REQUIRED); 2270 2271 make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU); 2272 2273 add_sym_1 ("is_contiguous", GFC_ISYM_IS_CONTIGUOUS, CLASS_INQUIRY, ACTUAL_NO, 2274 BT_LOGICAL, dl, GFC_STD_F2008, 2275 gfc_check_is_contiguous, gfc_simplify_is_contiguous, 2276 gfc_resolve_is_contiguous, 2277 ar, BT_REAL, dr, REQUIRED); 2278 2279 make_generic ("is_contiguous", GFC_ISYM_IS_CONTIGUOUS, GFC_STD_F2008); 2280 2281 add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, 2282 CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, 2283 gfc_check_i, gfc_simplify_is_iostat_end, NULL, 2284 i, BT_INTEGER, 0, REQUIRED); 2285 2286 make_generic ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, GFC_STD_F2003); 2287 2288 add_sym_1 ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, 2289 CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003, 2290 gfc_check_i, gfc_simplify_is_iostat_eor, NULL, 2291 i, BT_INTEGER, 0, REQUIRED); 2292 2293 make_generic ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, GFC_STD_F2003); 2294 2295 add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO, 2296 BT_LOGICAL, dl, GFC_STD_GNU, 2297 gfc_check_isnan, gfc_simplify_isnan, NULL, 2298 x, BT_REAL, 0, REQUIRED); 2299 2300 make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU); 2301 2302 add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, 2303 BT_INTEGER, di, GFC_STD_GNU, 2304 gfc_check_ishft, gfc_simplify_rshift, gfc_resolve_rshift, 2305 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); 2306 2307 make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU); 2308 2309 add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, 2310 BT_INTEGER, di, GFC_STD_GNU, 2311 gfc_check_ishft, gfc_simplify_lshift, gfc_resolve_lshift, 2312 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); 2313 2314 make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU); 2315 2316 add_sym_2 ("ishft", GFC_ISYM_ISHFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2317 gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft, 2318 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED); 2319 2320 if (flag_dec_intrinsic_ints) 2321 { 2322 make_alias ("bshft", GFC_STD_GNU); 2323 make_alias ("iishft", GFC_STD_GNU); 2324 make_alias ("jishft", GFC_STD_GNU); 2325 make_alias ("kishft", GFC_STD_GNU); 2326 } 2327 2328 make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95); 2329 2330 add_sym_3 ("ishftc", GFC_ISYM_ISHFTC, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2331 gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc, 2332 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED, 2333 sz, BT_INTEGER, di, OPTIONAL); 2334 2335 if (flag_dec_intrinsic_ints) 2336 { 2337 make_alias ("bshftc", GFC_STD_GNU); 2338 make_alias ("iishftc", GFC_STD_GNU); 2339 make_alias ("jishftc", GFC_STD_GNU); 2340 make_alias ("kishftc", GFC_STD_GNU); 2341 } 2342 2343 make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95); 2344 2345 add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2346 di, GFC_STD_GNU, gfc_check_kill, NULL, NULL, 2347 pid, BT_INTEGER, di, REQUIRED, sig, BT_INTEGER, di, REQUIRED); 2348 2349 make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU); 2350 2351 add_sym_1 ("kind", GFC_ISYM_KIND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2352 gfc_check_kind, gfc_simplify_kind, NULL, 2353 x, BT_REAL, dr, REQUIRED); 2354 2355 make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95); 2356 2357 add_sym_3 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO, 2358 BT_INTEGER, di, GFC_STD_F95, 2359 gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound, 2360 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL, 2361 kind, BT_INTEGER, di, OPTIONAL); 2362 2363 make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95); 2364 2365 add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO, 2366 BT_INTEGER, di, GFC_STD_F2008, 2367 gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound, 2368 ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2369 kind, BT_INTEGER, di, OPTIONAL); 2370 2371 make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008); 2372 2373 add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO, 2374 BT_INTEGER, di, GFC_STD_F2008, 2375 gfc_check_i, gfc_simplify_leadz, NULL, 2376 i, BT_INTEGER, di, REQUIRED); 2377 2378 make_generic ("leadz", GFC_ISYM_LEADZ, GFC_STD_F2008); 2379 2380 add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES, 2381 BT_INTEGER, di, GFC_STD_F77, 2382 gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len, 2383 stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 2384 2385 make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77); 2386 2387 add_sym_2 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO, 2388 BT_INTEGER, di, GFC_STD_F95, 2389 gfc_check_len_lentrim, gfc_simplify_len_trim, gfc_resolve_len_trim, 2390 stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 2391 2392 make_alias ("lnblnk", GFC_STD_GNU); 2393 2394 make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95); 2395 2396 add_sym_1 ("lgamma", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, 2397 dr, GFC_STD_GNU, 2398 gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma, 2399 x, BT_REAL, dr, REQUIRED); 2400 2401 make_alias ("log_gamma", GFC_STD_F2008); 2402 2403 add_sym_1 ("algama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 2404 gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma, 2405 x, BT_REAL, dr, REQUIRED); 2406 2407 add_sym_1 ("dlgama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 2408 gfc_check_fn_d, gfc_simplify_lgamma, gfc_resolve_lgamma, 2409 x, BT_REAL, dr, REQUIRED); 2410 2411 make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008); 2412 2413 2414 add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, 2415 GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL, 2416 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); 2417 2418 make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77); 2419 2420 add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, 2421 GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL, 2422 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); 2423 2424 make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77); 2425 2426 add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, 2427 GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL, 2428 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); 2429 2430 make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77); 2431 2432 add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, 2433 GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL, 2434 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED); 2435 2436 make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77); 2437 2438 add_sym_2 ("link", GFC_ISYM_LINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, 2439 GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link, 2440 p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); 2441 2442 make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU); 2443 2444 add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2445 gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log, 2446 x, BT_REAL, dr, REQUIRED); 2447 2448 add_sym_1 ("alog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 2449 NULL, gfc_simplify_log, gfc_resolve_log, 2450 x, BT_REAL, dr, REQUIRED); 2451 2452 add_sym_1 ("dlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 2453 gfc_check_fn_d, gfc_simplify_log, gfc_resolve_log, 2454 x, BT_REAL, dd, REQUIRED); 2455 2456 add_sym_1 ("clog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, 2457 NULL, gfc_simplify_log, gfc_resolve_log, 2458 x, BT_COMPLEX, dz, REQUIRED); 2459 2460 add_sym_1 ("zlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, 2461 NULL, gfc_simplify_log, gfc_resolve_log, 2462 x, BT_COMPLEX, dd, REQUIRED); 2463 2464 make_alias ("cdlog", GFC_STD_GNU); 2465 2466 make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77); 2467 2468 add_sym_1 ("log10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2469 gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10, 2470 x, BT_REAL, dr, REQUIRED); 2471 2472 add_sym_1 ("alog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 2473 NULL, gfc_simplify_log10, gfc_resolve_log10, 2474 x, BT_REAL, dr, REQUIRED); 2475 2476 add_sym_1 ("dlog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 2477 gfc_check_fn_d, gfc_simplify_log10, gfc_resolve_log10, 2478 x, BT_REAL, dd, REQUIRED); 2479 2480 make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77); 2481 2482 add_sym_2 ("logical", GFC_ISYM_LOGICAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95, 2483 gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical, 2484 l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 2485 2486 make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95); 2487 2488 add_sym_2_intent ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, ACTUAL_NO, 2489 BT_INTEGER, di, GFC_STD_GNU, 2490 gfc_check_stat, NULL, gfc_resolve_lstat, 2491 nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 2492 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); 2493 2494 make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU); 2495 2496 add_sym_1 ("malloc", GFC_ISYM_MALLOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, 2497 GFC_STD_GNU, gfc_check_malloc, NULL, NULL, 2498 sz, BT_INTEGER, di, REQUIRED); 2499 2500 make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU); 2501 2502 add_sym_2 ("maskl", GFC_ISYM_MASKL, CLASS_ELEMENTAL, ACTUAL_NO, 2503 BT_INTEGER, di, GFC_STD_F2008, 2504 gfc_check_mask, gfc_simplify_maskl, gfc_resolve_mask, 2505 i, BT_INTEGER, di, REQUIRED, 2506 kind, BT_INTEGER, di, OPTIONAL); 2507 2508 make_generic ("maskl", GFC_ISYM_MASKL, GFC_STD_F2008); 2509 2510 add_sym_2 ("maskr", GFC_ISYM_MASKR, CLASS_ELEMENTAL, ACTUAL_NO, 2511 BT_INTEGER, di, GFC_STD_F2008, 2512 gfc_check_mask, gfc_simplify_maskr, gfc_resolve_mask, 2513 i, BT_INTEGER, di, REQUIRED, 2514 kind, BT_INTEGER, di, OPTIONAL); 2515 2516 make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008); 2517 2518 add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2519 gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul, 2520 ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED); 2521 2522 make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95); 2523 2524 /* Note: amax0 is equivalent to real(max), max1 is equivalent to 2525 int(max). The max function must take at least two arguments. */ 2526 2527 add_sym_1m ("max", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77, 2528 gfc_check_min_max, gfc_simplify_max, gfc_resolve_max, 2529 a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED); 2530 2531 add_sym_1m ("max0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, 2532 gfc_check_min_max_integer, gfc_simplify_max, NULL, 2533 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); 2534 2535 add_sym_1m ("amax0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2536 gfc_check_min_max_integer, gfc_simplify_max, NULL, 2537 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); 2538 2539 add_sym_1m ("amax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2540 gfc_check_min_max_real, gfc_simplify_max, NULL, 2541 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); 2542 2543 add_sym_1m ("max1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, 2544 gfc_check_min_max_real, gfc_simplify_max, NULL, 2545 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); 2546 2547 add_sym_1m ("dmax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, 2548 gfc_check_min_max_double, gfc_simplify_max, NULL, 2549 a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED); 2550 2551 make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77); 2552 2553 add_sym_1 ("maxexponent", GFC_ISYM_MAXEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, 2554 di, GFC_STD_F95, gfc_check_fn_r, gfc_simplify_maxexponent, NULL, 2555 x, BT_UNKNOWN, dr, REQUIRED); 2556 2557 make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95); 2558 2559 add_sym_5ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2560 gfc_check_minloc_maxloc, gfc_simplify_maxloc, gfc_resolve_maxloc, 2561 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2562 msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL, 2563 bck, BT_LOGICAL, dl, OPTIONAL); 2564 2565 make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95); 2566 2567 add_sym_6fl ("findloc", GFC_ISYM_FINDLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, 2568 BT_INTEGER, di, GFC_STD_F2008, 2569 gfc_check_findloc, gfc_simplify_findloc, gfc_resolve_findloc, 2570 ar, BT_REAL, dr, REQUIRED, val, BT_REAL, dr, REQUIRED, 2571 dm, BT_INTEGER, ii, OPTIONAL, msk, BT_LOGICAL, dl, OPTIONAL, 2572 kind, BT_INTEGER, di, OPTIONAL, bck, BT_LOGICAL, dl, OPTIONAL); 2573 2574 make_generic ("findloc", GFC_ISYM_FINDLOC, GFC_STD_F2008); 2575 2576 add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2577 gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval, 2578 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2579 msk, BT_LOGICAL, dl, OPTIONAL); 2580 2581 make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95); 2582 2583 add_sym_0 ("mclock", GFC_ISYM_MCLOCK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, 2584 GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock); 2585 2586 make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU); 2587 2588 add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2589 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8); 2590 2591 make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU); 2592 2593 add_sym_3 ("merge", GFC_ISYM_MERGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2594 gfc_check_merge, gfc_simplify_merge, gfc_resolve_merge, 2595 ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED, 2596 msk, BT_LOGICAL, dl, REQUIRED); 2597 2598 make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95); 2599 2600 add_sym_3 ("merge_bits", GFC_ISYM_MERGE_BITS, CLASS_ELEMENTAL, ACTUAL_NO, 2601 BT_INTEGER, di, GFC_STD_F2008, 2602 gfc_check_merge_bits, gfc_simplify_merge_bits, 2603 gfc_resolve_merge_bits, 2604 i, BT_INTEGER, di, REQUIRED, 2605 j, BT_INTEGER, di, REQUIRED, 2606 msk, BT_INTEGER, di, REQUIRED); 2607 2608 make_generic ("merge_bits", GFC_ISYM_MERGE_BITS, GFC_STD_F2008); 2609 2610 /* Note: amin0 is equivalent to real(min), min1 is equivalent to 2611 int(min). */ 2612 2613 add_sym_1m ("min", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77, 2614 gfc_check_min_max, gfc_simplify_min, gfc_resolve_min, 2615 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); 2616 2617 add_sym_1m ("min0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, 2618 gfc_check_min_max_integer, gfc_simplify_min, NULL, 2619 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); 2620 2621 add_sym_1m ("amin0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2622 gfc_check_min_max_integer, gfc_simplify_min, NULL, 2623 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED); 2624 2625 add_sym_1m ("amin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2626 gfc_check_min_max_real, gfc_simplify_min, NULL, 2627 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); 2628 2629 add_sym_1m ("min1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77, 2630 gfc_check_min_max_real, gfc_simplify_min, NULL, 2631 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED); 2632 2633 add_sym_1m ("dmin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77, 2634 gfc_check_min_max_double, gfc_simplify_min, NULL, 2635 a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED); 2636 2637 make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77); 2638 2639 add_sym_1 ("minexponent", GFC_ISYM_MINEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, 2640 di, GFC_STD_F95, gfc_check_fn_r, gfc_simplify_minexponent, NULL, 2641 x, BT_UNKNOWN, dr, REQUIRED); 2642 2643 make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95); 2644 2645 add_sym_5ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2646 gfc_check_minloc_maxloc, gfc_simplify_minloc, gfc_resolve_minloc, 2647 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2648 msk, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL, 2649 bck, BT_LOGICAL, dl, OPTIONAL); 2650 2651 make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95); 2652 2653 add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2654 gfc_check_minval_maxval, gfc_simplify_minval, gfc_resolve_minval, 2655 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2656 msk, BT_LOGICAL, dl, OPTIONAL); 2657 2658 make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95); 2659 2660 add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, 2661 gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod, 2662 a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED); 2663 2664 if (flag_dec_intrinsic_ints) 2665 { 2666 make_alias ("bmod", GFC_STD_GNU); 2667 make_alias ("imod", GFC_STD_GNU); 2668 make_alias ("jmod", GFC_STD_GNU); 2669 make_alias ("kmod", GFC_STD_GNU); 2670 } 2671 2672 add_sym_2 ("amod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 2673 NULL, gfc_simplify_mod, gfc_resolve_mod, 2674 a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED); 2675 2676 add_sym_2 ("dmod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 2677 gfc_check_x_yd, gfc_simplify_mod, gfc_resolve_mod, 2678 a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED); 2679 2680 make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77); 2681 2682 add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95, 2683 gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo, 2684 a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED); 2685 2686 make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95); 2687 2688 add_sym_2 ("nearest", GFC_ISYM_NEAREST, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2689 gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest, 2690 x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED); 2691 2692 make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95); 2693 2694 add_sym_1 ("new_line", GFC_ISYM_NEW_LINE, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc, 2695 GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL, 2696 a, BT_CHARACTER, dc, REQUIRED); 2697 2698 make_generic ("new_line", GFC_ISYM_NEW_LINE, GFC_STD_F2003); 2699 2700 add_sym_2 ("nint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, 2701 gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint, 2702 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 2703 2704 add_sym_1 ("idnint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, 2705 gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint, 2706 a, BT_REAL, dd, REQUIRED); 2707 2708 make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77); 2709 2710 add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2711 gfc_check_i, gfc_simplify_not, gfc_resolve_not, 2712 i, BT_INTEGER, di, REQUIRED); 2713 2714 if (flag_dec_intrinsic_ints) 2715 { 2716 make_alias ("bnot", GFC_STD_GNU); 2717 make_alias ("inot", GFC_STD_GNU); 2718 make_alias ("jnot", GFC_STD_GNU); 2719 make_alias ("knot", GFC_STD_GNU); 2720 } 2721 2722 make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95); 2723 2724 add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, 2725 GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2, 2726 x, BT_REAL, dr, REQUIRED, 2727 dm, BT_INTEGER, ii, OPTIONAL); 2728 2729 make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008); 2730 2731 add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2732 gfc_check_null, gfc_simplify_null, NULL, 2733 mo, BT_INTEGER, di, OPTIONAL); 2734 2735 make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95); 2736 2737 add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_TRANSFORMATIONAL, 2738 ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, 2739 gfc_check_num_images, gfc_simplify_num_images, NULL, 2740 dist, BT_INTEGER, di, OPTIONAL, 2741 failed, BT_LOGICAL, dl, OPTIONAL); 2742 2743 add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2744 gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack, 2745 ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, 2746 v, BT_REAL, dr, OPTIONAL); 2747 2748 make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95); 2749 2750 2751 add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, 2752 GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity, 2753 msk, BT_LOGICAL, dl, REQUIRED, 2754 dm, BT_INTEGER, ii, OPTIONAL); 2755 2756 make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008); 2757 2758 add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO, 2759 BT_INTEGER, di, GFC_STD_F2008, 2760 gfc_check_i, gfc_simplify_popcnt, NULL, 2761 i, BT_INTEGER, di, REQUIRED); 2762 2763 make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008); 2764 2765 add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO, 2766 BT_INTEGER, di, GFC_STD_F2008, 2767 gfc_check_i, gfc_simplify_poppar, NULL, 2768 i, BT_INTEGER, di, REQUIRED); 2769 2770 make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008); 2771 2772 add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2773 gfc_check_precision, gfc_simplify_precision, NULL, 2774 x, BT_UNKNOWN, 0, REQUIRED); 2775 2776 make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95); 2777 2778 add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO, 2779 BT_LOGICAL, dl, GFC_STD_F95, gfc_check_present, NULL, NULL, 2780 a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN); 2781 2782 make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95); 2783 2784 add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2785 gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product, 2786 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 2787 msk, BT_LOGICAL, dl, OPTIONAL); 2788 2789 make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95); 2790 2791 add_sym_1 ("radix", GFC_ISYM_RADIX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2792 gfc_check_radix, gfc_simplify_radix, NULL, 2793 x, BT_UNKNOWN, 0, REQUIRED); 2794 2795 make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95); 2796 2797 /* The following function is for G77 compatibility. */ 2798 add_sym_1 ("rand", GFC_ISYM_RAND, CLASS_IMPURE, ACTUAL_NO, BT_REAL, 2799 4, GFC_STD_GNU, gfc_check_rand, NULL, NULL, 2800 i, BT_INTEGER, 4, OPTIONAL); 2801 2802 /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran() 2803 use slightly different shoddy multiplicative congruential PRNG. */ 2804 make_alias ("ran", GFC_STD_GNU); 2805 2806 make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU); 2807 2808 add_sym_1 ("range", GFC_ISYM_RANGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2809 gfc_check_range, gfc_simplify_range, NULL, 2810 x, BT_REAL, dr, REQUIRED); 2811 2812 make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95); 2813 2814 add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, 2815 GFC_STD_F2018, gfc_check_rank, gfc_simplify_rank, gfc_resolve_rank, 2816 a, BT_REAL, dr, REQUIRED); 2817 make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2018); 2818 2819 add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2820 gfc_check_real, gfc_simplify_real, gfc_resolve_real, 2821 a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); 2822 2823 make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77); 2824 2825 /* This provides compatibility with g77. */ 2826 add_sym_1 ("realpart", GFC_ISYM_REALPART, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU, 2827 gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart, 2828 a, BT_UNKNOWN, dr, REQUIRED); 2829 2830 make_generic ("realpart", GFC_ISYM_REALPART, GFC_STD_F77); 2831 2832 add_sym_1 ("float", GFC_ISYM_FLOAT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2833 gfc_check_float, gfc_simplify_float, NULL, 2834 a, BT_INTEGER, di, REQUIRED); 2835 2836 if (flag_dec_intrinsic_ints) 2837 { 2838 make_alias ("floati", GFC_STD_GNU); 2839 make_alias ("floatj", GFC_STD_GNU); 2840 make_alias ("floatk", GFC_STD_GNU); 2841 } 2842 2843 make_generic ("float", GFC_ISYM_FLOAT, GFC_STD_F77); 2844 2845 add_sym_1 ("dfloat", GFC_ISYM_DFLOAT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU, 2846 gfc_check_float, gfc_simplify_dble, gfc_resolve_dble, 2847 a, BT_REAL, dr, REQUIRED); 2848 2849 make_generic ("dfloat", GFC_ISYM_DFLOAT, GFC_STD_F77); 2850 2851 add_sym_1 ("sngl", GFC_ISYM_SNGL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, 2852 gfc_check_sngl, gfc_simplify_sngl, NULL, 2853 a, BT_REAL, dd, REQUIRED); 2854 2855 make_generic ("sngl", GFC_ISYM_SNGL, GFC_STD_F77); 2856 2857 add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, 2858 GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename, 2859 p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); 2860 2861 make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU); 2862 2863 add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, 2864 gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat, 2865 stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED); 2866 2867 make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95); 2868 2869 add_sym_4 ("reshape", GFC_ISYM_RESHAPE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2870 gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape, 2871 src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED, 2872 pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL); 2873 2874 make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95); 2875 2876 add_sym_1 ("rrspacing", GFC_ISYM_RRSPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, 2877 GFC_STD_F95, gfc_check_fn_r, gfc_simplify_rrspacing, gfc_resolve_rrspacing, 2878 x, BT_REAL, dr, REQUIRED); 2879 2880 make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95); 2881 2882 add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO, 2883 BT_LOGICAL, dl, GFC_STD_F2003, 2884 gfc_check_same_type_as, gfc_simplify_same_type_as, NULL, 2885 a, BT_UNKNOWN, 0, REQUIRED, 2886 b, BT_UNKNOWN, 0, REQUIRED); 2887 2888 add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2889 gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale, 2890 x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); 2891 2892 make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95); 2893 2894 add_sym_4 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO, 2895 BT_INTEGER, di, GFC_STD_F95, 2896 gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan, 2897 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED, 2898 bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); 2899 2900 make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95); 2901 2902 /* Added for G77 compatibility garbage. */ 2903 add_sym_0 ("second", GFC_ISYM_SECOND, CLASS_IMPURE, ACTUAL_NO, BT_REAL, 2904 4, GFC_STD_GNU, NULL, NULL, NULL); 2905 2906 make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU); 2907 2908 /* Added for G77 compatibility. */ 2909 add_sym_1 ("secnds", GFC_ISYM_SECNDS, CLASS_IMPURE, ACTUAL_NO, BT_REAL, 2910 dr, GFC_STD_GNU, gfc_check_secnds, NULL, gfc_resolve_secnds, 2911 x, BT_REAL, dr, REQUIRED); 2912 2913 make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU); 2914 2915 add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL, 2916 ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, 2917 gfc_check_selected_char_kind, gfc_simplify_selected_char_kind, 2918 NULL, nm, BT_CHARACTER, dc, REQUIRED); 2919 2920 make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003); 2921 2922 add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, 2923 GFC_STD_F95, gfc_check_selected_int_kind, 2924 gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED); 2925 2926 make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95); 2927 2928 add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, 2929 GFC_STD_F95, gfc_check_selected_real_kind, 2930 gfc_simplify_selected_real_kind, NULL, 2931 p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL, 2932 "radix", BT_INTEGER, di, OPTIONAL); 2933 2934 make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95); 2935 2936 add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 2937 gfc_check_set_exponent, gfc_simplify_set_exponent, 2938 gfc_resolve_set_exponent, 2939 x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED); 2940 2941 make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95); 2942 2943 add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95, 2944 gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape, 2945 src, BT_REAL, dr, REQUIRED, 2946 kind, BT_INTEGER, di, OPTIONAL); 2947 2948 make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95); 2949 2950 add_sym_2 ("shifta", GFC_ISYM_SHIFTA, CLASS_ELEMENTAL, ACTUAL_NO, 2951 BT_INTEGER, di, GFC_STD_F2008, 2952 gfc_check_shift, gfc_simplify_shifta, gfc_resolve_shift, 2953 i, BT_INTEGER, di, REQUIRED, 2954 sh, BT_INTEGER, di, REQUIRED); 2955 2956 make_generic ("shifta", GFC_ISYM_SHIFTA, GFC_STD_F2008); 2957 2958 add_sym_2 ("shiftl", GFC_ISYM_SHIFTL, CLASS_ELEMENTAL, ACTUAL_NO, 2959 BT_INTEGER, di, GFC_STD_F2008, 2960 gfc_check_shift, gfc_simplify_shiftl, gfc_resolve_shift, 2961 i, BT_INTEGER, di, REQUIRED, 2962 sh, BT_INTEGER, di, REQUIRED); 2963 2964 make_generic ("shiftl", GFC_ISYM_SHIFTL, GFC_STD_F2008); 2965 2966 add_sym_2 ("shiftr", GFC_ISYM_SHIFTR, CLASS_ELEMENTAL, ACTUAL_NO, 2967 BT_INTEGER, di, GFC_STD_F2008, 2968 gfc_check_shift, gfc_simplify_shiftr, gfc_resolve_shift, 2969 i, BT_INTEGER, di, REQUIRED, 2970 sh, BT_INTEGER, di, REQUIRED); 2971 2972 make_generic ("shiftr", GFC_ISYM_SHIFTR, GFC_STD_F2008); 2973 2974 add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 2975 gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign, 2976 a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED); 2977 2978 add_sym_2 ("isign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77, 2979 NULL, gfc_simplify_sign, gfc_resolve_sign, 2980 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED); 2981 2982 add_sym_2 ("dsign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 2983 gfc_check_x_yd, gfc_simplify_sign, gfc_resolve_sign, 2984 a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED); 2985 2986 make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77); 2987 2988 add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 2989 di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal, 2990 num, BT_INTEGER, di, REQUIRED, han, BT_VOID, 0, REQUIRED); 2991 2992 make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU); 2993 2994 add_sym_1 ("sin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 2995 gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin, 2996 x, BT_REAL, dr, REQUIRED); 2997 2998 add_sym_1 ("dsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 2999 gfc_check_fn_d, gfc_simplify_sin, gfc_resolve_sin, 3000 x, BT_REAL, dd, REQUIRED); 3001 3002 add_sym_1 ("csin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, 3003 NULL, gfc_simplify_sin, gfc_resolve_sin, 3004 x, BT_COMPLEX, dz, REQUIRED); 3005 3006 add_sym_1 ("zsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, 3007 NULL, gfc_simplify_sin, gfc_resolve_sin, 3008 x, BT_COMPLEX, dd, REQUIRED); 3009 3010 make_alias ("cdsin", GFC_STD_GNU); 3011 3012 make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77); 3013 3014 add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 3015 gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh, 3016 x, BT_REAL, dr, REQUIRED); 3017 3018 add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 3019 gfc_check_fn_d, gfc_simplify_sinh, gfc_resolve_sinh, 3020 x, BT_REAL, dd, REQUIRED); 3021 3022 make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77); 3023 3024 add_sym_3 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO, 3025 BT_INTEGER, di, GFC_STD_F95, 3026 gfc_check_size, gfc_simplify_size, gfc_resolve_size, 3027 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 3028 kind, BT_INTEGER, di, OPTIONAL); 3029 3030 make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95); 3031 3032 /* Obtain the stride for a given dimensions; to be used only internally. 3033 "make_from_module" makes it inaccessible for external users. */ 3034 add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO, 3035 BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU, 3036 NULL, NULL, gfc_resolve_stride, 3037 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); 3038 make_from_module(); 3039 3040 add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, 3041 BT_INTEGER, ii, GFC_STD_GNU, 3042 gfc_check_sizeof, gfc_simplify_sizeof, NULL, 3043 x, BT_UNKNOWN, 0, REQUIRED); 3044 3045 make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU); 3046 3047 /* The following functions are part of ISO_C_BINDING. */ 3048 add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, 3049 BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL, 3050 c_ptr_1, BT_VOID, 0, REQUIRED, 3051 c_ptr_2, BT_VOID, 0, OPTIONAL); 3052 make_from_module(); 3053 3054 add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO, 3055 BT_VOID, 0, GFC_STD_F2003, 3056 gfc_check_c_loc, NULL, gfc_resolve_c_loc, 3057 x, BT_UNKNOWN, 0, REQUIRED); 3058 make_from_module(); 3059 3060 add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO, 3061 BT_VOID, 0, GFC_STD_F2003, 3062 gfc_check_c_funloc, NULL, gfc_resolve_c_funloc, 3063 x, BT_UNKNOWN, 0, REQUIRED); 3064 make_from_module(); 3065 3066 add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO, 3067 BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008, 3068 gfc_check_c_sizeof, gfc_simplify_sizeof, NULL, 3069 x, BT_UNKNOWN, 0, REQUIRED); 3070 make_from_module(); 3071 3072 /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */ 3073 add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY, 3074 ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008, 3075 NULL, gfc_simplify_compiler_options, NULL); 3076 make_from_module(); 3077 3078 add_sym_0 ("compiler_version", GFC_ISYM_COMPILER_VERSION, CLASS_INQUIRY, 3079 ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008, 3080 NULL, gfc_simplify_compiler_version, NULL); 3081 make_from_module(); 3082 3083 add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, 3084 GFC_STD_F95, gfc_check_fn_r, gfc_simplify_spacing, gfc_resolve_spacing, 3085 x, BT_REAL, dr, REQUIRED); 3086 3087 make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95); 3088 3089 add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 3090 gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread, 3091 src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED, 3092 ncopies, BT_INTEGER, di, REQUIRED); 3093 3094 make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95); 3095 3096 add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 3097 gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt, 3098 x, BT_REAL, dr, REQUIRED); 3099 3100 add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 3101 gfc_check_fn_d, gfc_simplify_sqrt, gfc_resolve_sqrt, 3102 x, BT_REAL, dd, REQUIRED); 3103 3104 add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77, 3105 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, 3106 x, BT_COMPLEX, dz, REQUIRED); 3107 3108 add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU, 3109 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, 3110 x, BT_COMPLEX, dd, REQUIRED); 3111 3112 make_alias ("cdsqrt", GFC_STD_GNU); 3113 3114 make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77); 3115 3116 add_sym_2_intent ("stat", GFC_ISYM_STAT, CLASS_IMPURE, ACTUAL_NO, 3117 BT_INTEGER, di, GFC_STD_GNU, 3118 gfc_check_stat, NULL, gfc_resolve_stat, 3119 nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3120 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); 3121 3122 make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU); 3123 3124 add_sym_2 ("stopped_images", GFC_ISYM_STOPPED_IMAGES, CLASS_TRANSFORMATIONAL, 3125 ACTUAL_NO, BT_INTEGER, dd, GFC_STD_F2018, 3126 gfc_check_failed_or_stopped_images, 3127 gfc_simplify_failed_or_stopped_images, 3128 gfc_resolve_stopped_images, team, BT_VOID, di, OPTIONAL, 3129 kind, BT_INTEGER, di, OPTIONAL); 3130 3131 add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO, 3132 BT_INTEGER, di, GFC_STD_F2008, 3133 gfc_check_storage_size, gfc_simplify_storage_size, 3134 gfc_resolve_storage_size, 3135 a, BT_UNKNOWN, 0, REQUIRED, 3136 kind, BT_INTEGER, di, OPTIONAL); 3137 3138 add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 3139 gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum, 3140 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 3141 msk, BT_LOGICAL, dl, OPTIONAL); 3142 3143 make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95); 3144 3145 add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, 3146 GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk, 3147 p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED); 3148 3149 make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU); 3150 3151 add_sym_1 ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, 3152 GFC_STD_GNU, NULL, NULL, NULL, 3153 com, BT_CHARACTER, dc, REQUIRED); 3154 3155 make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU); 3156 3157 add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 3158 gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan, 3159 x, BT_REAL, dr, REQUIRED); 3160 3161 add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 3162 gfc_check_fn_d, gfc_simplify_tan, gfc_resolve_tan, 3163 x, BT_REAL, dd, REQUIRED); 3164 3165 make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77); 3166 3167 add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77, 3168 gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh, 3169 x, BT_REAL, dr, REQUIRED); 3170 3171 add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77, 3172 gfc_check_fn_d, gfc_simplify_tanh, gfc_resolve_tanh, 3173 x, BT_REAL, dd, REQUIRED); 3174 3175 make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77); 3176 3177 add_sym_1 ("team_number", GFC_ISYM_TEAM_NUMBER, CLASS_TRANSFORMATIONAL, 3178 ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2018, 3179 gfc_check_team_number, NULL, gfc_resolve_team_number, 3180 team, BT_DERIVED, di, OPTIONAL); 3181 3182 add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008, 3183 gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image, 3184 ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL, 3185 dist, BT_INTEGER, di, OPTIONAL); 3186 3187 add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 3188 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time); 3189 3190 make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU); 3191 3192 add_sym_0 ("time8", GFC_ISYM_TIME8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 3193 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time8); 3194 3195 make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU); 3196 3197 add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 3198 gfc_check_fn_r, gfc_simplify_tiny, NULL, x, BT_REAL, dr, REQUIRED); 3199 3200 make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95); 3201 3202 add_sym_1 ("trailz", GFC_ISYM_TRAILZ, CLASS_ELEMENTAL, ACTUAL_NO, 3203 BT_INTEGER, di, GFC_STD_F2008, 3204 gfc_check_i, gfc_simplify_trailz, NULL, 3205 i, BT_INTEGER, di, REQUIRED); 3206 3207 make_generic ("trailz", GFC_ISYM_TRAILZ, GFC_STD_F2008); 3208 3209 add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 3210 gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer, 3211 src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED, 3212 sz, BT_INTEGER, di, OPTIONAL); 3213 3214 make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95); 3215 3216 add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 3217 gfc_check_transpose, gfc_simplify_transpose, gfc_resolve_transpose, 3218 m, BT_REAL, dr, REQUIRED); 3219 3220 make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95); 3221 3222 add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95, 3223 gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim, 3224 stg, BT_CHARACTER, dc, REQUIRED); 3225 3226 make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95); 3227 3228 add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER, 3229 0, GFC_STD_GNU, gfc_check_ttynam, NULL, gfc_resolve_ttynam, 3230 ut, BT_INTEGER, di, REQUIRED); 3231 3232 make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU); 3233 3234 add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO, 3235 BT_INTEGER, di, GFC_STD_F95, 3236 gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound, 3237 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 3238 kind, BT_INTEGER, di, OPTIONAL); 3239 3240 make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95); 3241 3242 add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO, 3243 BT_INTEGER, di, GFC_STD_F2008, 3244 gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound, 3245 ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL, 3246 kind, BT_INTEGER, di, OPTIONAL); 3247 3248 make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008); 3249 3250 /* g77 compatibility for UMASK. */ 3251 add_sym_1 ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di, 3252 GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask, 3253 msk, BT_INTEGER, di, REQUIRED); 3254 3255 make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU); 3256 3257 /* g77 compatibility for UNLINK. */ 3258 add_sym_1 ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, 3259 di, GFC_STD_GNU, gfc_check_unlink, NULL, gfc_resolve_unlink, 3260 "path", BT_CHARACTER, dc, REQUIRED); 3261 3262 make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU); 3263 3264 add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, 3265 gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack, 3266 v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED, 3267 f, BT_REAL, dr, REQUIRED); 3268 3269 make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95); 3270 3271 add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO, 3272 BT_INTEGER, di, GFC_STD_F95, 3273 gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify, 3274 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED, 3275 bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL); 3276 3277 make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95); 3278 3279 add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii, 3280 GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc, 3281 x, BT_UNKNOWN, 0, REQUIRED); 3282 3283 make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU); 3284 3285 3286 /* The next of intrinsic subprogram are the degree trignometric functions. 3287 These were hidden behind the -fdec-math option, but are now simply 3288 included as extensions to the set of intrinsic subprograms. */ 3289 3290 add_sym_1 ("acosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, 3291 BT_REAL, dr, GFC_STD_GNU, 3292 gfc_check_fn_r, gfc_simplify_acosd, gfc_resolve_trigd, 3293 x, BT_REAL, dr, REQUIRED); 3294 3295 add_sym_1 ("dacosd", GFC_ISYM_ACOSD, CLASS_ELEMENTAL, ACTUAL_YES, 3296 BT_REAL, dd, GFC_STD_GNU, 3297 gfc_check_fn_d, gfc_simplify_acosd, gfc_resolve_trigd, 3298 x, BT_REAL, dd, REQUIRED); 3299 3300 make_generic ("acosd", GFC_ISYM_ACOSD, GFC_STD_GNU); 3301 3302 add_sym_1 ("asind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, 3303 BT_REAL, dr, GFC_STD_GNU, 3304 gfc_check_fn_r, gfc_simplify_asind, gfc_resolve_trigd, 3305 x, BT_REAL, dr, REQUIRED); 3306 3307 add_sym_1 ("dasind", GFC_ISYM_ASIND, CLASS_ELEMENTAL, ACTUAL_YES, 3308 BT_REAL, dd, GFC_STD_GNU, 3309 gfc_check_fn_d, gfc_simplify_asind, gfc_resolve_trigd, 3310 x, BT_REAL, dd, REQUIRED); 3311 3312 make_generic ("asind", GFC_ISYM_ASIND, GFC_STD_GNU); 3313 3314 add_sym_1 ("atand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, 3315 BT_REAL, dr, GFC_STD_GNU, 3316 gfc_check_fn_r, gfc_simplify_atand, gfc_resolve_trigd, 3317 x, BT_REAL, dr, REQUIRED); 3318 3319 add_sym_1 ("datand", GFC_ISYM_ATAND, CLASS_ELEMENTAL, ACTUAL_YES, 3320 BT_REAL, dd, GFC_STD_GNU, 3321 gfc_check_fn_d, gfc_simplify_atand, gfc_resolve_trigd, 3322 x, BT_REAL, dd, REQUIRED); 3323 3324 make_generic ("atand", GFC_ISYM_ATAND, GFC_STD_GNU); 3325 3326 add_sym_2 ("atan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, 3327 BT_REAL, dr, GFC_STD_GNU, 3328 gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_trigd2, 3329 y, BT_REAL, dr, REQUIRED, 3330 x, BT_REAL, dr, REQUIRED); 3331 3332 add_sym_2 ("datan2d", GFC_ISYM_ATAN2D, CLASS_ELEMENTAL, ACTUAL_YES, 3333 BT_REAL, dd, GFC_STD_GNU, 3334 gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_trigd2, 3335 y, BT_REAL, dd, REQUIRED, 3336 x, BT_REAL, dd, REQUIRED); 3337 3338 make_generic ("atan2d", GFC_ISYM_ATAN2D, GFC_STD_GNU); 3339 3340 add_sym_1 ("cosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, 3341 BT_REAL, dr, GFC_STD_GNU, 3342 gfc_check_fn_r, gfc_simplify_cosd, gfc_resolve_trigd, 3343 x, BT_REAL, dr, REQUIRED); 3344 3345 add_sym_1 ("dcosd", GFC_ISYM_COSD, CLASS_ELEMENTAL, ACTUAL_YES, 3346 BT_REAL, dd, GFC_STD_GNU, 3347 gfc_check_fn_d, gfc_simplify_cosd, gfc_resolve_trigd, 3348 x, BT_REAL, dd, REQUIRED); 3349 3350 make_generic ("cosd", GFC_ISYM_COSD, GFC_STD_GNU); 3351 3352 add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, 3353 BT_REAL, dr, GFC_STD_GNU, 3354 gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_trigd, 3355 x, BT_REAL, dr, REQUIRED); 3356 3357 add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, 3358 BT_REAL, dd, GFC_STD_GNU, 3359 gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_trigd, 3360 x, BT_REAL, dd, REQUIRED); 3361 3362 add_sym_1 ("ccotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, 3363 BT_COMPLEX, dz, GFC_STD_GNU, 3364 NULL, gfc_simplify_cotan, gfc_resolve_trigd, 3365 x, BT_COMPLEX, dz, REQUIRED); 3366 3367 add_sym_1 ("zcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, 3368 BT_COMPLEX, dd, GFC_STD_GNU, 3369 NULL, gfc_simplify_cotan, gfc_resolve_trigd, 3370 x, BT_COMPLEX, dd, REQUIRED); 3371 3372 make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU); 3373 3374 add_sym_1 ("cotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, 3375 BT_REAL, dr, GFC_STD_GNU, 3376 gfc_check_fn_r, gfc_simplify_cotand, gfc_resolve_trigd, 3377 x, BT_REAL, dr, REQUIRED); 3378 3379 add_sym_1 ("dcotand", GFC_ISYM_COTAND, CLASS_ELEMENTAL, ACTUAL_YES, 3380 BT_REAL, dd, GFC_STD_GNU, 3381 gfc_check_fn_d, gfc_simplify_cotand, gfc_resolve_trigd, 3382 x, BT_REAL, dd, REQUIRED); 3383 3384 make_generic ("cotand", GFC_ISYM_COTAND, GFC_STD_GNU); 3385 3386 add_sym_1 ("sind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, 3387 BT_REAL, dr, GFC_STD_GNU, 3388 gfc_check_fn_r, gfc_simplify_sind, gfc_resolve_trigd, 3389 x, BT_REAL, dr, REQUIRED); 3390 3391 add_sym_1 ("dsind", GFC_ISYM_SIND, CLASS_ELEMENTAL, ACTUAL_YES, 3392 BT_REAL, dd, GFC_STD_GNU, 3393 gfc_check_fn_d, gfc_simplify_sind, gfc_resolve_trigd, 3394 x, BT_REAL, dd, REQUIRED); 3395 3396 make_generic ("sind", GFC_ISYM_SIND, GFC_STD_GNU); 3397 3398 add_sym_1 ("tand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, 3399 BT_REAL, dr, GFC_STD_GNU, 3400 gfc_check_fn_r, gfc_simplify_tand, gfc_resolve_trigd, 3401 x, BT_REAL, dr, REQUIRED); 3402 3403 add_sym_1 ("dtand", GFC_ISYM_TAND, CLASS_ELEMENTAL, ACTUAL_YES, 3404 BT_REAL, dd, GFC_STD_GNU, 3405 gfc_check_fn_d, gfc_simplify_tand, gfc_resolve_trigd, 3406 x, BT_REAL, dd, REQUIRED); 3407 3408 make_generic ("tand", GFC_ISYM_TAND, GFC_STD_GNU); 3409 3410 /* The following function is internally used for coarray libray functions. 3411 "make_from_module" makes it inaccessible for external users. */ 3412 add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO, 3413 BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL, 3414 x, BT_REAL, dr, REQUIRED); 3415 make_from_module(); 3416 } 3417 3418 3419 /* Add intrinsic subroutines. */ 3420 3421 static void 3422 add_subroutines (void) 3423 { 3424 /* Argument names. These are used as argument keywords and so need to 3425 match the documentation. Please keep this list in sorted order. */ 3426 static const char 3427 *a = "a", *c_ = "c", *c = "count", *cm = "count_max", *com = "command", 3428 *cr = "count_rate", *dt = "date", *errmsg = "errmsg", *f = "from", 3429 *fp = "frompos", *gt = "get", *h = "harvest", *han = "handler", 3430 *length = "length", *ln = "len", *md = "mode", *msk = "mask", 3431 *name = "name", *num = "number", *of = "offset", *old = "old", 3432 *p1 = "path1", *p2 = "path2", *pid = "pid", *pos = "pos", 3433 *pt = "put", *ptr = "ptr", *res = "result", 3434 *result_image = "result_image", *sec = "seconds", *sig = "sig", 3435 *st = "status", *stat = "stat", *sz = "size", *t = "to", 3436 *tm = "time", *tp = "topos", *trim_name = "trim_name", *ut = "unit", 3437 *val = "value", *vl = "values", *whence = "whence", *zn = "zone"; 3438 3439 int di, dr, dc, dl, ii; 3440 3441 di = gfc_default_integer_kind; 3442 dr = gfc_default_real_kind; 3443 dc = gfc_default_character_kind; 3444 dl = gfc_default_logical_kind; 3445 ii = gfc_index_integer_kind; 3446 3447 add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL); 3448 3449 make_noreturn(); 3450 3451 add_sym_3s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC, 3452 BT_UNKNOWN, 0, GFC_STD_F2008, 3453 gfc_check_atomic_def, NULL, gfc_resolve_atomic_def, 3454 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3455 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3456 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3457 3458 add_sym_3s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC, 3459 BT_UNKNOWN, 0, GFC_STD_F2008, 3460 gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref, 3461 "value", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3462 "atom", BT_INTEGER, di, REQUIRED, INTENT_IN, 3463 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3464 3465 add_sym_5s ("atomic_cas", GFC_ISYM_ATOMIC_CAS, CLASS_ATOMIC, 3466 BT_UNKNOWN, 0, GFC_STD_F2018, 3467 gfc_check_atomic_cas, NULL, NULL, 3468 "atom", BT_INTEGER, di, REQUIRED, INTENT_INOUT, 3469 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3470 "compare", BT_INTEGER, di, REQUIRED, INTENT_IN, 3471 "new", BT_INTEGER, di, REQUIRED, INTENT_IN, 3472 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3473 3474 add_sym_3s ("atomic_add", GFC_ISYM_ATOMIC_ADD, CLASS_ATOMIC, 3475 BT_UNKNOWN, 0, GFC_STD_F2018, 3476 gfc_check_atomic_op, NULL, NULL, 3477 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3478 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3479 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3480 3481 add_sym_3s ("atomic_and", GFC_ISYM_ATOMIC_AND, CLASS_ATOMIC, 3482 BT_UNKNOWN, 0, GFC_STD_F2018, 3483 gfc_check_atomic_op, NULL, NULL, 3484 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3485 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3486 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3487 3488 add_sym_3s ("atomic_or", GFC_ISYM_ATOMIC_OR, CLASS_ATOMIC, 3489 BT_UNKNOWN, 0, GFC_STD_F2018, 3490 gfc_check_atomic_op, NULL, NULL, 3491 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3492 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3493 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3494 3495 add_sym_3s ("atomic_xor", GFC_ISYM_ATOMIC_XOR, CLASS_ATOMIC, 3496 BT_UNKNOWN, 0, GFC_STD_F2018, 3497 gfc_check_atomic_op, NULL, NULL, 3498 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3499 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3500 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3501 3502 add_sym_4s ("atomic_fetch_add", GFC_ISYM_ATOMIC_FETCH_ADD, CLASS_ATOMIC, 3503 BT_UNKNOWN, 0, GFC_STD_F2018, 3504 gfc_check_atomic_fetch_op, NULL, NULL, 3505 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3506 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3507 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3508 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3509 3510 add_sym_4s ("atomic_fetch_and", GFC_ISYM_ATOMIC_FETCH_AND, CLASS_ATOMIC, 3511 BT_UNKNOWN, 0, GFC_STD_F2018, 3512 gfc_check_atomic_fetch_op, NULL, NULL, 3513 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3514 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3515 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3516 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3517 3518 add_sym_4s ("atomic_fetch_or", GFC_ISYM_ATOMIC_FETCH_OR, CLASS_ATOMIC, 3519 BT_UNKNOWN, 0, GFC_STD_F2018, 3520 gfc_check_atomic_fetch_op, NULL, NULL, 3521 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3522 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3523 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3524 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3525 3526 add_sym_4s ("atomic_fetch_xor", GFC_ISYM_ATOMIC_FETCH_XOR, CLASS_ATOMIC, 3527 BT_UNKNOWN, 0, GFC_STD_F2018, 3528 gfc_check_atomic_fetch_op, NULL, NULL, 3529 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3530 "value", BT_INTEGER, di, REQUIRED, INTENT_IN, 3531 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT, 3532 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3533 3534 add_sym_0s ("backtrace", GFC_ISYM_BACKTRACE, GFC_STD_GNU, NULL); 3535 3536 add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0, 3537 GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time, 3538 tm, BT_REAL, dr, REQUIRED, INTENT_OUT); 3539 3540 add_sym_3s ("event_query", GFC_ISYM_EVENT_QUERY, CLASS_ATOMIC, 3541 BT_UNKNOWN, 0, GFC_STD_F2018, 3542 gfc_check_event_query, NULL, gfc_resolve_event_query, 3543 "event", BT_INTEGER, di, REQUIRED, INTENT_IN, 3544 c, BT_INTEGER, di, OPTIONAL, INTENT_IN, 3545 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3546 3547 /* More G77 compatibility garbage. */ 3548 add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3549 gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub, 3550 tm, BT_INTEGER, di, REQUIRED, INTENT_IN, 3551 res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 3552 3553 add_sym_1s ("idate", GFC_ISYM_IDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3554 gfc_check_itime_idate, NULL, gfc_resolve_idate, 3555 vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT); 3556 3557 add_sym_1s ("itime", GFC_ISYM_ITIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3558 gfc_check_itime_idate, NULL, gfc_resolve_itime, 3559 vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT); 3560 3561 add_sym_2s ("ltime", GFC_ISYM_LTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3562 gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime, 3563 tm, BT_INTEGER, di, REQUIRED, INTENT_IN, 3564 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); 3565 3566 add_sym_2s ("gmtime", GFC_ISYM_GMTIME, CLASS_IMPURE, BT_UNKNOWN, 0, 3567 GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime, 3568 tm, BT_INTEGER, di, REQUIRED, INTENT_IN, 3569 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT); 3570 3571 add_sym_1s ("second", GFC_ISYM_SECOND, CLASS_IMPURE, BT_UNKNOWN, 0, 3572 GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub, 3573 tm, BT_REAL, dr, REQUIRED, INTENT_OUT); 3574 3575 add_sym_2s ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3576 gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub, 3577 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3578 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3579 3580 add_sym_3s ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3581 gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub, 3582 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3583 md, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3584 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3585 3586 add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, CLASS_IMPURE, BT_UNKNOWN, 3587 0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL, 3588 dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, 3589 tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, 3590 zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, 3591 vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3592 3593 /* More G77 compatibility garbage. */ 3594 add_sym_2s ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3595 gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub, 3596 vl, BT_REAL, 4, REQUIRED, INTENT_OUT, 3597 tm, BT_REAL, 4, REQUIRED, INTENT_OUT); 3598 3599 add_sym_2s ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3600 gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub, 3601 vl, BT_REAL, 4, REQUIRED, INTENT_OUT, 3602 tm, BT_REAL, 4, REQUIRED, INTENT_OUT); 3603 3604 add_sym_5s ("execute_command_line", GFC_ISYM_EXECUTE_COMMAND_LINE, 3605 CLASS_IMPURE , BT_UNKNOWN, 0, GFC_STD_F2008, 3606 NULL, NULL, gfc_resolve_execute_command_line, 3607 "command", BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3608 "wait", BT_LOGICAL, dl, OPTIONAL, INTENT_IN, 3609 "exitstat", BT_INTEGER, di, OPTIONAL, INTENT_INOUT, 3610 "cmdstat", BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3611 "cmdmsg", BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); 3612 3613 add_sym_1s ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3614 gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub, 3615 dt, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 3616 3617 add_sym_1s ("gerror", GFC_ISYM_GERROR, CLASS_IMPURE, BT_UNKNOWN, 3618 0, GFC_STD_GNU, gfc_check_gerror, NULL, gfc_resolve_gerror, 3619 res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 3620 3621 add_sym_2s ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, BT_UNKNOWN, 0, 3622 GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub, 3623 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, 3624 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3625 3626 add_sym_2s ("getenv", GFC_ISYM_GETENV, CLASS_IMPURE, BT_UNKNOWN, 3627 0, GFC_STD_GNU, NULL, NULL, NULL, 3628 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3629 val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 3630 3631 add_sym_2s ("getarg", GFC_ISYM_GETARG, CLASS_IMPURE, BT_UNKNOWN, 3632 0, GFC_STD_GNU, gfc_check_getarg, NULL, gfc_resolve_getarg, 3633 pos, BT_INTEGER, di, REQUIRED, INTENT_IN, 3634 val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 3635 3636 add_sym_1s ("getlog", GFC_ISYM_GETLOG, CLASS_IMPURE, BT_UNKNOWN, 3637 0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog, 3638 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 3639 3640 /* F2003 commandline routines. */ 3641 3642 add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, CLASS_IMPURE, 3643 BT_UNKNOWN, 0, GFC_STD_F2003, 3644 NULL, NULL, gfc_resolve_get_command, 3645 com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, 3646 length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3647 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3648 3649 add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, 3650 CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL, 3651 gfc_resolve_get_command_argument, 3652 num, BT_INTEGER, di, REQUIRED, INTENT_IN, 3653 val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, 3654 length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3655 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3656 3657 /* F2003 subroutine to get environment variables. */ 3658 3659 add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE, 3660 CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, 3661 NULL, NULL, gfc_resolve_get_environment_variable, 3662 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3663 val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT, 3664 length, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3665 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3666 trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN); 3667 3668 add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0, 3669 GFC_STD_F2003, 3670 gfc_check_move_alloc, NULL, NULL, 3671 f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT, 3672 t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); 3673 3674 add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, 3675 GFC_STD_F95, gfc_check_mvbits, NULL, gfc_resolve_mvbits, 3676 f, BT_INTEGER, di, REQUIRED, INTENT_IN, 3677 fp, BT_INTEGER, di, REQUIRED, INTENT_IN, 3678 ln, BT_INTEGER, di, REQUIRED, INTENT_IN, 3679 t, BT_INTEGER, di, REQUIRED, INTENT_INOUT, 3680 tp, BT_INTEGER, di, REQUIRED, INTENT_IN); 3681 3682 if (flag_dec_intrinsic_ints) 3683 { 3684 make_alias ("bmvbits", GFC_STD_GNU); 3685 make_alias ("imvbits", GFC_STD_GNU); 3686 make_alias ("jmvbits", GFC_STD_GNU); 3687 make_alias ("kmvbits", GFC_STD_GNU); 3688 } 3689 3690 add_sym_2s ("random_init", GFC_ISYM_RANDOM_INIT, CLASS_IMPURE, 3691 BT_UNKNOWN, 0, GFC_STD_F2018, 3692 gfc_check_random_init, NULL, gfc_resolve_random_init, 3693 "repeatable", BT_LOGICAL, dl, REQUIRED, INTENT_IN, 3694 "image_distinct", BT_LOGICAL, dl, REQUIRED, INTENT_IN); 3695 3696 add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE, 3697 BT_UNKNOWN, 0, GFC_STD_F95, 3698 gfc_check_random_number, NULL, gfc_resolve_random_number, 3699 h, BT_REAL, dr, REQUIRED, INTENT_OUT); 3700 3701 add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, CLASS_IMPURE, 3702 BT_UNKNOWN, 0, GFC_STD_F95, 3703 gfc_check_random_seed, NULL, gfc_resolve_random_seed, 3704 sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3705 pt, BT_INTEGER, di, OPTIONAL, INTENT_IN, 3706 gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3707 3708 /* The following subroutines are part of ISO_C_BINDING. */ 3709 3710 add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0, 3711 GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL, 3712 "cptr", BT_VOID, 0, REQUIRED, INTENT_IN, 3713 "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT, 3714 "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN); 3715 make_from_module(); 3716 3717 add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE, 3718 BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer, 3719 NULL, NULL, 3720 "cptr", BT_VOID, 0, REQUIRED, INTENT_IN, 3721 "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT); 3722 make_from_module(); 3723 3724 /* Internal subroutine for emitting a runtime error. */ 3725 3726 add_sym_1p ("fe_runtime_error", GFC_ISYM_FE_RUNTIME_ERROR, CLASS_IMPURE, 3727 BT_UNKNOWN, 0, GFC_STD_GNU, 3728 gfc_check_fe_runtime_error, NULL, gfc_resolve_fe_runtime_error, 3729 "msg", BT_CHARACTER, dc, REQUIRED, INTENT_IN); 3730 3731 make_noreturn (); 3732 make_vararg (); 3733 make_from_module (); 3734 3735 /* Coarray collectives. */ 3736 add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE, 3737 BT_UNKNOWN, 0, GFC_STD_F2018, 3738 gfc_check_co_broadcast, NULL, NULL, 3739 a, BT_REAL, dr, REQUIRED, INTENT_INOUT, 3740 "source_image", BT_INTEGER, di, REQUIRED, INTENT_IN, 3741 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3742 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); 3743 3744 add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE, 3745 BT_UNKNOWN, 0, GFC_STD_F2018, 3746 gfc_check_co_minmax, NULL, NULL, 3747 a, BT_REAL, dr, REQUIRED, INTENT_INOUT, 3748 result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, 3749 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3750 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); 3751 3752 add_sym_4s ("co_min", GFC_ISYM_CO_MIN, CLASS_IMPURE, 3753 BT_UNKNOWN, 0, GFC_STD_F2018, 3754 gfc_check_co_minmax, NULL, NULL, 3755 a, BT_REAL, dr, REQUIRED, INTENT_INOUT, 3756 result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, 3757 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3758 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); 3759 3760 add_sym_4s ("co_sum", GFC_ISYM_CO_SUM, CLASS_IMPURE, 3761 BT_UNKNOWN, 0, GFC_STD_F2018, 3762 gfc_check_co_sum, NULL, NULL, 3763 a, BT_REAL, dr, REQUIRED, INTENT_INOUT, 3764 result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, 3765 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3766 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); 3767 3768 add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE, 3769 BT_UNKNOWN, 0, GFC_STD_F2018, 3770 gfc_check_co_reduce, NULL, NULL, 3771 a, BT_REAL, dr, REQUIRED, INTENT_INOUT, 3772 "operator", BT_INTEGER, di, REQUIRED, INTENT_IN, 3773 result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN, 3774 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3775 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT); 3776 3777 3778 /* The following subroutine is internally used for coarray libray functions. 3779 "make_from_module" makes it inaccessible for external users. */ 3780 add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE, 3781 BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL, 3782 "x", BT_REAL, dr, REQUIRED, INTENT_OUT, 3783 "y", BT_REAL, dr, REQUIRED, INTENT_IN); 3784 make_from_module(); 3785 3786 3787 /* More G77 compatibility garbage. */ 3788 add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3789 gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub, 3790 sec, BT_INTEGER, di, REQUIRED, INTENT_IN, 3791 han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN, 3792 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3793 3794 add_sym_1s ("srand", GFC_ISYM_SRAND, CLASS_IMPURE, BT_UNKNOWN, 3795 di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand, 3796 "seed", BT_INTEGER, 4, REQUIRED, INTENT_IN); 3797 3798 add_sym_1s ("exit", GFC_ISYM_EXIT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3799 gfc_check_exit, NULL, gfc_resolve_exit, 3800 st, BT_INTEGER, di, OPTIONAL, INTENT_IN); 3801 3802 make_noreturn(); 3803 3804 add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3805 gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub, 3806 ut, BT_INTEGER, di, REQUIRED, INTENT_IN, 3807 c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, 3808 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3809 3810 add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3811 gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub, 3812 c_, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, 3813 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3814 3815 add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3816 gfc_check_flush, NULL, gfc_resolve_flush, 3817 ut, BT_INTEGER, di, OPTIONAL, INTENT_IN); 3818 3819 add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3820 gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub, 3821 ut, BT_INTEGER, di, REQUIRED, INTENT_IN, 3822 c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3823 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3824 3825 add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3826 gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub, 3827 c_, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3828 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3829 3830 add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3831 gfc_check_free, NULL, NULL, 3832 ptr, BT_INTEGER, ii, REQUIRED, INTENT_INOUT); 3833 3834 add_sym_4s ("fseek", GFC_ISYM_FSEEK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3835 gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub, 3836 ut, BT_INTEGER, di, REQUIRED, INTENT_IN, 3837 of, BT_INTEGER, di, REQUIRED, INTENT_IN, 3838 whence, BT_INTEGER, di, REQUIRED, INTENT_IN, 3839 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3840 3841 add_sym_2s ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3842 gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub, 3843 ut, BT_INTEGER, di, REQUIRED, INTENT_IN, 3844 of, BT_INTEGER, ii, REQUIRED, INTENT_OUT); 3845 3846 add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, BT_UNKNOWN, 0, 3847 GFC_STD_GNU, gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub, 3848 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT, 3849 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3850 3851 add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3852 gfc_check_kill_sub, NULL, NULL, 3853 pid, BT_INTEGER, di, REQUIRED, INTENT_IN, 3854 sig, BT_INTEGER, di, REQUIRED, INTENT_IN, 3855 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3856 3857 add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3858 gfc_check_link_sub, NULL, gfc_resolve_link_sub, 3859 p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3860 p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3861 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3862 3863 add_sym_1s ("perror", GFC_ISYM_PERROR, CLASS_IMPURE, BT_UNKNOWN, 3864 0, GFC_STD_GNU, gfc_check_perror, NULL, gfc_resolve_perror, 3865 "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN); 3866 3867 add_sym_3s ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, BT_UNKNOWN, 0, 3868 GFC_STD_GNU, gfc_check_rename_sub, NULL, gfc_resolve_rename_sub, 3869 p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3870 p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3871 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3872 3873 add_sym_1s ("sleep", GFC_ISYM_SLEEP, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3874 gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub, 3875 sec, BT_INTEGER, di, REQUIRED, INTENT_IN); 3876 3877 add_sym_3s ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3878 gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub, 3879 ut, BT_INTEGER, di, REQUIRED, INTENT_IN, 3880 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, 3881 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3882 3883 add_sym_3s ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3884 gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub, 3885 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3886 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, 3887 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3888 3889 add_sym_3s ("stat", GFC_ISYM_STAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3890 gfc_check_stat_sub, NULL, gfc_resolve_stat_sub, 3891 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3892 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT, 3893 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3894 3895 add_sym_3s ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, BT_UNKNOWN, 0, 3896 GFC_STD_GNU, gfc_check_signal_sub, NULL, gfc_resolve_signal_sub, 3897 num, BT_INTEGER, di, REQUIRED, INTENT_IN, 3898 han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN, 3899 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3900 3901 add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, CLASS_IMPURE, BT_UNKNOWN, 0, 3902 GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub, 3903 p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3904 p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3905 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3906 3907 add_sym_2s ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, BT_UNKNOWN, 3908 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub, 3909 com, BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3910 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3911 3912 add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, CLASS_IMPURE, 3913 BT_UNKNOWN, 0, GFC_STD_F95, 3914 gfc_check_system_clock, NULL, gfc_resolve_system_clock, 3915 c, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3916 cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT, 3917 cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3918 3919 add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, BT_UNKNOWN, 0, 3920 GFC_STD_GNU, gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub, 3921 ut, BT_INTEGER, di, REQUIRED, INTENT_IN, 3922 name, BT_CHARACTER, dc, REQUIRED, INTENT_OUT); 3923 3924 add_sym_2s ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU, 3925 gfc_check_umask_sub, NULL, gfc_resolve_umask_sub, 3926 msk, BT_INTEGER, di, REQUIRED, INTENT_IN, 3927 old, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3928 3929 add_sym_2s ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, BT_UNKNOWN, 0, 3930 GFC_STD_GNU, gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub, 3931 "path", BT_CHARACTER, dc, REQUIRED, INTENT_IN, 3932 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT); 3933 } 3934 3935 3936 /* Add a function to the list of conversion symbols. */ 3937 3938 static void 3939 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard) 3940 { 3941 gfc_typespec from, to; 3942 gfc_intrinsic_sym *sym; 3943 3944 if (sizing == SZ_CONVS) 3945 { 3946 nconv++; 3947 return; 3948 } 3949 3950 gfc_clear_ts (&from); 3951 from.type = from_type; 3952 from.kind = from_kind; 3953 3954 gfc_clear_ts (&to); 3955 to.type = to_type; 3956 to.kind = to_kind; 3957 3958 sym = conversion + nconv; 3959 3960 sym->name = conv_name (&from, &to); 3961 sym->lib_name = sym->name; 3962 sym->simplify.cc = gfc_convert_constant; 3963 sym->standard = standard; 3964 sym->elemental = 1; 3965 sym->pure = 1; 3966 sym->conversion = 1; 3967 sym->ts = to; 3968 sym->id = GFC_ISYM_CONVERSION; 3969 3970 nconv++; 3971 } 3972 3973 3974 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion 3975 functions by looping over the kind tables. */ 3976 3977 static void 3978 add_conversions (void) 3979 { 3980 int i, j; 3981 3982 /* Integer-Integer conversions. */ 3983 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 3984 for (j = 0; gfc_integer_kinds[j].kind != 0; j++) 3985 { 3986 if (i == j) 3987 continue; 3988 3989 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, 3990 BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77); 3991 } 3992 3993 /* Integer-Real/Complex conversions. */ 3994 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 3995 for (j = 0; gfc_real_kinds[j].kind != 0; j++) 3996 { 3997 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, 3998 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); 3999 4000 add_conv (BT_REAL, gfc_real_kinds[j].kind, 4001 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); 4002 4003 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, 4004 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); 4005 4006 add_conv (BT_COMPLEX, gfc_real_kinds[j].kind, 4007 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77); 4008 } 4009 4010 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) 4011 { 4012 /* Hollerith-Integer conversions. */ 4013 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 4014 add_conv (BT_HOLLERITH, gfc_default_character_kind, 4015 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); 4016 /* Hollerith-Real conversions. */ 4017 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 4018 add_conv (BT_HOLLERITH, gfc_default_character_kind, 4019 BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY); 4020 /* Hollerith-Complex conversions. */ 4021 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 4022 add_conv (BT_HOLLERITH, gfc_default_character_kind, 4023 BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY); 4024 4025 /* Hollerith-Character conversions. */ 4026 add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER, 4027 gfc_default_character_kind, GFC_STD_LEGACY); 4028 4029 /* Hollerith-Logical conversions. */ 4030 for (i = 0; gfc_logical_kinds[i].kind != 0; i++) 4031 add_conv (BT_HOLLERITH, gfc_default_character_kind, 4032 BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY); 4033 } 4034 4035 /* Real/Complex - Real/Complex conversions. */ 4036 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 4037 for (j = 0; gfc_real_kinds[j].kind != 0; j++) 4038 { 4039 if (i != j) 4040 { 4041 add_conv (BT_REAL, gfc_real_kinds[i].kind, 4042 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); 4043 4044 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, 4045 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); 4046 } 4047 4048 add_conv (BT_REAL, gfc_real_kinds[i].kind, 4049 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77); 4050 4051 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind, 4052 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77); 4053 } 4054 4055 /* Logical/Logical kind conversion. */ 4056 for (i = 0; gfc_logical_kinds[i].kind; i++) 4057 for (j = 0; gfc_logical_kinds[j].kind; j++) 4058 { 4059 if (i == j) 4060 continue; 4061 4062 add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind, 4063 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77); 4064 } 4065 4066 /* Integer-Logical and Logical-Integer conversions. */ 4067 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0) 4068 for (i=0; gfc_integer_kinds[i].kind; i++) 4069 for (j=0; gfc_logical_kinds[j].kind; j++) 4070 { 4071 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind, 4072 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY); 4073 add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind, 4074 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); 4075 } 4076 4077 /* DEC legacy feature allows character conversions similar to Hollerith 4078 conversions - the character data will transferred on a byte by byte 4079 basis. */ 4080 if (flag_dec_char_conversions) 4081 { 4082 /* Character-Integer conversions. */ 4083 for (i = 0; gfc_integer_kinds[i].kind != 0; i++) 4084 add_conv (BT_CHARACTER, gfc_default_character_kind, 4085 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY); 4086 /* Character-Real conversions. */ 4087 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 4088 add_conv (BT_CHARACTER, gfc_default_character_kind, 4089 BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY); 4090 /* Character-Complex conversions. */ 4091 for (i = 0; gfc_real_kinds[i].kind != 0; i++) 4092 add_conv (BT_CHARACTER, gfc_default_character_kind, 4093 BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY); 4094 /* Character-Logical conversions. */ 4095 for (i = 0; gfc_logical_kinds[i].kind != 0; i++) 4096 add_conv (BT_CHARACTER, gfc_default_character_kind, 4097 BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY); 4098 } 4099 } 4100 4101 4102 static void 4103 add_char_conversions (void) 4104 { 4105 int n, i, j; 4106 4107 /* Count possible conversions. */ 4108 for (i = 0; gfc_character_kinds[i].kind != 0; i++) 4109 for (j = 0; gfc_character_kinds[j].kind != 0; j++) 4110 if (i != j) 4111 ncharconv++; 4112 4113 /* Allocate memory. */ 4114 char_conversions = XCNEWVEC (gfc_intrinsic_sym, ncharconv); 4115 4116 /* Add the conversions themselves. */ 4117 n = 0; 4118 for (i = 0; gfc_character_kinds[i].kind != 0; i++) 4119 for (j = 0; gfc_character_kinds[j].kind != 0; j++) 4120 { 4121 gfc_typespec from, to; 4122 4123 if (i == j) 4124 continue; 4125 4126 gfc_clear_ts (&from); 4127 from.type = BT_CHARACTER; 4128 from.kind = gfc_character_kinds[i].kind; 4129 4130 gfc_clear_ts (&to); 4131 to.type = BT_CHARACTER; 4132 to.kind = gfc_character_kinds[j].kind; 4133 4134 char_conversions[n].name = conv_name (&from, &to); 4135 char_conversions[n].lib_name = char_conversions[n].name; 4136 char_conversions[n].simplify.cc = gfc_convert_char_constant; 4137 char_conversions[n].standard = GFC_STD_F2003; 4138 char_conversions[n].elemental = 1; 4139 char_conversions[n].pure = 1; 4140 char_conversions[n].conversion = 0; 4141 char_conversions[n].ts = to; 4142 char_conversions[n].id = GFC_ISYM_CONVERSION; 4143 4144 n++; 4145 } 4146 } 4147 4148 4149 /* Initialize the table of intrinsics. */ 4150 void 4151 gfc_intrinsic_init_1 (void) 4152 { 4153 nargs = nfunc = nsub = nconv = 0; 4154 4155 /* Create a namespace to hold the resolved intrinsic symbols. */ 4156 gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0); 4157 4158 sizing = SZ_FUNCS; 4159 add_functions (); 4160 sizing = SZ_SUBS; 4161 add_subroutines (); 4162 sizing = SZ_CONVS; 4163 add_conversions (); 4164 4165 functions = XCNEWVAR (struct gfc_intrinsic_sym, 4166 sizeof (gfc_intrinsic_sym) * (nfunc + nsub) 4167 + sizeof (gfc_intrinsic_arg) * nargs); 4168 4169 next_sym = functions; 4170 subroutines = functions + nfunc; 4171 4172 conversion = XCNEWVEC (gfc_intrinsic_sym, nconv); 4173 4174 next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1; 4175 4176 sizing = SZ_NOTHING; 4177 nconv = 0; 4178 4179 add_functions (); 4180 add_subroutines (); 4181 add_conversions (); 4182 4183 /* Character conversion intrinsics need to be treated separately. */ 4184 add_char_conversions (); 4185 } 4186 4187 4188 void 4189 gfc_intrinsic_done_1 (void) 4190 { 4191 free (functions); 4192 free (conversion); 4193 free (char_conversions); 4194 gfc_free_namespace (gfc_intrinsic_namespace); 4195 } 4196 4197 4198 /******** Subroutines to check intrinsic interfaces ***********/ 4199 4200 /* Given a formal argument list, remove any NULL arguments that may 4201 have been left behind by a sort against some formal argument list. */ 4202 4203 static void 4204 remove_nullargs (gfc_actual_arglist **ap) 4205 { 4206 gfc_actual_arglist *head, *tail, *next; 4207 4208 tail = NULL; 4209 4210 for (head = *ap; head; head = next) 4211 { 4212 next = head->next; 4213 4214 if (head->expr == NULL && !head->label) 4215 { 4216 head->next = NULL; 4217 gfc_free_actual_arglist (head); 4218 } 4219 else 4220 { 4221 if (tail == NULL) 4222 *ap = head; 4223 else 4224 tail->next = head; 4225 4226 tail = head; 4227 tail->next = NULL; 4228 } 4229 } 4230 4231 if (tail == NULL) 4232 *ap = NULL; 4233 } 4234 4235 4236 /* Given an actual arglist and a formal arglist, sort the actual 4237 arglist so that its arguments are in a one-to-one correspondence 4238 with the format arglist. Arguments that are not present are given 4239 a blank gfc_actual_arglist structure. If something is obviously 4240 wrong (say, a missing required argument) we abort sorting and 4241 return false. */ 4242 4243 static bool 4244 sort_actual (const char *name, gfc_actual_arglist **ap, 4245 gfc_intrinsic_arg *formal, locus *where) 4246 { 4247 gfc_actual_arglist *actual, *a; 4248 gfc_intrinsic_arg *f; 4249 4250 remove_nullargs (ap); 4251 actual = *ap; 4252 4253 for (f = formal; f; f = f->next) 4254 f->actual = NULL; 4255 4256 f = formal; 4257 a = actual; 4258 4259 if (f == NULL && a == NULL) /* No arguments */ 4260 return true; 4261 4262 /* ALLOCATED has two mutually exclusive keywords, but only one 4263 can be present at time and neither is optional. */ 4264 if (strcmp (name, "allocated") == 0) 4265 { 4266 if (!a) 4267 { 4268 gfc_error ("ALLOCATED intrinsic at %L requires an array or scalar " 4269 "allocatable entity", where); 4270 return false; 4271 } 4272 4273 if (a->name) 4274 { 4275 if (strcmp (a->name, "scalar") == 0) 4276 { 4277 if (a->next) 4278 goto whoops; 4279 if (a->expr->rank != 0) 4280 { 4281 gfc_error ("Scalar entity required at %L", &a->expr->where); 4282 return false; 4283 } 4284 return true; 4285 } 4286 else if (strcmp (a->name, "array") == 0) 4287 { 4288 if (a->next) 4289 goto whoops; 4290 if (a->expr->rank == 0) 4291 { 4292 gfc_error ("Array entity required at %L", &a->expr->where); 4293 return false; 4294 } 4295 return true; 4296 } 4297 else 4298 { 4299 gfc_error ("Invalid keyword %qs in %qs intrinsic function at %L", 4300 a->name, name, &a->expr->where); 4301 return false; 4302 } 4303 } 4304 } 4305 4306 for (;;) 4307 { /* Put the nonkeyword arguments in a 1:1 correspondence */ 4308 if (f == NULL) 4309 break; 4310 if (a == NULL) 4311 goto optional; 4312 4313 if (a->name != NULL) 4314 goto keywords; 4315 4316 f->actual = a; 4317 4318 f = f->next; 4319 a = a->next; 4320 } 4321 4322 if (a == NULL) 4323 goto do_sort; 4324 4325 whoops: 4326 gfc_error ("Too many arguments in call to %qs at %L", name, where); 4327 return false; 4328 4329 keywords: 4330 /* Associate the remaining actual arguments, all of which have 4331 to be keyword arguments. */ 4332 for (; a; a = a->next) 4333 { 4334 for (f = formal; f; f = f->next) 4335 if (strcmp (a->name, f->name) == 0) 4336 break; 4337 4338 if (f == NULL) 4339 { 4340 if (a->name[0] == '%') 4341 gfc_error ("The argument list functions %%VAL, %%LOC or %%REF " 4342 "are not allowed in this context at %L", where); 4343 else 4344 gfc_error ("Cannot find keyword named %qs in call to %qs at %L", 4345 a->name, name, where); 4346 return false; 4347 } 4348 4349 if (f->actual != NULL) 4350 { 4351 gfc_error ("Argument %qs appears twice in call to %qs at %L", 4352 f->name, name, where); 4353 return false; 4354 } 4355 4356 f->actual = a; 4357 } 4358 4359 optional: 4360 /* At this point, all unmatched formal args must be optional. */ 4361 for (f = formal; f; f = f->next) 4362 { 4363 if (f->actual == NULL && f->optional == 0) 4364 { 4365 gfc_error ("Missing actual argument %qs in call to %qs at %L", 4366 f->name, name, where); 4367 return false; 4368 } 4369 } 4370 4371 do_sort: 4372 /* Using the formal argument list, string the actual argument list 4373 together in a way that corresponds with the formal list. */ 4374 actual = NULL; 4375 4376 for (f = formal; f; f = f->next) 4377 { 4378 if (f->actual && f->actual->label != NULL && f->ts.type) 4379 { 4380 gfc_error ("ALTERNATE RETURN not permitted at %L", where); 4381 return false; 4382 } 4383 4384 if (f->actual == NULL) 4385 { 4386 a = gfc_get_actual_arglist (); 4387 a->missing_arg_type = f->ts.type; 4388 } 4389 else 4390 a = f->actual; 4391 4392 if (actual == NULL) 4393 *ap = a; 4394 else 4395 actual->next = a; 4396 4397 actual = a; 4398 } 4399 actual->next = NULL; /* End the sorted argument list. */ 4400 4401 return true; 4402 } 4403 4404 4405 /* Compare an actual argument list with an intrinsic's formal argument 4406 list. The lists are checked for agreement of type. We don't check 4407 for arrayness here. */ 4408 4409 static bool 4410 check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym, 4411 int error_flag) 4412 { 4413 gfc_actual_arglist *actual; 4414 gfc_intrinsic_arg *formal; 4415 int i; 4416 4417 formal = sym->formal; 4418 actual = *ap; 4419 4420 i = 0; 4421 for (; formal; formal = formal->next, actual = actual->next, i++) 4422 { 4423 gfc_typespec ts; 4424 4425 if (actual->expr == NULL) 4426 continue; 4427 4428 ts = formal->ts; 4429 4430 /* A kind of 0 means we don't check for kind. */ 4431 if (ts.kind == 0) 4432 ts.kind = actual->expr->ts.kind; 4433 4434 if (!gfc_compare_types (&ts, &actual->expr->ts)) 4435 { 4436 if (error_flag) 4437 gfc_error ("In call to %qs at %L, type mismatch in argument " 4438 "%qs; pass %qs to %qs", gfc_current_intrinsic, 4439 &actual->expr->where, 4440 gfc_current_intrinsic_arg[i]->name, 4441 gfc_typename (actual->expr), 4442 gfc_dummy_typename (&formal->ts)); 4443 return false; 4444 } 4445 4446 /* F2018, p. 328: An argument to an intrinsic procedure other than 4447 ASSOCIATED, NULL, or PRESENT shall be a data object. An EXPR_NULL 4448 is not a data object. */ 4449 if (actual->expr->expr_type == EXPR_NULL 4450 && (!(sym->id == GFC_ISYM_ASSOCIATED 4451 || sym->id == GFC_ISYM_NULL 4452 || sym->id == GFC_ISYM_PRESENT))) 4453 { 4454 gfc_invalid_null_arg (actual->expr); 4455 return false; 4456 } 4457 4458 /* If the formal argument is INTENT([IN]OUT), check for definability. */ 4459 if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT) 4460 { 4461 const char* context = (error_flag 4462 ? _("actual argument to INTENT = OUT/INOUT") 4463 : NULL); 4464 4465 /* No pointer arguments for intrinsics. */ 4466 if (!gfc_check_vardef_context (actual->expr, false, false, false, context)) 4467 return false; 4468 } 4469 } 4470 4471 return true; 4472 } 4473 4474 4475 /* Given a pointer to an intrinsic symbol and an expression node that 4476 represent the function call to that subroutine, figure out the type 4477 of the result. This may involve calling a resolution subroutine. */ 4478 4479 static void 4480 resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e) 4481 { 4482 gfc_expr *a1, *a2, *a3, *a4, *a5, *a6; 4483 gfc_actual_arglist *arg; 4484 4485 if (specific->resolve.f1 == NULL) 4486 { 4487 if (e->value.function.name == NULL) 4488 e->value.function.name = specific->lib_name; 4489 4490 if (e->ts.type == BT_UNKNOWN) 4491 e->ts = specific->ts; 4492 return; 4493 } 4494 4495 arg = e->value.function.actual; 4496 4497 /* Special case hacks for MIN, MAX and INDEX. */ 4498 if (specific->resolve.f1m == gfc_resolve_max 4499 || specific->resolve.f1m == gfc_resolve_min 4500 || specific->resolve.f1m == gfc_resolve_index_func) 4501 { 4502 (*specific->resolve.f1m) (e, arg); 4503 return; 4504 } 4505 4506 if (arg == NULL) 4507 { 4508 (*specific->resolve.f0) (e); 4509 return; 4510 } 4511 4512 a1 = arg->expr; 4513 arg = arg->next; 4514 4515 if (arg == NULL) 4516 { 4517 (*specific->resolve.f1) (e, a1); 4518 return; 4519 } 4520 4521 a2 = arg->expr; 4522 arg = arg->next; 4523 4524 if (arg == NULL) 4525 { 4526 (*specific->resolve.f2) (e, a1, a2); 4527 return; 4528 } 4529 4530 a3 = arg->expr; 4531 arg = arg->next; 4532 4533 if (arg == NULL) 4534 { 4535 (*specific->resolve.f3) (e, a1, a2, a3); 4536 return; 4537 } 4538 4539 a4 = arg->expr; 4540 arg = arg->next; 4541 4542 if (arg == NULL) 4543 { 4544 (*specific->resolve.f4) (e, a1, a2, a3, a4); 4545 return; 4546 } 4547 4548 a5 = arg->expr; 4549 arg = arg->next; 4550 4551 if (arg == NULL) 4552 { 4553 (*specific->resolve.f5) (e, a1, a2, a3, a4, a5); 4554 return; 4555 } 4556 4557 a6 = arg->expr; 4558 arg = arg->next; 4559 4560 if (arg == NULL) 4561 { 4562 (*specific->resolve.f6) (e, a1, a2, a3, a4, a5, a6); 4563 return; 4564 } 4565 4566 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic"); 4567 } 4568 4569 4570 /* Given an intrinsic symbol node and an expression node, call the 4571 simplification function (if there is one), perhaps replacing the 4572 expression with something simpler. We return false on an error 4573 of the simplification, true if the simplification worked, even 4574 if nothing has changed in the expression itself. */ 4575 4576 static bool 4577 do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e) 4578 { 4579 gfc_expr *result, *a1, *a2, *a3, *a4, *a5, *a6; 4580 gfc_actual_arglist *arg; 4581 4582 /* Max and min require special handling due to the variable number 4583 of args. */ 4584 if (specific->simplify.f1 == gfc_simplify_min) 4585 { 4586 result = gfc_simplify_min (e); 4587 goto finish; 4588 } 4589 4590 if (specific->simplify.f1 == gfc_simplify_max) 4591 { 4592 result = gfc_simplify_max (e); 4593 goto finish; 4594 } 4595 4596 if (specific->simplify.f1 == NULL) 4597 { 4598 result = NULL; 4599 goto finish; 4600 } 4601 4602 arg = e->value.function.actual; 4603 4604 if (arg == NULL) 4605 { 4606 result = (*specific->simplify.f0) (); 4607 goto finish; 4608 } 4609 4610 a1 = arg->expr; 4611 arg = arg->next; 4612 4613 if (specific->simplify.cc == gfc_convert_constant 4614 || specific->simplify.cc == gfc_convert_char_constant) 4615 { 4616 result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind); 4617 goto finish; 4618 } 4619 4620 if (arg == NULL) 4621 result = (*specific->simplify.f1) (a1); 4622 else 4623 { 4624 a2 = arg->expr; 4625 arg = arg->next; 4626 4627 if (arg == NULL) 4628 result = (*specific->simplify.f2) (a1, a2); 4629 else 4630 { 4631 a3 = arg->expr; 4632 arg = arg->next; 4633 4634 if (arg == NULL) 4635 result = (*specific->simplify.f3) (a1, a2, a3); 4636 else 4637 { 4638 a4 = arg->expr; 4639 arg = arg->next; 4640 4641 if (arg == NULL) 4642 result = (*specific->simplify.f4) (a1, a2, a3, a4); 4643 else 4644 { 4645 a5 = arg->expr; 4646 arg = arg->next; 4647 4648 if (arg == NULL) 4649 result = (*specific->simplify.f5) (a1, a2, a3, a4, a5); 4650 else 4651 { 4652 a6 = arg->expr; 4653 arg = arg->next; 4654 4655 if (arg == NULL) 4656 result = (*specific->simplify.f6) 4657 (a1, a2, a3, a4, a5, a6); 4658 else 4659 gfc_internal_error 4660 ("do_simplify(): Too many args for intrinsic"); 4661 } 4662 } 4663 } 4664 } 4665 } 4666 4667 finish: 4668 if (result == &gfc_bad_expr) 4669 return false; 4670 4671 if (result == NULL) 4672 resolve_intrinsic (specific, e); /* Must call at run-time */ 4673 else 4674 { 4675 result->where = e->where; 4676 gfc_replace_expr (e, result); 4677 } 4678 4679 return true; 4680 } 4681 4682 4683 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of 4684 error messages. This subroutine returns false if a subroutine 4685 has more than MAX_INTRINSIC_ARGS, in which case the actual argument 4686 list cannot match any intrinsic. */ 4687 4688 static void 4689 init_arglist (gfc_intrinsic_sym *isym) 4690 { 4691 gfc_intrinsic_arg *formal; 4692 int i; 4693 4694 gfc_current_intrinsic = isym->name; 4695 4696 i = 0; 4697 for (formal = isym->formal; formal; formal = formal->next) 4698 { 4699 if (i >= MAX_INTRINSIC_ARGS) 4700 gfc_internal_error ("init_arglist(): too many arguments"); 4701 gfc_current_intrinsic_arg[i++] = formal; 4702 } 4703 } 4704 4705 4706 /* Given a pointer to an intrinsic symbol and an expression consisting 4707 of a function call, see if the function call is consistent with the 4708 intrinsic's formal argument list. Return true if the expression 4709 and intrinsic match, false otherwise. */ 4710 4711 static bool 4712 check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag) 4713 { 4714 gfc_actual_arglist *arg, **ap; 4715 bool t; 4716 4717 ap = &expr->value.function.actual; 4718 4719 init_arglist (specific); 4720 4721 /* Don't attempt to sort the argument list for min or max. */ 4722 if (specific->check.f1m == gfc_check_min_max 4723 || specific->check.f1m == gfc_check_min_max_integer 4724 || specific->check.f1m == gfc_check_min_max_real 4725 || specific->check.f1m == gfc_check_min_max_double) 4726 { 4727 if (!do_ts29113_check (specific, *ap)) 4728 return false; 4729 return (*specific->check.f1m) (*ap); 4730 } 4731 4732 if (!sort_actual (specific->name, ap, specific->formal, &expr->where)) 4733 return false; 4734 4735 if (!do_ts29113_check (specific, *ap)) 4736 return false; 4737 4738 if (specific->check.f5ml == gfc_check_minloc_maxloc) 4739 /* This is special because we might have to reorder the argument list. */ 4740 t = gfc_check_minloc_maxloc (*ap); 4741 else if (specific->check.f6fl == gfc_check_findloc) 4742 t = gfc_check_findloc (*ap); 4743 else if (specific->check.f3red == gfc_check_minval_maxval) 4744 /* This is also special because we also might have to reorder the 4745 argument list. */ 4746 t = gfc_check_minval_maxval (*ap); 4747 else if (specific->check.f3red == gfc_check_product_sum) 4748 /* Same here. The difference to the previous case is that we allow a 4749 general numeric type. */ 4750 t = gfc_check_product_sum (*ap); 4751 else if (specific->check.f3red == gfc_check_transf_bit_intrins) 4752 /* Same as for PRODUCT and SUM, but different checks. */ 4753 t = gfc_check_transf_bit_intrins (*ap); 4754 else 4755 { 4756 if (specific->check.f1 == NULL) 4757 { 4758 t = check_arglist (ap, specific, error_flag); 4759 if (t) 4760 expr->ts = specific->ts; 4761 } 4762 else 4763 t = do_check (specific, *ap); 4764 } 4765 4766 /* Check conformance of elemental intrinsics. */ 4767 if (t && specific->elemental) 4768 { 4769 int n = 0; 4770 gfc_expr *first_expr; 4771 arg = expr->value.function.actual; 4772 4773 /* There is no elemental intrinsic without arguments. */ 4774 gcc_assert(arg != NULL); 4775 first_expr = arg->expr; 4776 4777 for ( ; arg && arg->expr; arg = arg->next, n++) 4778 if (!gfc_check_conformance (first_expr, arg->expr, 4779 "arguments '%s' and '%s' for " 4780 "intrinsic '%s'", 4781 gfc_current_intrinsic_arg[0]->name, 4782 gfc_current_intrinsic_arg[n]->name, 4783 gfc_current_intrinsic)) 4784 return false; 4785 } 4786 4787 if (!t) 4788 remove_nullargs (ap); 4789 4790 return t; 4791 } 4792 4793 4794 /* Check whether an intrinsic belongs to whatever standard the user 4795 has chosen, taking also into account -fall-intrinsics. Here, no 4796 warning/error is emitted; but if symstd is not NULL, it is pointed to a 4797 textual representation of the symbols standard status (like 4798 "new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that 4799 can be used to construct a detailed warning/error message in case of 4800 a false. */ 4801 4802 bool 4803 gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym, 4804 const char** symstd, bool silent, locus where) 4805 { 4806 const char* symstd_msg; 4807 4808 /* For -fall-intrinsics, just succeed. */ 4809 if (flag_all_intrinsics) 4810 return true; 4811 4812 /* Find the symbol's standard message for later usage. */ 4813 switch (isym->standard) 4814 { 4815 case GFC_STD_F77: 4816 symstd_msg = "available since Fortran 77"; 4817 break; 4818 4819 case GFC_STD_F95_OBS: 4820 symstd_msg = "obsolescent in Fortran 95"; 4821 break; 4822 4823 case GFC_STD_F95_DEL: 4824 symstd_msg = "deleted in Fortran 95"; 4825 break; 4826 4827 case GFC_STD_F95: 4828 symstd_msg = "new in Fortran 95"; 4829 break; 4830 4831 case GFC_STD_F2003: 4832 symstd_msg = "new in Fortran 2003"; 4833 break; 4834 4835 case GFC_STD_F2008: 4836 symstd_msg = "new in Fortran 2008"; 4837 break; 4838 4839 case GFC_STD_F2018: 4840 symstd_msg = "new in Fortran 2018"; 4841 break; 4842 4843 case GFC_STD_GNU: 4844 symstd_msg = "a GNU Fortran extension"; 4845 break; 4846 4847 case GFC_STD_LEGACY: 4848 symstd_msg = "for backward compatibility"; 4849 break; 4850 4851 default: 4852 gfc_internal_error ("Invalid standard code on intrinsic %qs (%d)", 4853 isym->name, isym->standard); 4854 } 4855 4856 /* If warning about the standard, warn and succeed. */ 4857 if (gfc_option.warn_std & isym->standard) 4858 { 4859 /* Do only print a warning if not a GNU extension. */ 4860 if (!silent && isym->standard != GFC_STD_GNU) 4861 gfc_warning (0, "Intrinsic %qs (is %s) is used at %L", 4862 isym->name, _(symstd_msg), &where); 4863 4864 return true; 4865 } 4866 4867 /* If allowing the symbol's standard, succeed, too. */ 4868 if (gfc_option.allow_std & isym->standard) 4869 return true; 4870 4871 /* Otherwise, fail. */ 4872 if (symstd) 4873 *symstd = _(symstd_msg); 4874 return false; 4875 } 4876 4877 4878 /* See if a function call corresponds to an intrinsic function call. 4879 We return: 4880 4881 MATCH_YES if the call corresponds to an intrinsic, simplification 4882 is done if possible. 4883 4884 MATCH_NO if the call does not correspond to an intrinsic 4885 4886 MATCH_ERROR if the call corresponds to an intrinsic but there was an 4887 error during the simplification process. 4888 4889 The error_flag parameter enables an error reporting. */ 4890 4891 match 4892 gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag) 4893 { 4894 gfc_symbol *sym; 4895 gfc_intrinsic_sym *isym, *specific; 4896 gfc_actual_arglist *actual; 4897 int flag; 4898 4899 if (expr->value.function.isym != NULL) 4900 return (!do_simplify(expr->value.function.isym, expr)) 4901 ? MATCH_ERROR : MATCH_YES; 4902 4903 if (!error_flag) 4904 gfc_push_suppress_errors (); 4905 flag = 0; 4906 4907 for (actual = expr->value.function.actual; actual; actual = actual->next) 4908 if (actual->expr != NULL) 4909 flag |= (actual->expr->ts.type != BT_INTEGER 4910 && actual->expr->ts.type != BT_CHARACTER); 4911 4912 sym = expr->symtree->n.sym; 4913 4914 if (sym->intmod_sym_id) 4915 { 4916 gfc_isym_id id = gfc_isym_id_by_intmod_sym (sym); 4917 isym = specific = gfc_intrinsic_function_by_id (id); 4918 } 4919 else 4920 isym = specific = gfc_find_function (sym->name); 4921 4922 if (isym == NULL) 4923 { 4924 if (!error_flag) 4925 gfc_pop_suppress_errors (); 4926 return MATCH_NO; 4927 } 4928 4929 if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE 4930 || isym->id == GFC_ISYM_CMPLX || isym->id == GFC_ISYM_FLOAT 4931 || isym->id == GFC_ISYM_SNGL || isym->id == GFC_ISYM_DFLOAT) 4932 && gfc_init_expr_flag 4933 && !gfc_notify_std (GFC_STD_F2003, "Function %qs as initialization " 4934 "expression at %L", sym->name, &expr->where)) 4935 { 4936 if (!error_flag) 4937 gfc_pop_suppress_errors (); 4938 return MATCH_ERROR; 4939 } 4940 4941 /* F95, 7.1.6.1: Only transformational functions REPEAT, RESHAPE, 4942 SELECTED_INT_KIND, SELECTED_REAL_KIND, TRANSFER, and TRIM are allowed in 4943 initialization expressions. */ 4944 4945 if (gfc_init_expr_flag && isym->transformational) 4946 { 4947 gfc_isym_id id = isym->id; 4948 if (id != GFC_ISYM_REPEAT && id != GFC_ISYM_RESHAPE 4949 && id != GFC_ISYM_SI_KIND && id != GFC_ISYM_SR_KIND 4950 && id != GFC_ISYM_TRANSFER && id != GFC_ISYM_TRIM 4951 && !gfc_notify_std (GFC_STD_F2003, "Transformational function %qs " 4952 "at %L is invalid in an initialization " 4953 "expression", sym->name, &expr->where)) 4954 { 4955 if (!error_flag) 4956 gfc_pop_suppress_errors (); 4957 4958 return MATCH_ERROR; 4959 } 4960 } 4961 4962 gfc_current_intrinsic_where = &expr->where; 4963 4964 /* Bypass the generic list for min, max and ISO_C_Binding's c_loc. */ 4965 if (isym->check.f1m == gfc_check_min_max) 4966 { 4967 init_arglist (isym); 4968 4969 if (isym->check.f1m(expr->value.function.actual)) 4970 goto got_specific; 4971 4972 if (!error_flag) 4973 gfc_pop_suppress_errors (); 4974 return MATCH_NO; 4975 } 4976 4977 /* If the function is generic, check all of its specific 4978 incarnations. If the generic name is also a specific, we check 4979 that name last, so that any error message will correspond to the 4980 specific. */ 4981 gfc_push_suppress_errors (); 4982 4983 if (isym->generic) 4984 { 4985 for (specific = isym->specific_head; specific; 4986 specific = specific->next) 4987 { 4988 if (specific == isym) 4989 continue; 4990 if (check_specific (specific, expr, 0)) 4991 { 4992 gfc_pop_suppress_errors (); 4993 goto got_specific; 4994 } 4995 } 4996 } 4997 4998 gfc_pop_suppress_errors (); 4999 5000 if (!check_specific (isym, expr, error_flag)) 5001 { 5002 if (!error_flag) 5003 gfc_pop_suppress_errors (); 5004 return MATCH_NO; 5005 } 5006 5007 specific = isym; 5008 5009 got_specific: 5010 expr->value.function.isym = specific; 5011 if (!error_flag) 5012 gfc_pop_suppress_errors (); 5013 5014 if (!do_simplify (specific, expr)) 5015 return MATCH_ERROR; 5016 5017 /* F95, 7.1.6.1, Initialization expressions 5018 (4) An elemental intrinsic function reference of type integer or 5019 character where each argument is an initialization expression 5020 of type integer or character 5021 5022 F2003, 7.1.7 Initialization expression 5023 (4) A reference to an elemental standard intrinsic function, 5024 where each argument is an initialization expression */ 5025 5026 if (gfc_init_expr_flag && isym->elemental && flag 5027 && !gfc_notify_std (GFC_STD_F2003, "Elemental function as " 5028 "initialization expression with non-integer/non-" 5029 "character arguments at %L", &expr->where)) 5030 return MATCH_ERROR; 5031 5032 if (sym->attr.flavor == FL_UNKNOWN) 5033 { 5034 sym->attr.function = 1; 5035 sym->attr.intrinsic = 1; 5036 sym->attr.flavor = FL_PROCEDURE; 5037 } 5038 if (sym->attr.flavor == FL_PROCEDURE) 5039 { 5040 sym->attr.function = 1; 5041 sym->attr.proc = PROC_INTRINSIC; 5042 } 5043 5044 if (!sym->module) 5045 gfc_intrinsic_symbol (sym); 5046 5047 /* Have another stab at simplification since elemental intrinsics with array 5048 actual arguments would be missed by the calls above to do_simplify. */ 5049 if (isym->elemental) 5050 gfc_simplify_expr (expr, 1); 5051 5052 return MATCH_YES; 5053 } 5054 5055 5056 /* See if a CALL statement corresponds to an intrinsic subroutine. 5057 Returns MATCH_YES if the subroutine corresponds to an intrinsic, 5058 MATCH_NO if not, and MATCH_ERROR if there was an error (but did 5059 correspond). */ 5060 5061 match 5062 gfc_intrinsic_sub_interface (gfc_code *c, int error_flag) 5063 { 5064 gfc_intrinsic_sym *isym; 5065 const char *name; 5066 5067 name = c->symtree->n.sym->name; 5068 5069 if (c->symtree->n.sym->intmod_sym_id) 5070 { 5071 gfc_isym_id id; 5072 id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym); 5073 isym = gfc_intrinsic_subroutine_by_id (id); 5074 } 5075 else 5076 isym = gfc_find_subroutine (name); 5077 if (isym == NULL) 5078 return MATCH_NO; 5079 5080 if (!error_flag) 5081 gfc_push_suppress_errors (); 5082 5083 init_arglist (isym); 5084 5085 if (!isym->vararg && !sort_actual (name, &c->ext.actual, isym->formal, &c->loc)) 5086 goto fail; 5087 5088 if (!do_ts29113_check (isym, c->ext.actual)) 5089 goto fail; 5090 5091 if (isym->check.f1 != NULL) 5092 { 5093 if (!do_check (isym, c->ext.actual)) 5094 goto fail; 5095 } 5096 else 5097 { 5098 if (!check_arglist (&c->ext.actual, isym, 1)) 5099 goto fail; 5100 } 5101 5102 /* The subroutine corresponds to an intrinsic. Allow errors to be 5103 seen at this point. */ 5104 if (!error_flag) 5105 gfc_pop_suppress_errors (); 5106 5107 c->resolved_isym = isym; 5108 if (isym->resolve.s1 != NULL) 5109 isym->resolve.s1 (c); 5110 else 5111 { 5112 c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name); 5113 c->resolved_sym->attr.elemental = isym->elemental; 5114 } 5115 5116 if (gfc_do_concurrent_flag && !isym->pure) 5117 { 5118 gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT " 5119 "block at %L is not PURE", name, &c->loc); 5120 return MATCH_ERROR; 5121 } 5122 5123 if (!isym->pure && gfc_pure (NULL)) 5124 { 5125 gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name, 5126 &c->loc); 5127 return MATCH_ERROR; 5128 } 5129 5130 if (!isym->pure) 5131 gfc_unset_implicit_pure (NULL); 5132 5133 c->resolved_sym->attr.noreturn = isym->noreturn; 5134 5135 return MATCH_YES; 5136 5137 fail: 5138 if (!error_flag) 5139 gfc_pop_suppress_errors (); 5140 return MATCH_NO; 5141 } 5142 5143 5144 /* Call gfc_convert_type() with warning enabled. */ 5145 5146 bool 5147 gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag) 5148 { 5149 return gfc_convert_type_warn (expr, ts, eflag, 1); 5150 } 5151 5152 5153 /* Try to convert an expression (in place) from one type to another. 5154 'eflag' controls the behavior on error. 5155 5156 The possible values are: 5157 5158 1 Generate a gfc_error() 5159 2 Generate a gfc_internal_error(). 5160 5161 'wflag' controls the warning related to conversion. 5162 5163 'array' indicates whether the conversion is in an array constructor. 5164 Non-standard conversion from character to numeric not allowed if true. 5165 */ 5166 5167 bool 5168 gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag, 5169 bool array) 5170 { 5171 gfc_intrinsic_sym *sym; 5172 gfc_typespec from_ts; 5173 locus old_where; 5174 gfc_expr *new_expr; 5175 int rank; 5176 mpz_t *shape; 5177 bool is_char_constant = (expr->expr_type == EXPR_CONSTANT) 5178 && (expr->ts.type == BT_CHARACTER); 5179 5180 from_ts = expr->ts; /* expr->ts gets clobbered */ 5181 5182 if (ts->type == BT_UNKNOWN) 5183 goto bad; 5184 5185 expr->do_not_warn = ! wflag; 5186 5187 /* NULL and zero size arrays get their type here, unless they already have a 5188 typespec. */ 5189 if ((expr->expr_type == EXPR_NULL 5190 || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL)) 5191 && expr->ts.type == BT_UNKNOWN) 5192 { 5193 /* Sometimes the RHS acquire the type. */ 5194 expr->ts = *ts; 5195 return true; 5196 } 5197 5198 if (expr->ts.type == BT_UNKNOWN) 5199 goto bad; 5200 5201 /* In building an array constructor, gfortran can end up here when no 5202 conversion is required for an intrinsic type. We need to let derived 5203 types drop through. */ 5204 if (from_ts.type != BT_DERIVED 5205 && (from_ts.type == ts->type && from_ts.kind == ts->kind)) 5206 return true; 5207 5208 if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED 5209 && gfc_compare_types (&expr->ts, ts)) 5210 return true; 5211 5212 /* If array is true then conversion is in an array constructor where 5213 non-standard conversion is not allowed. */ 5214 if (array && from_ts.type == BT_CHARACTER 5215 && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL)) 5216 goto bad; 5217 5218 sym = find_conv (&expr->ts, ts); 5219 if (sym == NULL) 5220 goto bad; 5221 5222 /* At this point, a conversion is necessary. A warning may be needed. */ 5223 if ((gfc_option.warn_std & sym->standard) != 0) 5224 { 5225 const char *type_name = is_char_constant ? gfc_typename (expr) 5226 : gfc_typename (&from_ts); 5227 gfc_warning_now (0, "Extension: Conversion from %s to %s at %L", 5228 type_name, gfc_dummy_typename (ts), 5229 &expr->where); 5230 } 5231 else if (wflag) 5232 { 5233 if (flag_range_check && expr->expr_type == EXPR_CONSTANT 5234 && from_ts.type == ts->type) 5235 { 5236 /* Do nothing. Constants of the same type are range-checked 5237 elsewhere. If a value too large for the target type is 5238 assigned, an error is generated. Not checking here avoids 5239 duplications of warnings/errors. 5240 If range checking was disabled, but -Wconversion enabled, 5241 a non range checked warning is generated below. */ 5242 } 5243 else if (flag_dec_char_conversions && from_ts.type == BT_CHARACTER 5244 && (gfc_numeric_ts (ts) || ts->type == BT_LOGICAL)) 5245 { 5246 const char *type_name = is_char_constant ? gfc_typename (expr) 5247 : gfc_typename (&from_ts); 5248 gfc_warning_now (OPT_Wconversion, "Nonstandard conversion from %s " 5249 "to %s at %L", type_name, gfc_typename (ts), 5250 &expr->where); 5251 } 5252 else if (from_ts.type == ts->type 5253 || (from_ts.type == BT_INTEGER && ts->type == BT_REAL) 5254 || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX) 5255 || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX)) 5256 { 5257 /* Larger kinds can hold values of smaller kinds without problems. 5258 Hence, only warn if target kind is smaller than the source 5259 kind - or if -Wconversion-extra is specified. LOGICAL values 5260 will always fit regardless of kind so ignore conversion. */ 5261 if (expr->expr_type != EXPR_CONSTANT 5262 && ts->type != BT_LOGICAL) 5263 { 5264 if (warn_conversion && from_ts.kind > ts->kind) 5265 gfc_warning_now (OPT_Wconversion, "Possible change of value in " 5266 "conversion from %s to %s at %L", 5267 gfc_typename (&from_ts), gfc_typename (ts), 5268 &expr->where); 5269 else 5270 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %s to %s " 5271 "at %L", gfc_typename (&from_ts), 5272 gfc_typename (ts), &expr->where); 5273 } 5274 } 5275 else if ((from_ts.type == BT_REAL && ts->type == BT_INTEGER) 5276 || (from_ts.type == BT_COMPLEX && ts->type == BT_INTEGER) 5277 || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL)) 5278 { 5279 /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL 5280 usually comes with a loss of information, regardless of kinds. */ 5281 if (expr->expr_type != EXPR_CONSTANT) 5282 gfc_warning_now (OPT_Wconversion, "Possible change of value in " 5283 "conversion from %s to %s at %L", 5284 gfc_typename (&from_ts), gfc_typename (ts), 5285 &expr->where); 5286 } 5287 else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH) 5288 { 5289 /* If HOLLERITH is involved, all bets are off. */ 5290 gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L", 5291 gfc_typename (&from_ts), gfc_dummy_typename (ts), 5292 &expr->where); 5293 } 5294 else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL) 5295 { 5296 /* Do nothing. This block exists only to simplify the other 5297 else-if expressions. 5298 LOGICAL <> LOGICAL no warning, independent of kind values 5299 LOGICAL <> INTEGER extension, warned elsewhere 5300 LOGICAL <> REAL invalid, error generated elsewhere 5301 LOGICAL <> COMPLEX invalid, error generated elsewhere */ 5302 } 5303 else 5304 gcc_unreachable (); 5305 } 5306 5307 /* Insert a pre-resolved function call to the right function. */ 5308 old_where = expr->where; 5309 rank = expr->rank; 5310 shape = expr->shape; 5311 5312 new_expr = gfc_get_expr (); 5313 *new_expr = *expr; 5314 5315 new_expr = gfc_build_conversion (new_expr); 5316 new_expr->value.function.name = sym->lib_name; 5317 new_expr->value.function.isym = sym; 5318 new_expr->where = old_where; 5319 new_expr->ts = *ts; 5320 new_expr->rank = rank; 5321 new_expr->shape = gfc_copy_shape (shape, rank); 5322 5323 gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); 5324 new_expr->symtree->n.sym->result = new_expr->symtree->n.sym; 5325 new_expr->symtree->n.sym->ts.type = ts->type; 5326 new_expr->symtree->n.sym->ts.kind = ts->kind; 5327 new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; 5328 new_expr->symtree->n.sym->attr.function = 1; 5329 new_expr->symtree->n.sym->attr.elemental = 1; 5330 new_expr->symtree->n.sym->attr.pure = 1; 5331 new_expr->symtree->n.sym->attr.referenced = 1; 5332 gfc_intrinsic_symbol(new_expr->symtree->n.sym); 5333 gfc_commit_symbol (new_expr->symtree->n.sym); 5334 5335 *expr = *new_expr; 5336 5337 free (new_expr); 5338 expr->ts = *ts; 5339 5340 if (gfc_is_constant_expr (expr->value.function.actual->expr) 5341 && !do_simplify (sym, expr)) 5342 { 5343 5344 if (eflag == 2) 5345 goto bad; 5346 return false; /* Error already generated in do_simplify() */ 5347 } 5348 5349 return true; 5350 5351 bad: 5352 const char *type_name = is_char_constant ? gfc_typename (expr) 5353 : gfc_typename (&from_ts); 5354 if (eflag == 1) 5355 { 5356 gfc_error ("Cannot convert %s to %s at %L", type_name, gfc_typename (ts), 5357 &expr->where); 5358 return false; 5359 } 5360 5361 gfc_internal_error ("Cannot convert %qs to %qs at %L", type_name, 5362 gfc_typename (ts), &expr->where); 5363 /* Not reached */ 5364 } 5365 5366 5367 bool 5368 gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts) 5369 { 5370 gfc_intrinsic_sym *sym; 5371 locus old_where; 5372 gfc_expr *new_expr; 5373 int rank; 5374 mpz_t *shape; 5375 5376 gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER); 5377 5378 sym = find_char_conv (&expr->ts, ts); 5379 gcc_assert (sym); 5380 5381 /* Insert a pre-resolved function call to the right function. */ 5382 old_where = expr->where; 5383 rank = expr->rank; 5384 shape = expr->shape; 5385 5386 new_expr = gfc_get_expr (); 5387 *new_expr = *expr; 5388 5389 new_expr = gfc_build_conversion (new_expr); 5390 new_expr->value.function.name = sym->lib_name; 5391 new_expr->value.function.isym = sym; 5392 new_expr->where = old_where; 5393 new_expr->ts = *ts; 5394 new_expr->rank = rank; 5395 new_expr->shape = gfc_copy_shape (shape, rank); 5396 5397 gfc_get_ha_sym_tree (sym->name, &new_expr->symtree); 5398 new_expr->symtree->n.sym->ts.type = ts->type; 5399 new_expr->symtree->n.sym->ts.kind = ts->kind; 5400 new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE; 5401 new_expr->symtree->n.sym->attr.function = 1; 5402 new_expr->symtree->n.sym->attr.elemental = 1; 5403 new_expr->symtree->n.sym->attr.referenced = 1; 5404 gfc_intrinsic_symbol(new_expr->symtree->n.sym); 5405 gfc_commit_symbol (new_expr->symtree->n.sym); 5406 5407 *expr = *new_expr; 5408 5409 free (new_expr); 5410 expr->ts = *ts; 5411 5412 if (gfc_is_constant_expr (expr->value.function.actual->expr) 5413 && !do_simplify (sym, expr)) 5414 { 5415 /* Error already generated in do_simplify() */ 5416 return false; 5417 } 5418 5419 return true; 5420 } 5421 5422 5423 /* Check if the passed name is name of an intrinsic (taking into account the 5424 current -std=* and -fall-intrinsic settings). If it is, see if we should 5425 warn about this as a user-procedure having the same name as an intrinsic 5426 (-Wintrinsic-shadow enabled) and do so if we should. */ 5427 5428 void 5429 gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func) 5430 { 5431 gfc_intrinsic_sym* isym; 5432 5433 /* If the warning is disabled, do nothing at all. */ 5434 if (!warn_intrinsic_shadow) 5435 return; 5436 5437 /* Try to find an intrinsic of the same name. */ 5438 if (func) 5439 isym = gfc_find_function (sym->name); 5440 else 5441 isym = gfc_find_subroutine (sym->name); 5442 5443 /* If no intrinsic was found with this name or it's not included in the 5444 selected standard, everything's fine. */ 5445 if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true, 5446 sym->declared_at)) 5447 return; 5448 5449 /* Emit the warning. */ 5450 if (in_module || sym->ns->proc_name) 5451 gfc_warning (OPT_Wintrinsic_shadow, 5452 "%qs declared at %L may shadow the intrinsic of the same" 5453 " name. In order to call the intrinsic, explicit INTRINSIC" 5454 " declarations may be required.", 5455 sym->name, &sym->declared_at); 5456 else 5457 gfc_warning (OPT_Wintrinsic_shadow, 5458 "%qs declared at %L is also the name of an intrinsic. It can" 5459 " only be called via an explicit interface or if declared" 5460 " EXTERNAL.", sym->name, &sym->declared_at); 5461 } 5462