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