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