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