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