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