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