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