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