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