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