?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
* de.po: Update.
[official-gcc.git] / gcc / fortran / intrinsic.c
blob923572d888c44d6c176a9d1757c2bf50147d6133
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_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
1844 dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate);
1845
1846 make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU);
1847
1848 add_sym_2 ("floor", GFC_ISYM_FLOOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1849 gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
1850 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1851
1852 make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
1853
1854 /* G77 compatible fnum */
1855 add_sym_1 ("fnum", GFC_ISYM_FNUM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1856 di, GFC_STD_GNU, gfc_check_fnum, NULL, gfc_resolve_fnum,
1857 ut, BT_INTEGER, di, REQUIRED);
1858
1859 make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
1860
1861 add_sym_1 ("fraction", GFC_ISYM_FRACTION, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1862 gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
1863 x, BT_REAL, dr, REQUIRED);
1864
1865 make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
1866
1867 add_sym_2_intent ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, ACTUAL_NO,
1868 BT_INTEGER, di, GFC_STD_GNU,
1869 gfc_check_fstat, NULL, gfc_resolve_fstat,
1870 ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
1871 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
1872
1873 make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
1874
1875 add_sym_1 ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1876 ii, GFC_STD_GNU, gfc_check_ftell, NULL, gfc_resolve_ftell,
1877 ut, BT_INTEGER, di, REQUIRED);
1878
1879 make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU);
1880
1881 add_sym_2_intent ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, ACTUAL_NO,
1882 BT_INTEGER, di, GFC_STD_GNU,
1883 gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
1884 ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
1885 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
1886
1887 make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU);
1888
1889 add_sym_1_intent ("fget", GFC_ISYM_FGET, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1890 di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fget,
1891 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
1892
1893 make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU);
1894
1895 add_sym_2 ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1896 di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fputc,
1897 ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
1898
1899 make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU);
1900
1901 add_sym_1 ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1902 di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fput,
1903 c, BT_CHARACTER, dc, REQUIRED);
1904
1905 make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
1906
1907 add_sym_1 ("gamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr,
1908 GFC_STD_F2008, gfc_check_fn_r, gfc_simplify_gamma,
1909 gfc_resolve_gamma, x, BT_REAL, dr, REQUIRED);
1910
1911 add_sym_1 ("dgamma", GFC_ISYM_TGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1912 gfc_check_fn_d, gfc_simplify_gamma, gfc_resolve_gamma,
1913 x, BT_REAL, dr, REQUIRED);
1914
1915 make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008);
1916
1917 /* Unix IDs (g77 compatibility) */
1918 add_sym_1 ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1919 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getcwd,
1920 c, BT_CHARACTER, dc, REQUIRED);
1921
1922 make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
1923
1924 add_sym_0 ("getgid", GFC_ISYM_GETGID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1925 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getgid);
1926
1927 make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
1928
1929 add_sym_0 ("getpid", GFC_ISYM_GETPID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1930 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getpid);
1931
1932 make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
1933
1934 add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
1935 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid);
1936
1937 make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
1938
1939 add_sym_1_intent ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, ACTUAL_NO,
1940 BT_INTEGER, di, GFC_STD_GNU,
1941 gfc_check_hostnm, NULL, gfc_resolve_hostnm,
1942 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
1943
1944 make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
1945
1946 add_sym_1 ("huge", GFC_ISYM_HUGE, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1947 gfc_check_huge, gfc_simplify_huge, NULL,
1948 x, BT_UNKNOWN, dr, REQUIRED);
1949
1950 make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95);
1951
1952 add_sym_2 ("hypot", GFC_ISYM_HYPOT, CLASS_ELEMENTAL, ACTUAL_NO,
1953 BT_REAL, dr, GFC_STD_F2008,
1954 gfc_check_hypot, gfc_simplify_hypot, gfc_resolve_hypot,
1955 x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1956
1957 make_generic ("hypot", GFC_ISYM_HYPOT, GFC_STD_F2008);
1958
1959 add_sym_2 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO,
1960 BT_INTEGER, di, GFC_STD_F95,
1961 gfc_check_ichar_iachar, gfc_simplify_iachar, gfc_resolve_iachar,
1962 c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1963
1964 make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
1965
1966 add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1967 gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1968 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1969
1970 if (flag_dec_intrinsic_ints)
1971 {
1972 make_alias ("biand", GFC_STD_GNU);
1973 make_alias ("iiand", GFC_STD_GNU);
1974 make_alias ("jiand", GFC_STD_GNU);
1975 make_alias ("kiand", GFC_STD_GNU);
1976 }
1977
1978 make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
1979
1980 add_sym_2 ("and", GFC_ISYM_AND, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
1981 dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_and, gfc_resolve_and,
1982 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1983
1984 make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
1985
1986 add_sym_3red ("iall", GFC_ISYM_IALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
1987 gfc_check_transf_bit_intrins, gfc_simplify_iall, gfc_resolve_iall,
1988 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1989 msk, BT_LOGICAL, dl, OPTIONAL);
1990
1991 make_generic ("iall", GFC_ISYM_IALL, GFC_STD_F2008);
1992
1993 add_sym_3red ("iany", GFC_ISYM_IANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
1994 gfc_check_transf_bit_intrins, gfc_simplify_iany, gfc_resolve_iany,
1995 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1996 msk, BT_LOGICAL, dl, OPTIONAL);
1997
1998 make_generic ("iany", GFC_ISYM_IANY, GFC_STD_F2008);
1999
2000 add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
2001 di, GFC_STD_GNU, NULL, NULL, NULL);
2002
2003 make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
2004
2005 add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2006 gfc_check_bitfcn, gfc_simplify_ibclr, gfc_resolve_ibclr,
2007 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
2008
2009 if (flag_dec_intrinsic_ints)
2010 {
2011 make_alias ("bbclr", GFC_STD_GNU);
2012 make_alias ("iibclr", GFC_STD_GNU);
2013 make_alias ("jibclr", GFC_STD_GNU);
2014 make_alias ("kibclr", GFC_STD_GNU);
2015 }
2016
2017 make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
2018
2019 add_sym_3 ("ibits", GFC_ISYM_IBITS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2020 gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
2021 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
2022 ln, BT_INTEGER, di, REQUIRED);
2023
2024 if (flag_dec_intrinsic_ints)
2025 {
2026 make_alias ("bbits", GFC_STD_GNU);
2027 make_alias ("iibits", GFC_STD_GNU);
2028 make_alias ("jibits", GFC_STD_GNU);
2029 make_alias ("kibits", GFC_STD_GNU);
2030 }
2031
2032 make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
2033
2034 add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2035 gfc_check_bitfcn, gfc_simplify_ibset, gfc_resolve_ibset,
2036 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
2037
2038 if (flag_dec_intrinsic_ints)
2039 {
2040 make_alias ("bbset", GFC_STD_GNU);
2041 make_alias ("iibset", GFC_STD_GNU);
2042 make_alias ("jibset", GFC_STD_GNU);
2043 make_alias ("kibset", GFC_STD_GNU);
2044 }
2045
2046 make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
2047
2048 add_sym_2 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO,
2049 BT_INTEGER, di, GFC_STD_F77,
2050 gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
2051 c, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2052
2053 make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
2054
2055 add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2056 gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
2057 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
2058
2059 if (flag_dec_intrinsic_ints)
2060 {
2061 make_alias ("bieor", GFC_STD_GNU);
2062 make_alias ("iieor", GFC_STD_GNU);
2063 make_alias ("jieor", GFC_STD_GNU);
2064 make_alias ("kieor", GFC_STD_GNU);
2065 }
2066
2067 make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
2068
2069 add_sym_2 ("xor", GFC_ISYM_XOR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
2070 dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
2071 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
2072
2073 make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU);
2074
2075 add_sym_0 ("ierrno", GFC_ISYM_IERRNO, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
2076 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_ierrno);
2077
2078 make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
2079
2080 add_sym_2 ("image_index", GFC_ISYM_IMAGE_INDEX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
2081 gfc_check_image_index, gfc_simplify_image_index, gfc_resolve_image_index,
2082 ca, BT_REAL, dr, REQUIRED, sub, BT_INTEGER, ii, REQUIRED);
2083
2084 /* The resolution function for INDEX is called gfc_resolve_index_func
2085 because the name gfc_resolve_index is already used in resolve.c. */
2086 add_sym_4 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES,
2087 BT_INTEGER, di, GFC_STD_F77,
2088 gfc_check_index, gfc_simplify_index, gfc_resolve_index_func,
2089 stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
2090 bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
2091
2092 make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
2093
2094 add_sym_2 ("int", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2095 gfc_check_int, gfc_simplify_int, gfc_resolve_int,
2096 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2097
2098 add_sym_1 ("ifix", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2099 NULL, gfc_simplify_ifix, NULL,
2100 a, BT_REAL, dr, REQUIRED);
2101
2102 add_sym_1 ("idint", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2103 NULL, gfc_simplify_idint, NULL,
2104 a, BT_REAL, dd, REQUIRED);
2105
2106 make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
2107
2108 add_sym_1 ("int2", GFC_ISYM_INT2, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2109 gfc_check_intconv, gfc_simplify_int2, gfc_resolve_int2,
2110 a, BT_REAL, dr, REQUIRED);
2111
2112 make_alias ("short", GFC_STD_GNU);
2113
2114 make_generic ("int2", GFC_ISYM_INT2, GFC_STD_GNU);
2115
2116 add_sym_1 ("int8", GFC_ISYM_INT8, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2117 gfc_check_intconv, gfc_simplify_int8, gfc_resolve_int8,
2118 a, BT_REAL, dr, REQUIRED);
2119
2120 make_generic ("int8", GFC_ISYM_INT8, GFC_STD_GNU);
2121
2122 add_sym_1 ("long", GFC_ISYM_LONG, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2123 gfc_check_intconv, gfc_simplify_long, gfc_resolve_long,
2124 a, BT_REAL, dr, REQUIRED);
2125
2126 make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU);
2127
2128 add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2129 gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
2130 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
2131
2132 if (flag_dec_intrinsic_ints)
2133 {
2134 make_alias ("bior", GFC_STD_GNU);
2135 make_alias ("iior", GFC_STD_GNU);
2136 make_alias ("jior", GFC_STD_GNU);
2137 make_alias ("kior", GFC_STD_GNU);
2138 }
2139
2140 make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
2141
2142 add_sym_2 ("or", GFC_ISYM_OR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
2143 dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_or, gfc_resolve_or,
2144 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
2145
2146 make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
2147
2148 add_sym_3red ("iparity", GFC_ISYM_IPARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F2008,
2149 gfc_check_transf_bit_intrins, gfc_simplify_iparity, gfc_resolve_iparity,
2150 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2151 msk, BT_LOGICAL, dl, OPTIONAL);
2152
2153 make_generic ("iparity", GFC_ISYM_IPARITY, GFC_STD_F2008);
2154
2155 /* The following function is for G77 compatibility. */
2156 add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
2157 4, GFC_STD_GNU, gfc_check_irand, NULL, NULL,
2158 i, BT_INTEGER, 4, OPTIONAL);
2159
2160 make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
2161
2162 add_sym_1 ("isatty", GFC_ISYM_ISATTY, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
2163 dl, GFC_STD_GNU, gfc_check_isatty, NULL, gfc_resolve_isatty,
2164 ut, BT_INTEGER, di, REQUIRED);
2165
2166 make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU);
2167
2168 add_sym_1 ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END,
2169 CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
2170 gfc_check_i, gfc_simplify_is_iostat_end, NULL,
2171 i, BT_INTEGER, 0, REQUIRED);
2172
2173 make_generic ("is_iostat_end", GFC_ISYM_IS_IOSTAT_END, GFC_STD_F2003);
2174
2175 add_sym_1 ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR,
2176 CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F2003,
2177 gfc_check_i, gfc_simplify_is_iostat_eor, NULL,
2178 i, BT_INTEGER, 0, REQUIRED);
2179
2180 make_generic ("is_iostat_eor", GFC_ISYM_IS_IOSTAT_EOR, GFC_STD_F2003);
2181
2182 add_sym_1 ("isnan", GFC_ISYM_ISNAN, CLASS_ELEMENTAL, ACTUAL_NO,
2183 BT_LOGICAL, dl, GFC_STD_GNU,
2184 gfc_check_isnan, gfc_simplify_isnan, NULL,
2185 x, BT_REAL, 0, REQUIRED);
2186
2187 make_generic ("isnan", GFC_ISYM_ISNAN, GFC_STD_GNU);
2188
2189 add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO,
2190 BT_INTEGER, di, GFC_STD_GNU,
2191 gfc_check_ishft, gfc_simplify_rshift, gfc_resolve_rshift,
2192 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
2193
2194 make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU);
2195
2196 add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO,
2197 BT_INTEGER, di, GFC_STD_GNU,
2198 gfc_check_ishft, gfc_simplify_lshift, gfc_resolve_lshift,
2199 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
2200
2201 make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU);
2202
2203 add_sym_2 ("ishft", GFC_ISYM_ISHFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2204 gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
2205 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
2206
2207 if (flag_dec_intrinsic_ints)
2208 {
2209 make_alias ("bshft", GFC_STD_GNU);
2210 make_alias ("iishft", GFC_STD_GNU);
2211 make_alias ("jishft", GFC_STD_GNU);
2212 make_alias ("kishft", GFC_STD_GNU);
2213 }
2214
2215 make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
2216
2217 add_sym_3 ("ishftc", GFC_ISYM_ISHFTC, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2218 gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
2219 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
2220 sz, BT_INTEGER, di, OPTIONAL);
2221
2222 if (flag_dec_intrinsic_ints)
2223 {
2224 make_alias ("bshftc", GFC_STD_GNU);
2225 make_alias ("iishftc", GFC_STD_GNU);
2226 make_alias ("jishftc", GFC_STD_GNU);
2227 make_alias ("kishftc", GFC_STD_GNU);
2228 }
2229
2230 make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
2231
2232 add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
2233 di, GFC_STD_GNU, gfc_check_kill, NULL, gfc_resolve_kill,
2234 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
2235
2236 make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
2237
2238 add_sym_1 ("kind", GFC_ISYM_KIND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2239 gfc_check_kind, gfc_simplify_kind, NULL,
2240 x, BT_REAL, dr, REQUIRED);
2241
2242 make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95);
2243
2244 add_sym_3 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO,
2245 BT_INTEGER, di, GFC_STD_F95,
2246 gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
2247 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL,
2248 kind, BT_INTEGER, di, OPTIONAL);
2249
2250 make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
2251
2252 add_sym_3 ("lcobound", GFC_ISYM_LCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
2253 BT_INTEGER, di, GFC_STD_F2008,
2254 gfc_check_lcobound, gfc_simplify_lcobound, gfc_resolve_lcobound,
2255 ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2256 kind, BT_INTEGER, di, OPTIONAL);
2257
2258 make_generic ("lcobound", GFC_ISYM_LCOBOUND, GFC_STD_F2008);
2259
2260 add_sym_1 ("leadz", GFC_ISYM_LEADZ, CLASS_ELEMENTAL, ACTUAL_NO,
2261 BT_INTEGER, di, GFC_STD_F2008,
2262 gfc_check_i, gfc_simplify_leadz, NULL,
2263 i, BT_INTEGER, di, REQUIRED);
2264
2265 make_generic ("leadz", GFC_ISYM_LEADZ, GFC_STD_F2008);
2266
2267 add_sym_2 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES,
2268 BT_INTEGER, di, GFC_STD_F77,
2269 gfc_check_len_lentrim, gfc_simplify_len, gfc_resolve_len,
2270 stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2271
2272 make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
2273
2274 add_sym_2 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO,
2275 BT_INTEGER, di, GFC_STD_F95,
2276 gfc_check_len_lentrim, gfc_simplify_len_trim, gfc_resolve_len_trim,
2277 stg, BT_CHARACTER, dc, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2278
2279 make_alias ("lnblnk", GFC_STD_GNU);
2280
2281 make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
2282
2283 add_sym_1 ("lgamma", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL,
2284 dr, GFC_STD_GNU,
2285 gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma,
2286 x, BT_REAL, dr, REQUIRED);
2287
2288 make_alias ("log_gamma", GFC_STD_F2008);
2289
2290 add_sym_1 ("algama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
2291 gfc_check_fn_r, gfc_simplify_lgamma, gfc_resolve_lgamma,
2292 x, BT_REAL, dr, REQUIRED);
2293
2294 add_sym_1 ("dlgama", GFC_ISYM_LGAMMA, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
2295 gfc_check_fn_d, gfc_simplify_lgamma, gfc_resolve_lgamma,
2296 x, BT_REAL, dr, REQUIRED);
2297
2298 make_generic ("log_gamma", GFC_ISYM_LGAMMA, GFC_STD_F2008);
2299
2300
2301 add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
2302 GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lge, NULL,
2303 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
2304
2305 make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
2306
2307 add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
2308 GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lgt, NULL,
2309 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
2310
2311 make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
2312
2313 add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
2314 GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_lle, NULL,
2315 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
2316
2317 make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
2318
2319 add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl,
2320 GFC_STD_F77, gfc_check_lge_lgt_lle_llt, gfc_simplify_llt, NULL,
2321 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
2322
2323 make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
2324
2325 add_sym_2 ("link", GFC_ISYM_LINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
2326 GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link,
2327 p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
2328
2329 make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
2330
2331 add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2332 gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
2333 x, BT_REAL, dr, REQUIRED);
2334
2335 add_sym_1 ("alog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2336 NULL, gfc_simplify_log, gfc_resolve_log,
2337 x, BT_REAL, dr, REQUIRED);
2338
2339 add_sym_1 ("dlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2340 gfc_check_fn_d, gfc_simplify_log, gfc_resolve_log,
2341 x, BT_REAL, dd, REQUIRED);
2342
2343 add_sym_1 ("clog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2344 NULL, gfc_simplify_log, gfc_resolve_log,
2345 x, BT_COMPLEX, dz, REQUIRED);
2346
2347 add_sym_1 ("zlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
2348 NULL, gfc_simplify_log, gfc_resolve_log,
2349 x, BT_COMPLEX, dd, REQUIRED);
2350
2351 make_alias ("cdlog", GFC_STD_GNU);
2352
2353 make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
2354
2355 add_sym_1 ("log10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2356 gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
2357 x, BT_REAL, dr, REQUIRED);
2358
2359 add_sym_1 ("alog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2360 NULL, gfc_simplify_log10, gfc_resolve_log10,
2361 x, BT_REAL, dr, REQUIRED);
2362
2363 add_sym_1 ("dlog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2364 gfc_check_fn_d, gfc_simplify_log10, gfc_resolve_log10,
2365 x, BT_REAL, dd, REQUIRED);
2366
2367 make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
2368
2369 add_sym_2 ("logical", GFC_ISYM_LOGICAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
2370 gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
2371 l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2372
2373 make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
2374
2375 add_sym_2_intent ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, ACTUAL_NO,
2376 BT_INTEGER, di, GFC_STD_GNU,
2377 gfc_check_stat, NULL, gfc_resolve_lstat,
2378 nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
2379 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
2380
2381 make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU);
2382
2383 add_sym_1 ("malloc", GFC_ISYM_MALLOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
2384 GFC_STD_GNU, gfc_check_malloc, NULL, NULL,
2385 sz, BT_INTEGER, di, REQUIRED);
2386
2387 make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
2388
2389 add_sym_2 ("maskl", GFC_ISYM_MASKL, CLASS_ELEMENTAL, ACTUAL_NO,
2390 BT_INTEGER, di, GFC_STD_F2008,
2391 gfc_check_mask, gfc_simplify_maskl, gfc_resolve_mask,
2392 i, BT_INTEGER, di, REQUIRED,
2393 kind, BT_INTEGER, di, OPTIONAL);
2394
2395 make_generic ("maskl", GFC_ISYM_MASKL, GFC_STD_F2008);
2396
2397 add_sym_2 ("maskr", GFC_ISYM_MASKR, CLASS_ELEMENTAL, ACTUAL_NO,
2398 BT_INTEGER, di, GFC_STD_F2008,
2399 gfc_check_mask, gfc_simplify_maskr, gfc_resolve_mask,
2400 i, BT_INTEGER, di, REQUIRED,
2401 kind, BT_INTEGER, di, OPTIONAL);
2402
2403 make_generic ("maskr", GFC_ISYM_MASKR, GFC_STD_F2008);
2404
2405 add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2406 gfc_check_matmul, gfc_simplify_matmul, gfc_resolve_matmul,
2407 ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
2408
2409 make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
2410
2411 /* Note: amax0 is equivalent to real(max), max1 is equivalent to
2412 int(max). The max function must take at least two arguments. */
2413
2414 add_sym_1m ("max", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
2415 gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
2416 a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
2417
2418 add_sym_1m ("max0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2419 gfc_check_min_max_integer, gfc_simplify_max, NULL,
2420 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
2421
2422 add_sym_1m ("amax0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2423 gfc_check_min_max_integer, gfc_simplify_max, NULL,
2424 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
2425
2426 add_sym_1m ("amax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2427 gfc_check_min_max_real, gfc_simplify_max, NULL,
2428 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2429
2430 add_sym_1m ("max1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2431 gfc_check_min_max_real, gfc_simplify_max, NULL,
2432 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2433
2434 add_sym_1m ("dmax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
2435 gfc_check_min_max_double, gfc_simplify_max, NULL,
2436 a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
2437
2438 make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
2439
2440 add_sym_1 ("maxexponent", GFC_ISYM_MAXEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
2441 GFC_STD_F95, gfc_check_x, gfc_simplify_maxexponent, NULL,
2442 x, BT_UNKNOWN, dr, REQUIRED);
2443
2444 make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95);
2445
2446 add_sym_3ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2447 gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
2448 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2449 msk, BT_LOGICAL, dl, OPTIONAL);
2450
2451 make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
2452
2453 add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2454 gfc_check_minval_maxval, gfc_simplify_maxval, gfc_resolve_maxval,
2455 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2456 msk, BT_LOGICAL, dl, OPTIONAL);
2457
2458 make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
2459
2460 add_sym_0 ("mclock", GFC_ISYM_MCLOCK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
2461 GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock);
2462
2463 make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU);
2464
2465 add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
2466 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8);
2467
2468 make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU);
2469
2470 add_sym_3 ("merge", GFC_ISYM_MERGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2471 gfc_check_merge, gfc_simplify_merge, gfc_resolve_merge,
2472 ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
2473 msk, BT_LOGICAL, dl, REQUIRED);
2474
2475 make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
2476
2477 add_sym_3 ("merge_bits", GFC_ISYM_MERGE_BITS, CLASS_ELEMENTAL, ACTUAL_NO,
2478 BT_INTEGER, di, GFC_STD_F2008,
2479 gfc_check_merge_bits, gfc_simplify_merge_bits,
2480 gfc_resolve_merge_bits,
2481 i, BT_INTEGER, di, REQUIRED,
2482 j, BT_INTEGER, di, REQUIRED,
2483 msk, BT_INTEGER, di, REQUIRED);
2484
2485 make_generic ("merge_bits", GFC_ISYM_MERGE_BITS, GFC_STD_F2008);
2486
2487 /* Note: amin0 is equivalent to real(min), min1 is equivalent to
2488 int(min). */
2489
2490 add_sym_1m ("min", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
2491 gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
2492 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2493
2494 add_sym_1m ("min0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2495 gfc_check_min_max_integer, gfc_simplify_min, NULL,
2496 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
2497
2498 add_sym_1m ("amin0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2499 gfc_check_min_max_integer, gfc_simplify_min, NULL,
2500 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
2501
2502 add_sym_1m ("amin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2503 gfc_check_min_max_real, gfc_simplify_min, NULL,
2504 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2505
2506 add_sym_1m ("min1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
2507 gfc_check_min_max_real, gfc_simplify_min, NULL,
2508 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
2509
2510 add_sym_1m ("dmin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
2511 gfc_check_min_max_double, gfc_simplify_min, NULL,
2512 a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
2513
2514 make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
2515
2516 add_sym_1 ("minexponent", GFC_ISYM_MINEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
2517 GFC_STD_F95, gfc_check_x, gfc_simplify_minexponent, NULL,
2518 x, BT_UNKNOWN, dr, REQUIRED);
2519
2520 make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95);
2521
2522 add_sym_3ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2523 gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
2524 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2525 msk, BT_LOGICAL, dl, OPTIONAL);
2526
2527 make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
2528
2529 add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2530 gfc_check_minval_maxval, gfc_simplify_minval, gfc_resolve_minval,
2531 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2532 msk, BT_LOGICAL, dl, OPTIONAL);
2533
2534 make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
2535
2536 add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2537 gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
2538 a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
2539
2540 if (flag_dec_intrinsic_ints)
2541 {
2542 make_alias ("bmod", GFC_STD_GNU);
2543 make_alias ("imod", GFC_STD_GNU);
2544 make_alias ("jmod", GFC_STD_GNU);
2545 make_alias ("kmod", GFC_STD_GNU);
2546 }
2547
2548 add_sym_2 ("amod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2549 NULL, gfc_simplify_mod, gfc_resolve_mod,
2550 a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
2551
2552 add_sym_2 ("dmod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2553 gfc_check_x_yd, gfc_simplify_mod, gfc_resolve_mod,
2554 a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
2555
2556 make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
2557
2558 add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95,
2559 gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
2560 a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
2561
2562 make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
2563
2564 add_sym_2 ("nearest", GFC_ISYM_NEAREST, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2565 gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
2566 x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
2567
2568 make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
2569
2570 add_sym_1 ("new_line", GFC_ISYM_NEW_LINE, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc,
2571 GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL,
2572 a, BT_CHARACTER, dc, REQUIRED);
2573
2574 make_generic ("new_line", GFC_ISYM_NEW_LINE, GFC_STD_F2003);
2575
2576 add_sym_2 ("nint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2577 gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
2578 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2579
2580 add_sym_1 ("idnint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2581 gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
2582 a, BT_REAL, dd, REQUIRED);
2583
2584 make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
2585
2586 add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2587 gfc_check_i, gfc_simplify_not, gfc_resolve_not,
2588 i, BT_INTEGER, di, REQUIRED);
2589
2590 if (flag_dec_intrinsic_ints)
2591 {
2592 make_alias ("bnot", GFC_STD_GNU);
2593 make_alias ("inot", GFC_STD_GNU);
2594 make_alias ("jnot", GFC_STD_GNU);
2595 make_alias ("knot", GFC_STD_GNU);
2596 }
2597
2598 make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
2599
2600 add_sym_2 ("norm2", GFC_ISYM_NORM2, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
2601 GFC_STD_F2008, gfc_check_norm2, gfc_simplify_norm2, gfc_resolve_norm2,
2602 x, BT_REAL, dr, REQUIRED,
2603 dm, BT_INTEGER, ii, OPTIONAL);
2604
2605 make_generic ("norm2", GFC_ISYM_NORM2, GFC_STD_F2008);
2606
2607 add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2608 gfc_check_null, gfc_simplify_null, NULL,
2609 mo, BT_INTEGER, di, OPTIONAL);
2610
2611 make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
2612
2613 add_sym_2 ("num_images", GFC_ISYM_NUM_IMAGES, CLASS_INQUIRY, ACTUAL_NO,
2614 BT_INTEGER, di, GFC_STD_F2008,
2615 gfc_check_num_images, gfc_simplify_num_images, NULL,
2616 dist, BT_INTEGER, di, OPTIONAL,
2617 failed, BT_LOGICAL, dl, OPTIONAL);
2618
2619 add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2620 gfc_check_pack, gfc_simplify_pack, gfc_resolve_pack,
2621 ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2622 v, BT_REAL, dr, OPTIONAL);
2623
2624 make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
2625
2626
2627 add_sym_2 ("parity", GFC_ISYM_PARITY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl,
2628 GFC_STD_F2008, gfc_check_parity, gfc_simplify_parity, gfc_resolve_parity,
2629 msk, BT_LOGICAL, dl, REQUIRED,
2630 dm, BT_INTEGER, ii, OPTIONAL);
2631
2632 make_generic ("parity", GFC_ISYM_PARITY, GFC_STD_F2008);
2633
2634 add_sym_1 ("popcnt", GFC_ISYM_POPCNT, CLASS_ELEMENTAL, ACTUAL_NO,
2635 BT_INTEGER, di, GFC_STD_F2008,
2636 gfc_check_i, gfc_simplify_popcnt, NULL,
2637 i, BT_INTEGER, di, REQUIRED);
2638
2639 make_generic ("popcnt", GFC_ISYM_POPCNT, GFC_STD_F2008);
2640
2641 add_sym_1 ("poppar", GFC_ISYM_POPPAR, CLASS_ELEMENTAL, ACTUAL_NO,
2642 BT_INTEGER, di, GFC_STD_F2008,
2643 gfc_check_i, gfc_simplify_poppar, NULL,
2644 i, BT_INTEGER, di, REQUIRED);
2645
2646 make_generic ("poppar", GFC_ISYM_POPPAR, GFC_STD_F2008);
2647
2648 add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2649 gfc_check_precision, gfc_simplify_precision, NULL,
2650 x, BT_UNKNOWN, 0, REQUIRED);
2651
2652 make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95);
2653
2654 add_sym_1_intent ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO,
2655 BT_LOGICAL, dl, GFC_STD_F95, gfc_check_present, NULL, NULL,
2656 a, BT_REAL, dr, REQUIRED, INTENT_UNKNOWN);
2657
2658 make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
2659
2660 add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2661 gfc_check_product_sum, gfc_simplify_product, gfc_resolve_product,
2662 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2663 msk, BT_LOGICAL, dl, OPTIONAL);
2664
2665 make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
2666
2667 add_sym_1 ("radix", GFC_ISYM_RADIX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2668 gfc_check_radix, gfc_simplify_radix, NULL,
2669 x, BT_UNKNOWN, 0, REQUIRED);
2670
2671 make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95);
2672
2673 /* The following function is for G77 compatibility. */
2674 add_sym_1 ("rand", GFC_ISYM_RAND, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
2675 4, GFC_STD_GNU, gfc_check_rand, NULL, NULL,
2676 i, BT_INTEGER, 4, OPTIONAL);
2677
2678 /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran()
2679 use slightly different shoddy multiplicative congruential PRNG. */
2680 make_alias ("ran", GFC_STD_GNU);
2681
2682 make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
2683
2684 add_sym_1 ("range", GFC_ISYM_RANGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2685 gfc_check_range, gfc_simplify_range, NULL,
2686 x, BT_REAL, dr, REQUIRED);
2687
2688 make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95);
2689
2690 add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
2691 GFC_STD_F2008_TS, gfc_check_rank, gfc_simplify_rank, gfc_resolve_rank,
2692 a, BT_REAL, dr, REQUIRED);
2693 make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2008_TS);
2694
2695 add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2696 gfc_check_real, gfc_simplify_real, gfc_resolve_real,
2697 a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
2698
2699 /* This provides compatibility with g77. */
2700 add_sym_1 ("realpart", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
2701 gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart,
2702 a, BT_UNKNOWN, dr, REQUIRED);
2703
2704 add_sym_1 ("float", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2705 gfc_check_float, gfc_simplify_float, NULL,
2706 a, BT_INTEGER, di, REQUIRED);
2707
2708 if (flag_dec_intrinsic_ints)
2709 {
2710 make_alias ("floati", GFC_STD_GNU);
2711 make_alias ("floatj", GFC_STD_GNU);
2712 make_alias ("floatk", GFC_STD_GNU);
2713 }
2714
2715 add_sym_1 ("dfloat", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
2716 gfc_check_float, gfc_simplify_dble, gfc_resolve_dble,
2717 a, BT_REAL, dr, REQUIRED);
2718
2719 add_sym_1 ("sngl", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2720 gfc_check_sngl, gfc_simplify_sngl, NULL,
2721 a, BT_REAL, dd, REQUIRED);
2722
2723 make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
2724
2725 add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
2726 GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename,
2727 p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
2728
2729 make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
2730
2731 add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
2732 gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
2733 stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED);
2734
2735 make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
2736
2737 add_sym_4 ("reshape", GFC_ISYM_RESHAPE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2738 gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
2739 src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
2740 pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
2741
2742 make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
2743
2744 add_sym_1 ("rrspacing", GFC_ISYM_RRSPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2745 gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
2746 x, BT_REAL, dr, REQUIRED);
2747
2748 make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
2749
2750 add_sym_2 ("same_type_as", GFC_ISYM_SAME_TYPE_AS, CLASS_INQUIRY, ACTUAL_NO,
2751 BT_LOGICAL, dl, GFC_STD_F2003,
2752 gfc_check_same_type_as, gfc_simplify_same_type_as, NULL,
2753 a, BT_UNKNOWN, 0, REQUIRED,
2754 b, BT_UNKNOWN, 0, REQUIRED);
2755
2756 add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2757 gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
2758 x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
2759
2760 make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
2761
2762 add_sym_4 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO,
2763 BT_INTEGER, di, GFC_STD_F95,
2764 gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
2765 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2766 bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
2767
2768 make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
2769
2770 /* Added for G77 compatibility garbage. */
2771 add_sym_0 ("second", GFC_ISYM_SECOND, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
2772 4, GFC_STD_GNU, NULL, NULL, NULL);
2773
2774 make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
2775
2776 /* Added for G77 compatibility. */
2777 add_sym_1 ("secnds", GFC_ISYM_SECNDS, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
2778 dr, GFC_STD_GNU, gfc_check_secnds, NULL, gfc_resolve_secnds,
2779 x, BT_REAL, dr, REQUIRED);
2780
2781 make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
2782
2783 add_sym_1 ("selected_char_kind", GFC_ISYM_SC_KIND, CLASS_TRANSFORMATIONAL,
2784 ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003,
2785 gfc_check_selected_char_kind, gfc_simplify_selected_char_kind,
2786 NULL, nm, BT_CHARACTER, dc, REQUIRED);
2787
2788 make_generic ("selected_char_kind", GFC_ISYM_SC_KIND, GFC_STD_F2003);
2789
2790 add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
2791 GFC_STD_F95, gfc_check_selected_int_kind,
2792 gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED);
2793
2794 make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
2795
2796 add_sym_3 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
2797 GFC_STD_F95, gfc_check_selected_real_kind,
2798 gfc_simplify_selected_real_kind, NULL,
2799 p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL,
2800 "radix", BT_INTEGER, di, OPTIONAL);
2801
2802 make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
2803
2804 add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2805 gfc_check_set_exponent, gfc_simplify_set_exponent,
2806 gfc_resolve_set_exponent,
2807 x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
2808
2809 make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
2810
2811 add_sym_2 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2812 gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
2813 src, BT_REAL, dr, REQUIRED,
2814 kind, BT_INTEGER, di, OPTIONAL);
2815
2816 make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
2817
2818 add_sym_2 ("shifta", GFC_ISYM_SHIFTA, CLASS_ELEMENTAL, ACTUAL_NO,
2819 BT_INTEGER, di, GFC_STD_F2008,
2820 gfc_check_shift, gfc_simplify_shifta, gfc_resolve_shift,
2821 i, BT_INTEGER, di, REQUIRED,
2822 sh, BT_INTEGER, di, REQUIRED);
2823
2824 make_generic ("shifta", GFC_ISYM_SHIFTA, GFC_STD_F2008);
2825
2826 add_sym_2 ("shiftl", GFC_ISYM_SHIFTL, CLASS_ELEMENTAL, ACTUAL_NO,
2827 BT_INTEGER, di, GFC_STD_F2008,
2828 gfc_check_shift, gfc_simplify_shiftl, gfc_resolve_shift,
2829 i, BT_INTEGER, di, REQUIRED,
2830 sh, BT_INTEGER, di, REQUIRED);
2831
2832 make_generic ("shiftl", GFC_ISYM_SHIFTL, GFC_STD_F2008);
2833
2834 add_sym_2 ("shiftr", GFC_ISYM_SHIFTR, CLASS_ELEMENTAL, ACTUAL_NO,
2835 BT_INTEGER, di, GFC_STD_F2008,
2836 gfc_check_shift, gfc_simplify_shiftr, gfc_resolve_shift,
2837 i, BT_INTEGER, di, REQUIRED,
2838 sh, BT_INTEGER, di, REQUIRED);
2839
2840 make_generic ("shiftr", GFC_ISYM_SHIFTR, GFC_STD_F2008);
2841
2842 add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2843 gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
2844 a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
2845
2846 add_sym_2 ("isign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2847 NULL, gfc_simplify_sign, gfc_resolve_sign,
2848 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
2849
2850 add_sym_2 ("dsign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2851 gfc_check_x_yd, gfc_simplify_sign, gfc_resolve_sign,
2852 a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
2853
2854 make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
2855
2856 add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
2857 di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal,
2858 num, BT_INTEGER, di, REQUIRED, han, BT_VOID, 0, REQUIRED);
2859
2860 make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
2861
2862 add_sym_1 ("sin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2863 gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
2864 x, BT_REAL, dr, REQUIRED);
2865
2866 add_sym_1 ("dsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2867 gfc_check_fn_d, gfc_simplify_sin, gfc_resolve_sin,
2868 x, BT_REAL, dd, REQUIRED);
2869
2870 add_sym_1 ("csin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2871 NULL, gfc_simplify_sin, gfc_resolve_sin,
2872 x, BT_COMPLEX, dz, REQUIRED);
2873
2874 add_sym_1 ("zsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
2875 NULL, gfc_simplify_sin, gfc_resolve_sin,
2876 x, BT_COMPLEX, dd, REQUIRED);
2877
2878 make_alias ("cdsin", GFC_STD_GNU);
2879
2880 make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
2881
2882 add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2883 gfc_check_fn_rc2008, gfc_simplify_sinh, gfc_resolve_sinh,
2884 x, BT_REAL, dr, REQUIRED);
2885
2886 add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2887 gfc_check_fn_d, gfc_simplify_sinh, gfc_resolve_sinh,
2888 x, BT_REAL, dd, REQUIRED);
2889
2890 make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
2891
2892 add_sym_3 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO,
2893 BT_INTEGER, di, GFC_STD_F95,
2894 gfc_check_size, gfc_simplify_size, gfc_resolve_size,
2895 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2896 kind, BT_INTEGER, di, OPTIONAL);
2897
2898 make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
2899
2900 /* Obtain the stride for a given dimensions; to be used only internally.
2901 "make_from_module" makes it inaccessible for external users. */
2902 add_sym_2 (GFC_PREFIX ("stride"), GFC_ISYM_STRIDE, CLASS_INQUIRY, ACTUAL_NO,
2903 BT_INTEGER, gfc_index_integer_kind, GFC_STD_GNU,
2904 NULL, NULL, gfc_resolve_stride,
2905 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
2906 make_from_module();
2907
2908 add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
2909 BT_INTEGER, ii, GFC_STD_GNU,
2910 gfc_check_sizeof, gfc_simplify_sizeof, NULL,
2911 x, BT_UNKNOWN, 0, REQUIRED);
2912
2913 make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
2914
2915 /* The following functions are part of ISO_C_BINDING. */
2916 add_sym_2 ("c_associated", GFC_ISYM_C_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO,
2917 BT_LOGICAL, dl, GFC_STD_F2003, gfc_check_c_associated, NULL, NULL,
2918 c_ptr_1, BT_VOID, 0, REQUIRED,
2919 c_ptr_2, BT_VOID, 0, OPTIONAL);
2920 make_from_module();
2921
2922 add_sym_1 ("c_loc", GFC_ISYM_C_LOC, CLASS_INQUIRY, ACTUAL_NO,
2923 BT_VOID, 0, GFC_STD_F2003,
2924 gfc_check_c_loc, NULL, gfc_resolve_c_loc,
2925 x, BT_UNKNOWN, 0, REQUIRED);
2926 make_from_module();
2927
2928 add_sym_1 ("c_funloc", GFC_ISYM_C_FUNLOC, CLASS_INQUIRY, ACTUAL_NO,
2929 BT_VOID, 0, GFC_STD_F2003,
2930 gfc_check_c_funloc, NULL, gfc_resolve_c_funloc,
2931 x, BT_UNKNOWN, 0, REQUIRED);
2932 make_from_module();
2933
2934 add_sym_1 ("c_sizeof", GFC_ISYM_C_SIZEOF, CLASS_INQUIRY, ACTUAL_NO,
2935 BT_INTEGER, gfc_index_integer_kind, GFC_STD_F2008,
2936 gfc_check_c_sizeof, gfc_simplify_sizeof, NULL,
2937 x, BT_UNKNOWN, 0, REQUIRED);
2938 make_from_module();
2939
2940 /* COMPILER_OPTIONS and COMPILER_VERSION are part of ISO_FORTRAN_ENV. */
2941 add_sym_0 ("compiler_options", GFC_ISYM_COMPILER_OPTIONS, CLASS_INQUIRY,
2942 ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
2943 NULL, gfc_simplify_compiler_options, NULL);
2944 make_from_module();
2945
2946 add_sym_0 ("compiler_version", GFC_ISYM_COMPILER_VERSION, CLASS_INQUIRY,
2947 ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F2008,
2948 NULL, gfc_simplify_compiler_version, NULL);
2949 make_from_module();
2950
2951 add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2952 gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
2953 x, BT_REAL, dr, REQUIRED);
2954
2955 make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
2956
2957 add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2958 gfc_check_spread, gfc_simplify_spread, gfc_resolve_spread,
2959 src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
2960 ncopies, BT_INTEGER, di, REQUIRED);
2961
2962 make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
2963
2964 add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2965 gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
2966 x, BT_REAL, dr, REQUIRED);
2967
2968 add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2969 gfc_check_fn_d, gfc_simplify_sqrt, gfc_resolve_sqrt,
2970 x, BT_REAL, dd, REQUIRED);
2971
2972 add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2973 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2974 x, BT_COMPLEX, dz, REQUIRED);
2975
2976 add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
2977 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2978 x, BT_COMPLEX, dd, REQUIRED);
2979
2980 make_alias ("cdsqrt", GFC_STD_GNU);
2981
2982 make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
2983
2984 add_sym_2_intent ("stat", GFC_ISYM_STAT, CLASS_IMPURE, ACTUAL_NO,
2985 BT_INTEGER, di, GFC_STD_GNU,
2986 gfc_check_stat, NULL, gfc_resolve_stat,
2987 nm, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
2988 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
2989
2990 make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
2991
2992 add_sym_2 ("storage_size", GFC_ISYM_STORAGE_SIZE, CLASS_INQUIRY, ACTUAL_NO,
2993 BT_INTEGER, di, GFC_STD_F2008,
2994 gfc_check_storage_size, gfc_simplify_storage_size,
2995 gfc_resolve_storage_size,
2996 a, BT_UNKNOWN, 0, REQUIRED,
2997 kind, BT_INTEGER, di, OPTIONAL);
2998
2999 add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
3000 gfc_check_product_sum, gfc_simplify_sum, gfc_resolve_sum,
3001 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
3002 msk, BT_LOGICAL, dl, OPTIONAL);
3003
3004 make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
3005
3006 add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
3007 GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk,
3008 p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
3009
3010 make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
3011
3012 add_sym_1 ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
3013 GFC_STD_GNU, NULL, NULL, NULL,
3014 com, BT_CHARACTER, dc, REQUIRED);
3015
3016 make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
3017
3018 add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
3019 gfc_check_fn_rc2008, gfc_simplify_tan, gfc_resolve_tan,
3020 x, BT_REAL, dr, REQUIRED);
3021
3022 add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
3023 gfc_check_fn_d, gfc_simplify_tan, gfc_resolve_tan,
3024 x, BT_REAL, dd, REQUIRED);
3025
3026 make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
3027
3028 add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
3029 gfc_check_fn_rc2008, gfc_simplify_tanh, gfc_resolve_tanh,
3030 x, BT_REAL, dr, REQUIRED);
3031
3032 add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
3033 gfc_check_fn_d, gfc_simplify_tanh, gfc_resolve_tanh,
3034 x, BT_REAL, dd, REQUIRED);
3035
3036 make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
3037
3038 add_sym_3 ("this_image", GFC_ISYM_THIS_IMAGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2008,
3039 gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
3040 ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL,
3041 dist, BT_INTEGER, di, OPTIONAL);
3042
3043 add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
3044 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time);
3045
3046 make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
3047
3048 add_sym_0 ("time8", GFC_ISYM_TIME8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
3049 di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time8);
3050
3051 make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
3052
3053 add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
3054 gfc_check_x, gfc_simplify_tiny, NULL,
3055 x, BT_REAL, dr, REQUIRED);
3056
3057 make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95);
3058
3059 add_sym_1 ("trailz", GFC_ISYM_TRAILZ, CLASS_ELEMENTAL, ACTUAL_NO,
3060 BT_INTEGER, di, GFC_STD_F2008,
3061 gfc_check_i, gfc_simplify_trailz, NULL,
3062 i, BT_INTEGER, di, REQUIRED);
3063
3064 make_generic ("trailz", GFC_ISYM_TRAILZ, GFC_STD_F2008);
3065
3066 add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
3067 gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer,
3068 src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
3069 sz, BT_INTEGER, di, OPTIONAL);
3070
3071 make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
3072
3073 add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
3074 gfc_check_transpose, gfc_simplify_transpose, gfc_resolve_transpose,
3075 m, BT_REAL, dr, REQUIRED);
3076
3077 make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
3078
3079 add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
3080 gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
3081 stg, BT_CHARACTER, dc, REQUIRED);
3082
3083 make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
3084
3085 add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
3086 0, GFC_STD_GNU, gfc_check_ttynam, NULL, gfc_resolve_ttynam,
3087 ut, BT_INTEGER, di, REQUIRED);
3088
3089 make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
3090
3091 add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO,
3092 BT_INTEGER, di, GFC_STD_F95,
3093 gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
3094 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
3095 kind, BT_INTEGER, di, OPTIONAL);
3096
3097 make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
3098
3099 add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
3100 BT_INTEGER, di, GFC_STD_F2008,
3101 gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
3102 ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
3103 kind, BT_INTEGER, di, OPTIONAL);
3104
3105 make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008);
3106
3107 /* g77 compatibility for UMASK. */
3108 add_sym_1 ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
3109 GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask,
3110 msk, BT_INTEGER, di, REQUIRED);
3111
3112 make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
3113
3114 /* g77 compatibility for UNLINK. */
3115 add_sym_1 ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
3116 di, GFC_STD_GNU, gfc_check_unlink, NULL, gfc_resolve_unlink,
3117 "path", BT_CHARACTER, dc, REQUIRED);
3118
3119 make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
3120
3121 add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
3122 gfc_check_unpack, gfc_simplify_unpack, gfc_resolve_unpack,
3123 v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
3124 f, BT_REAL, dr, REQUIRED);
3125
3126 make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
3127
3128 add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO,
3129 BT_INTEGER, di, GFC_STD_F95,
3130 gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
3131 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
3132 bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
3133
3134 make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
3135
3136 add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
3137 GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc,
3138 x, BT_UNKNOWN, 0, REQUIRED);
3139
3140 make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
3141
3142 if (flag_dec_math)
3143 {
3144 add_sym_1 ("acosd", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3145 dr, GFC_STD_GNU,
3146 gfc_check_fn_r, gfc_simplify_atrigd, gfc_resolve_atrigd,
3147 x, BT_REAL, dr, REQUIRED);
3148
3149 add_sym_1 ("dacosd", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3150 dd, GFC_STD_GNU,
3151 gfc_check_fn_d, gfc_simplify_atrigd, gfc_resolve_atrigd,
3152 x, BT_REAL, dd, REQUIRED);
3153
3154 make_generic ("acosd", GFC_ISYM_ACOS, GFC_STD_GNU);
3155
3156 add_sym_1 ("asind", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3157 dr, GFC_STD_GNU,
3158 gfc_check_fn_r, gfc_simplify_atrigd, gfc_resolve_atrigd,
3159 x, BT_REAL, dr, REQUIRED);
3160
3161 add_sym_1 ("dasind", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3162 dd, GFC_STD_GNU,
3163 gfc_check_fn_d, gfc_simplify_atrigd, gfc_resolve_atrigd,
3164 x, BT_REAL, dd, REQUIRED);
3165
3166 make_generic ("asind", GFC_ISYM_ASIN, GFC_STD_GNU);
3167
3168 add_sym_1 ("atand", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3169 dr, GFC_STD_GNU,
3170 gfc_check_fn_r, gfc_simplify_atrigd, gfc_resolve_atrigd,
3171 x, BT_REAL, dr, REQUIRED);
3172
3173 add_sym_1 ("datand", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3174 dd, GFC_STD_GNU,
3175 gfc_check_fn_d, gfc_simplify_atrigd, gfc_resolve_atrigd,
3176 x, BT_REAL, dd, REQUIRED);
3177
3178 make_generic ("atand", GFC_ISYM_ATAN, GFC_STD_GNU);
3179
3180 add_sym_2 ("atan2d",GFC_ISYM_ATAN2,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3181 dr, GFC_STD_GNU,
3182 gfc_check_atan2, gfc_simplify_atan2d, gfc_resolve_atan2d,
3183 y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
3184
3185 add_sym_2 ("datan2d",GFC_ISYM_ATAN2,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3186 dd, GFC_STD_GNU,
3187 gfc_check_datan2, gfc_simplify_atan2d, gfc_resolve_atan2d,
3188 y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
3189
3190 make_generic ("atan2d", GFC_ISYM_ATAN2, GFC_STD_GNU);
3191
3192 add_sym_1 ("cosd", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3193 dr, GFC_STD_GNU,
3194 gfc_check_fn_r, gfc_simplify_trigd, gfc_resolve_trigd,
3195 x, BT_REAL, dr, REQUIRED);
3196
3197 add_sym_1 ("dcosd", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3198 dd, GFC_STD_GNU,
3199 gfc_check_fn_d, gfc_simplify_trigd, gfc_resolve_trigd,
3200 x, BT_REAL, dd, REQUIRED);
3201
3202 make_generic ("cosd", GFC_ISYM_COS, GFC_STD_GNU);
3203
3204 add_sym_1 ("cotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3205 dr, GFC_STD_GNU,
3206 gfc_check_fn_rc2008, gfc_simplify_cotan, gfc_resolve_cotan,
3207 x, BT_REAL, dr, REQUIRED);
3208
3209 add_sym_1 ("dcotan", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3210 dd, GFC_STD_GNU,
3211 gfc_check_fn_d, gfc_simplify_cotan, gfc_resolve_cotan,
3212 x, BT_REAL, dd, REQUIRED);
3213
3214 make_generic ("cotan", GFC_ISYM_COTAN, GFC_STD_GNU);
3215
3216 add_sym_1 ("cotand", GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3217 dr, GFC_STD_GNU,
3218 gfc_check_fn_r, gfc_simplify_trigd, gfc_resolve_trigd,
3219 x, BT_REAL, dr, REQUIRED);
3220
3221 add_sym_1 ("dcotand",GFC_ISYM_COTAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3222 dd, GFC_STD_GNU,
3223 gfc_check_fn_d, gfc_simplify_trigd, gfc_resolve_trigd,
3224 x, BT_REAL, dd, REQUIRED);
3225
3226 make_generic ("cotand", GFC_ISYM_COTAN, GFC_STD_GNU);
3227
3228 add_sym_1 ("sind", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3229 dr, GFC_STD_GNU,
3230 gfc_check_fn_r, gfc_simplify_trigd, gfc_resolve_trigd,
3231 x, BT_REAL, dr, REQUIRED);
3232
3233 add_sym_1 ("dsind", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3234 dd, GFC_STD_GNU,
3235 gfc_check_fn_d, gfc_simplify_trigd, gfc_resolve_trigd,
3236 x, BT_REAL, dd, REQUIRED);
3237
3238 make_generic ("sind", GFC_ISYM_SIN, GFC_STD_GNU);
3239
3240 add_sym_1 ("tand", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3241 dr, GFC_STD_GNU,
3242 gfc_check_fn_r, gfc_simplify_trigd, gfc_resolve_trigd,
3243 x, BT_REAL, dr, REQUIRED);
3244
3245 add_sym_1 ("dtand", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL,
3246 dd, GFC_STD_GNU,
3247 gfc_check_fn_d, gfc_simplify_trigd, gfc_resolve_trigd,
3248 x, BT_REAL, dd, REQUIRED);
3249
3250 make_generic ("tand", GFC_ISYM_TAN, GFC_STD_GNU);
3251 }
3252
3253 /* The following function is internally used for coarray libray functions.
3254 "make_from_module" makes it inaccessible for external users. */
3255 add_sym_1 (GFC_PREFIX ("caf_get"), GFC_ISYM_CAF_GET, CLASS_IMPURE, ACTUAL_NO,
3256 BT_REAL, dr, GFC_STD_GNU, NULL, NULL, NULL,
3257 x, BT_REAL, dr, REQUIRED);
3258 make_from_module();
3259 }
3260
3261
3262 /* Add intrinsic subroutines. */
3263
3264 static void
3265 add_subroutines (void)
3266 {
3267 /* Argument names as in the standard (to be used as argument keywords). */
3268 const char
3269 *a = "a", *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
3270 *c = "count", *tm = "time", *tp = "topos", *gt = "get",
3271 *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
3272 *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
3273 *com = "command", *length = "length", *st = "status",
3274 *val = "value", *num = "number", *name = "name",
3275 *trim_name = "trim_name", *ut = "unit", *han = "handler",
3276 *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
3277 *whence = "whence", *pos = "pos", *ptr = "ptr", *p1 = "path1",
3278 *p2 = "path2", *msk = "mask", *old = "old", *result_image = "result_image",
3279 *stat = "stat", *errmsg = "errmsg";
3280
3281 int di, dr, dc, dl, ii;
3282
3283 di = gfc_default_integer_kind;
3284 dr = gfc_default_real_kind;
3285 dc = gfc_default_character_kind;
3286 dl = gfc_default_logical_kind;
3287 ii = gfc_index_integer_kind;
3288
3289 add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL);
3290
3291 make_noreturn();
3292
3293 add_sym_3s ("atomic_define", GFC_ISYM_ATOMIC_DEF, CLASS_ATOMIC,
3294 BT_UNKNOWN, 0, GFC_STD_F2008,
3295 gfc_check_atomic_def, NULL, gfc_resolve_atomic_def,
3296 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3297 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3298 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3299
3300 add_sym_3s ("atomic_ref", GFC_ISYM_ATOMIC_REF, CLASS_ATOMIC,
3301 BT_UNKNOWN, 0, GFC_STD_F2008,
3302 gfc_check_atomic_ref, NULL, gfc_resolve_atomic_ref,
3303 "value", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3304 "atom", BT_INTEGER, di, REQUIRED, INTENT_IN,
3305 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3306
3307 add_sym_5s ("atomic_cas", GFC_ISYM_ATOMIC_CAS, CLASS_ATOMIC,
3308 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3309 gfc_check_atomic_cas, NULL, NULL,
3310 "atom", BT_INTEGER, di, REQUIRED, INTENT_INOUT,
3311 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3312 "compare", BT_INTEGER, di, REQUIRED, INTENT_IN,
3313 "new", BT_INTEGER, di, REQUIRED, INTENT_IN,
3314 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3315
3316 add_sym_3s ("atomic_add", GFC_ISYM_ATOMIC_ADD, CLASS_ATOMIC,
3317 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3318 gfc_check_atomic_op, NULL, NULL,
3319 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3320 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3321 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3322
3323 add_sym_3s ("atomic_and", GFC_ISYM_ATOMIC_AND, CLASS_ATOMIC,
3324 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3325 gfc_check_atomic_op, NULL, NULL,
3326 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3327 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3328 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3329
3330 add_sym_3s ("atomic_or", GFC_ISYM_ATOMIC_OR, CLASS_ATOMIC,
3331 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3332 gfc_check_atomic_op, NULL, NULL,
3333 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3334 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3335 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3336
3337 add_sym_3s ("atomic_xor", GFC_ISYM_ATOMIC_XOR, CLASS_ATOMIC,
3338 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3339 gfc_check_atomic_op, NULL, NULL,
3340 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3341 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3342 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3343
3344 add_sym_4s ("atomic_fetch_add", GFC_ISYM_ATOMIC_FETCH_ADD, CLASS_ATOMIC,
3345 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3346 gfc_check_atomic_fetch_op, NULL, NULL,
3347 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3348 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3349 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3350 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3351
3352 add_sym_4s ("atomic_fetch_and", GFC_ISYM_ATOMIC_FETCH_AND, CLASS_ATOMIC,
3353 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3354 gfc_check_atomic_fetch_op, NULL, NULL,
3355 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3356 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3357 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3358 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3359
3360 add_sym_4s ("atomic_fetch_or", GFC_ISYM_ATOMIC_FETCH_OR, CLASS_ATOMIC,
3361 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3362 gfc_check_atomic_fetch_op, NULL, NULL,
3363 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3364 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3365 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3366 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3367
3368 add_sym_4s ("atomic_fetch_xor", GFC_ISYM_ATOMIC_FETCH_XOR, CLASS_ATOMIC,
3369 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3370 gfc_check_atomic_fetch_op, NULL, NULL,
3371 "atom", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3372 "value", BT_INTEGER, di, REQUIRED, INTENT_IN,
3373 "old", BT_INTEGER, di, REQUIRED, INTENT_OUT,
3374 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3375
3376 add_sym_0s ("backtrace", GFC_ISYM_BACKTRACE, GFC_STD_GNU, NULL);
3377
3378 add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0,
3379 GFC_STD_F95, gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
3380 tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
3381
3382 add_sym_3s ("event_query", GFC_ISYM_EVENT_QUERY, CLASS_ATOMIC,
3383 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3384 gfc_check_event_query, NULL, gfc_resolve_event_query,
3385 "event", BT_INTEGER, di, REQUIRED, INTENT_IN,
3386 c, BT_INTEGER, di, OPTIONAL, INTENT_IN,
3387 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3388
3389 /* More G77 compatibility garbage. */
3390 add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3391 gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
3392 tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
3393 res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
3394
3395 add_sym_1s ("idate", GFC_ISYM_IDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3396 gfc_check_itime_idate, NULL, gfc_resolve_idate,
3397 vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT);
3398
3399 add_sym_1s ("itime", GFC_ISYM_ITIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3400 gfc_check_itime_idate, NULL, gfc_resolve_itime,
3401 vl, BT_INTEGER, 4, REQUIRED, INTENT_OUT);
3402
3403 add_sym_2s ("ltime", GFC_ISYM_LTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3404 gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime,
3405 tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
3406 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
3407
3408 add_sym_2s ("gmtime", GFC_ISYM_GMTIME, CLASS_IMPURE, BT_UNKNOWN, 0,
3409 GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime,
3410 tm, BT_INTEGER, di, REQUIRED, INTENT_IN,
3411 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT);
3412
3413 add_sym_1s ("second", GFC_ISYM_SECOND, CLASS_IMPURE, BT_UNKNOWN, 0,
3414 GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub,
3415 tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
3416
3417 add_sym_2s ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3418 gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
3419 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3420 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3421
3422 add_sym_3s ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3423 gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
3424 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3425 md, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3426 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3427
3428 add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, CLASS_IMPURE, BT_UNKNOWN,
3429 0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL,
3430 dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
3431 tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
3432 zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
3433 vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3434
3435 /* More G77 compatibility garbage. */
3436 add_sym_2s ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3437 gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub,
3438 vl, BT_REAL, 4, REQUIRED, INTENT_OUT,
3439 tm, BT_REAL, 4, REQUIRED, INTENT_OUT);
3440
3441 add_sym_2s ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3442 gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub,
3443 vl, BT_REAL, 4, REQUIRED, INTENT_OUT,
3444 tm, BT_REAL, 4, REQUIRED, INTENT_OUT);
3445
3446 add_sym_5s ("execute_command_line", GFC_ISYM_EXECUTE_COMMAND_LINE,
3447 CLASS_IMPURE , BT_UNKNOWN, 0, GFC_STD_F2008,
3448 NULL, NULL, gfc_resolve_execute_command_line,
3449 "command", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3450 "wait", BT_LOGICAL, dl, OPTIONAL, INTENT_IN,
3451 "exitstat", BT_INTEGER, di, OPTIONAL, INTENT_INOUT,
3452 "cmdstat", BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3453 "cmdmsg", BT_CHARACTER, dc, OPTIONAL, INTENT_INOUT);
3454
3455 add_sym_1s ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3456 gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
3457 dt, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
3458
3459 add_sym_1s ("gerror", GFC_ISYM_GERROR, CLASS_IMPURE, BT_UNKNOWN,
3460 0, GFC_STD_GNU, gfc_check_gerror, NULL, gfc_resolve_gerror,
3461 res, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
3462
3463 add_sym_2s ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, BT_UNKNOWN, 0,
3464 GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
3465 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
3466 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3467
3468 add_sym_2s ("getenv", GFC_ISYM_GETENV, CLASS_IMPURE, BT_UNKNOWN,
3469 0, GFC_STD_GNU, NULL, NULL, NULL,
3470 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3471 val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
3472
3473 add_sym_2s ("getarg", GFC_ISYM_GETARG, CLASS_IMPURE, BT_UNKNOWN,
3474 0, GFC_STD_GNU, gfc_check_getarg, NULL, gfc_resolve_getarg,
3475 pos, BT_INTEGER, di, REQUIRED, INTENT_IN,
3476 val, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
3477
3478 add_sym_1s ("getlog", GFC_ISYM_GETLOG, CLASS_IMPURE, BT_UNKNOWN,
3479 0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog,
3480 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
3481
3482 /* F2003 commandline routines. */
3483
3484 add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, CLASS_IMPURE,
3485 BT_UNKNOWN, 0, GFC_STD_F2003,
3486 NULL, NULL, gfc_resolve_get_command,
3487 com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
3488 length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3489 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3490
3491 add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT,
3492 CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL,
3493 gfc_resolve_get_command_argument,
3494 num, BT_INTEGER, di, REQUIRED, INTENT_IN,
3495 val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
3496 length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3497 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3498
3499 /* F2003 subroutine to get environment variables. */
3500
3501 add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE,
3502 CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003,
3503 NULL, NULL, gfc_resolve_get_environment_variable,
3504 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3505 val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
3506 length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3507 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3508 trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
3509
3510 add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE, BT_UNKNOWN, 0,
3511 GFC_STD_F2003,
3512 gfc_check_move_alloc, NULL, NULL,
3513 f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT,
3514 t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
3515
3516 add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0,
3517 GFC_STD_F95, gfc_check_mvbits, NULL, gfc_resolve_mvbits,
3518 f, BT_INTEGER, di, REQUIRED, INTENT_IN,
3519 fp, BT_INTEGER, di, REQUIRED, INTENT_IN,
3520 ln, BT_INTEGER, di, REQUIRED, INTENT_IN,
3521 t, BT_INTEGER, di, REQUIRED, INTENT_INOUT,
3522 tp, BT_INTEGER, di, REQUIRED, INTENT_IN);
3523
3524 if (flag_dec_intrinsic_ints)
3525 {
3526 make_alias ("bmvbits", GFC_STD_GNU);
3527 make_alias ("imvbits", GFC_STD_GNU);
3528 make_alias ("jmvbits", GFC_STD_GNU);
3529 make_alias ("kmvbits", GFC_STD_GNU);
3530 }
3531
3532 add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE,
3533 BT_UNKNOWN, 0, GFC_STD_F95,
3534 gfc_check_random_number, NULL, gfc_resolve_random_number,
3535 h, BT_REAL, dr, REQUIRED, INTENT_OUT);
3536
3537 add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, CLASS_IMPURE,
3538 BT_UNKNOWN, 0, GFC_STD_F95,
3539 gfc_check_random_seed, NULL, gfc_resolve_random_seed,
3540 sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3541 pt, BT_INTEGER, di, OPTIONAL, INTENT_IN,
3542 gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3543
3544 /* The following subroutines are part of ISO_C_BINDING. */
3545
3546 add_sym_3s ("c_f_pointer", GFC_ISYM_C_F_POINTER, CLASS_IMPURE, BT_UNKNOWN, 0,
3547 GFC_STD_F2003, gfc_check_c_f_pointer, NULL, NULL,
3548 "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
3549 "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT,
3550 "shape", BT_INTEGER, di, OPTIONAL, INTENT_IN);
3551 make_from_module();
3552
3553 add_sym_2s ("c_f_procpointer", GFC_ISYM_C_F_PROCPOINTER, CLASS_IMPURE,
3554 BT_UNKNOWN, 0, GFC_STD_F2003, gfc_check_c_f_procpointer,
3555 NULL, NULL,
3556 "cptr", BT_VOID, 0, REQUIRED, INTENT_IN,
3557 "fptr", BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
3558 make_from_module();
3559
3560 /* Internal subroutine for emitting a runtime error. */
3561
3562 add_sym_1p ("fe_runtime_error", GFC_ISYM_FE_RUNTIME_ERROR, CLASS_IMPURE,
3563 BT_UNKNOWN, 0, GFC_STD_GNU,
3564 gfc_check_fe_runtime_error, NULL, gfc_resolve_fe_runtime_error,
3565 "msg", BT_CHARACTER, dc, REQUIRED, INTENT_IN);
3566
3567 make_noreturn ();
3568 make_vararg ();
3569 make_from_module ();
3570
3571 /* Coarray collectives. */
3572 add_sym_4s ("co_broadcast", GFC_ISYM_CO_BROADCAST, CLASS_IMPURE,
3573 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3574 gfc_check_co_broadcast, NULL, NULL,
3575 a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
3576 "source_image", BT_INTEGER, di, REQUIRED, INTENT_IN,
3577 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3578 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
3579
3580 add_sym_4s ("co_max", GFC_ISYM_CO_MAX, CLASS_IMPURE,
3581 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3582 gfc_check_co_minmax, NULL, NULL,
3583 a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
3584 result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
3585 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3586 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
3587
3588 add_sym_4s ("co_min", GFC_ISYM_CO_MIN, CLASS_IMPURE,
3589 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3590 gfc_check_co_minmax, NULL, NULL,
3591 a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
3592 result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
3593 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3594 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
3595
3596 add_sym_4s ("co_sum", GFC_ISYM_CO_SUM, CLASS_IMPURE,
3597 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3598 gfc_check_co_sum, NULL, NULL,
3599 a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
3600 result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
3601 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3602 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
3603
3604 add_sym_5s ("co_reduce", GFC_ISYM_CO_REDUCE, CLASS_IMPURE,
3605 BT_UNKNOWN, 0, GFC_STD_F2008_TS,
3606 gfc_check_co_reduce, NULL, NULL,
3607 a, BT_REAL, dr, REQUIRED, INTENT_INOUT,
3608 "operator", BT_INTEGER, di, REQUIRED, INTENT_IN,
3609 result_image, BT_INTEGER, di, OPTIONAL, INTENT_IN,
3610 stat, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3611 errmsg, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT);
3612
3613
3614 /* The following subroutine is internally used for coarray libray functions.
3615 "make_from_module" makes it inaccessible for external users. */
3616 add_sym_2s (GFC_PREFIX ("caf_send"), GFC_ISYM_CAF_SEND, CLASS_IMPURE,
3617 BT_UNKNOWN, 0, GFC_STD_GNU, NULL, NULL, NULL,
3618 "x", BT_REAL, dr, REQUIRED, INTENT_OUT,
3619 "y", BT_REAL, dr, REQUIRED, INTENT_IN);
3620 make_from_module();
3621
3622
3623 /* More G77 compatibility garbage. */
3624 add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3625 gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
3626 sec, BT_INTEGER, di, REQUIRED, INTENT_IN,
3627 han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN,
3628 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3629
3630 add_sym_1s ("srand", GFC_ISYM_SRAND, CLASS_IMPURE, BT_UNKNOWN,
3631 di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand,
3632 "seed", BT_INTEGER, 4, REQUIRED, INTENT_IN);
3633
3634 add_sym_1s ("exit", GFC_ISYM_EXIT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3635 gfc_check_exit, NULL, gfc_resolve_exit,
3636 st, BT_INTEGER, di, OPTIONAL, INTENT_IN);
3637
3638 make_noreturn();
3639
3640 add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3641 gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
3642 ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
3643 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
3644 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3645
3646 add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3647 gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
3648 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
3649 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3650
3651 add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3652 gfc_check_flush, NULL, gfc_resolve_flush,
3653 ut, BT_INTEGER, di, OPTIONAL, INTENT_IN);
3654
3655 add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3656 gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
3657 ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
3658 c, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3659 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3660
3661 add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3662 gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
3663 c, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3664 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3665
3666 add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3667 gfc_check_free, NULL, NULL,
3668 ptr, BT_INTEGER, ii, REQUIRED, INTENT_INOUT);
3669
3670 add_sym_4s ("fseek", GFC_ISYM_FSEEK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3671 gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
3672 ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
3673 of, BT_INTEGER, di, REQUIRED, INTENT_IN,
3674 whence, BT_INTEGER, di, REQUIRED, INTENT_IN,
3675 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3676
3677 add_sym_2s ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3678 gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
3679 ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
3680 of, BT_INTEGER, ii, REQUIRED, INTENT_OUT);
3681
3682 add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, BT_UNKNOWN, 0,
3683 GFC_STD_GNU, gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
3684 c, BT_CHARACTER, dc, REQUIRED, INTENT_OUT,
3685 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3686
3687 add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3688 gfc_check_kill_sub, NULL, gfc_resolve_kill_sub,
3689 c, BT_INTEGER, di, REQUIRED, INTENT_IN,
3690 val, BT_INTEGER, di, REQUIRED, INTENT_IN,
3691 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3692
3693 add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3694 gfc_check_link_sub, NULL, gfc_resolve_link_sub,
3695 p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3696 p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3697 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3698
3699 add_sym_1s ("perror", GFC_ISYM_PERROR, CLASS_IMPURE, BT_UNKNOWN,
3700 0, GFC_STD_GNU, gfc_check_perror, NULL, gfc_resolve_perror,
3701 "string", BT_CHARACTER, dc, REQUIRED, INTENT_IN);
3702
3703 add_sym_3s ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, BT_UNKNOWN, 0,
3704 GFC_STD_GNU, gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
3705 p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3706 p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3707 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3708
3709 add_sym_1s ("sleep", GFC_ISYM_SLEEP, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3710 gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
3711 sec, BT_INTEGER, di, REQUIRED, INTENT_IN);
3712
3713 add_sym_3s ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3714 gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
3715 ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
3716 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
3717 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3718
3719 add_sym_3s ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3720 gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub,
3721 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3722 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
3723 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3724
3725 add_sym_3s ("stat", GFC_ISYM_STAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3726 gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
3727 name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3728 vl, BT_INTEGER, di, REQUIRED, INTENT_OUT,
3729 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3730
3731 add_sym_3s ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, BT_UNKNOWN, 0,
3732 GFC_STD_GNU, gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
3733 num, BT_INTEGER, di, REQUIRED, INTENT_IN,
3734 han, BT_UNKNOWN, 0, REQUIRED, INTENT_IN,
3735 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3736
3737 add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, CLASS_IMPURE, BT_UNKNOWN, 0,
3738 GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
3739 p1, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3740 p2, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3741 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3742
3743 add_sym_2s ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, BT_UNKNOWN,
3744 0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub,
3745 com, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3746 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3747
3748 add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, CLASS_IMPURE,
3749 BT_UNKNOWN, 0, GFC_STD_F95,
3750 gfc_check_system_clock, NULL, gfc_resolve_system_clock,
3751 c, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3752 cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
3753 cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3754
3755 add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, BT_UNKNOWN, 0,
3756 GFC_STD_GNU, gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
3757 ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
3758 name, BT_CHARACTER, dc, REQUIRED, INTENT_OUT);
3759
3760 add_sym_2s ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
3761 gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
3762 msk, BT_INTEGER, di, REQUIRED, INTENT_IN,
3763 old, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3764
3765 add_sym_2s ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, BT_UNKNOWN, 0,
3766 GFC_STD_GNU, gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
3767 "path", BT_CHARACTER, dc, REQUIRED, INTENT_IN,
3768 st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
3769 }
3770
3771
3772 /* Add a function to the list of conversion symbols. */
3773
3774 static void
3775 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
3776 {
3777 gfc_typespec from, to;
3778 gfc_intrinsic_sym *sym;
3779
3780 if (sizing == SZ_CONVS)
3781 {
3782 nconv++;
3783 return;
3784 }
3785
3786 gfc_clear_ts (&from);
3787 from.type = from_type;
3788 from.kind = from_kind;
3789
3790 gfc_clear_ts (&to);
3791 to.type = to_type;
3792 to.kind = to_kind;
3793
3794 sym = conversion + nconv;
3795
3796 sym->name = conv_name (&from, &to);
3797 sym->lib_name = sym->name;
3798 sym->simplify.cc = gfc_convert_constant;
3799 sym->standard = standard;
3800 sym->elemental = 1;
3801 sym->pure = 1;
3802 sym->conversion = 1;
3803 sym->ts = to;
3804 sym->id = GFC_ISYM_CONVERSION;
3805
3806 nconv++;
3807 }
3808
3809
3810 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
3811 functions by looping over the kind tables. */
3812
3813 static void
3814 add_conversions (void)
3815 {
3816 int i, j;
3817
3818 /* Integer-Integer conversions. */
3819 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3820 for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
3821 {
3822 if (i == j)
3823 continue;
3824
3825 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
3826 BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
3827 }
3828
3829 /* Integer-Real/Complex conversions. */
3830 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3831 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
3832 {
3833 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
3834 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
3835
3836 add_conv (BT_REAL, gfc_real_kinds[j].kind,
3837 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
3838
3839 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
3840 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
3841
3842 add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
3843 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
3844 }
3845
3846 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
3847 {
3848 /* Hollerith-Integer conversions. */
3849 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
3850 add_conv (BT_HOLLERITH, gfc_default_character_kind,
3851 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
3852 /* Hollerith-Real conversions. */
3853 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3854 add_conv (BT_HOLLERITH, gfc_default_character_kind,
3855 BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
3856 /* Hollerith-Complex conversions. */
3857 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3858 add_conv (BT_HOLLERITH, gfc_default_character_kind,
3859 BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
3860
3861 /* Hollerith-Character conversions. */
3862 add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
3863 gfc_default_character_kind, GFC_STD_LEGACY);
3864
3865 /* Hollerith-Logical conversions. */
3866 for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
3867 add_conv (BT_HOLLERITH, gfc_default_character_kind,
3868 BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
3869 }
3870
3871 /* Real/Complex - Real/Complex conversions. */
3872 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
3873 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
3874 {
3875 if (i != j)
3876 {
3877 add_conv (BT_REAL, gfc_real_kinds[i].kind,
3878 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
3879
3880 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
3881 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
3882 }
3883
3884 add_conv (BT_REAL, gfc_real_kinds[i].kind,
3885 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
3886
3887 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
3888 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
3889 }
3890
3891 /* Logical/Logical kind conversion. */
3892 for (i = 0; gfc_logical_kinds[i].kind; i++)
3893 for (j = 0; gfc_logical_kinds[j].kind; j++)
3894 {
3895 if (i == j)
3896 continue;
3897
3898 add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
3899 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
3900 }
3901
3902 /* Integer-Logical and Logical-Integer conversions. */
3903 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
3904 for (i=0; gfc_integer_kinds[i].kind; i++)
3905 for (j=0; gfc_logical_kinds[j].kind; j++)
3906 {
3907 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
3908 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
3909 add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
3910 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
3911 }
3912 }
3913
3914
3915 static void
3916 add_char_conversions (void)
3917 {
3918 int n, i, j;
3919
3920 /* Count possible conversions. */
3921 for (i = 0; gfc_character_kinds[i].kind != 0; i++)
3922 for (j = 0; gfc_character_kinds[j].kind != 0; j++)
3923 if (i != j)
3924 ncharconv++;
3925
3926 /* Allocate memory. */
3927 char_conversions = XCNEWVEC (gfc_intrinsic_sym, ncharconv);
3928
3929 /* Add the conversions themselves. */
3930 n = 0;
3931 for (i = 0; gfc_character_kinds[i].kind != 0; i++)
3932 for (j = 0; gfc_character_kinds[j].kind != 0; j++)
3933 {
3934 gfc_typespec from, to;
3935
3936 if (i == j)
3937 continue;
3938
3939 gfc_clear_ts (&from);
3940 from.type = BT_CHARACTER;
3941 from.kind = gfc_character_kinds[i].kind;
3942
3943 gfc_clear_ts (&to);
3944 to.type = BT_CHARACTER;
3945 to.kind = gfc_character_kinds[j].kind;
3946
3947 char_conversions[n].name = conv_name (&from, &to);
3948 char_conversions[n].lib_name = char_conversions[n].name;
3949 char_conversions[n].simplify.cc = gfc_convert_char_constant;
3950 char_conversions[n].standard = GFC_STD_F2003;
3951 char_conversions[n].elemental = 1;
3952 char_conversions[n].pure = 1;
3953 char_conversions[n].conversion = 0;
3954 char_conversions[n].ts = to;
3955 char_conversions[n].id = GFC_ISYM_CONVERSION;
3956
3957 n++;
3958 }
3959 }
3960
3961
3962 /* Initialize the table of intrinsics. */
3963 void
3964 gfc_intrinsic_init_1 (void)
3965 {
3966 nargs = nfunc = nsub = nconv = 0;
3967
3968 /* Create a namespace to hold the resolved intrinsic symbols. */
3969 gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
3970
3971 sizing = SZ_FUNCS;
3972 add_functions ();
3973 sizing = SZ_SUBS;
3974 add_subroutines ();
3975 sizing = SZ_CONVS;
3976 add_conversions ();
3977
3978 functions = XCNEWVAR (struct gfc_intrinsic_sym,
3979 sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
3980 + sizeof (gfc_intrinsic_arg) * nargs);
3981
3982 next_sym = functions;
3983 subroutines = functions + nfunc;
3984
3985 conversion = XCNEWVEC (gfc_intrinsic_sym, nconv);
3986
3987 next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
3988
3989 sizing = SZ_NOTHING;
3990 nconv = 0;
3991
3992 add_functions ();
3993 add_subroutines ();
3994 add_conversions ();
3995
3996 /* Character conversion intrinsics need to be treated separately. */
3997 add_char_conversions ();
3998 }
3999
4000
4001 void
4002 gfc_intrinsic_done_1 (void)
4003 {
4004 free (functions);
4005 free (conversion);
4006 free (char_conversions);
4007 gfc_free_namespace (gfc_intrinsic_namespace);
4008 }
4009
4010
4011 /******** Subroutines to check intrinsic interfaces ***********/
4012
4013 /* Given a formal argument list, remove any NULL arguments that may
4014 have been left behind by a sort against some formal argument list. */
4015
4016 static void
4017 remove_nullargs (gfc_actual_arglist **ap)
4018 {
4019 gfc_actual_arglist *head, *tail, *next;
4020
4021 tail = NULL;
4022
4023 for (head = *ap; head; head = next)
4024 {
4025 next = head->next;
4026
4027 if (head->expr == NULL && !head->label)
4028 {
4029 head->next = NULL;
4030 gfc_free_actual_arglist (head);
4031 }
4032 else
4033 {
4034 if (tail == NULL)
4035 *ap = head;
4036 else
4037 tail->next = head;
4038
4039 tail = head;
4040 tail->next = NULL;
4041 }
4042 }
4043
4044 if (tail == NULL)
4045 *ap = NULL;
4046 }
4047
4048
4049 /* Given an actual arglist and a formal arglist, sort the actual
4050 arglist so that its arguments are in a one-to-one correspondence
4051 with the format arglist. Arguments that are not present are given
4052 a blank gfc_actual_arglist structure. If something is obviously
4053 wrong (say, a missing required argument) we abort sorting and
4054 return false. */
4055
4056 static bool
4057 sort_actual (const char *name, gfc_actual_arglist **ap,
4058 gfc_intrinsic_arg *formal, locus *where)
4059 {
4060 gfc_actual_arglist *actual, *a;
4061 gfc_intrinsic_arg *f;
4062
4063 remove_nullargs (ap);
4064 actual = *ap;
4065
4066 for (f = formal; f; f = f->next)
4067 f->actual = NULL;
4068
4069 f = formal;
4070 a = actual;
4071
4072 if (f == NULL && a == NULL) /* No arguments */
4073 return true;
4074
4075 for (;;)
4076 { /* Put the nonkeyword arguments in a 1:1 correspondence */
4077 if (f == NULL)
4078 break;
4079 if (a == NULL)
4080 goto optional;
4081
4082 if (a->name != NULL)
4083 goto keywords;
4084
4085 f->actual = a;
4086
4087 f = f->next;
4088 a = a->next;
4089 }
4090
4091 if (a == NULL)
4092 goto do_sort;
4093
4094 gfc_error ("Too many arguments in call to %qs at %L", name, where);
4095 return false;
4096
4097 keywords:
4098 /* Associate the remaining actual arguments, all of which have
4099 to be keyword arguments. */
4100 for (; a; a = a->next)
4101 {
4102 for (f = formal; f; f = f->next)
4103 if (strcmp (a->name, f->name) == 0)
4104 break;
4105
4106 if (f == NULL)
4107 {
4108 if (a->name[0] == '%')
4109 gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
4110 "are not allowed in this context at %L", where);
4111 else
4112 gfc_error ("Can't find keyword named %qs in call to %qs at %L",
4113 a->name, name, where);
4114 return false;
4115 }
4116
4117 if (f->actual != NULL)
4118 {
4119 gfc_error ("Argument %qs appears twice in call to %qs at %L",
4120 f->name, name, where);
4121 return false;
4122 }
4123
4124 f->actual = a;
4125 }
4126
4127 optional:
4128 /* At this point, all unmatched formal args must be optional. */
4129 for (f = formal; f; f = f->next)
4130 {
4131 if (f->actual == NULL && f->optional == 0)
4132 {
4133 gfc_error ("Missing actual argument %qs in call to %qs at %L",
4134 f->name, name, where);
4135 return false;
4136 }
4137 }
4138
4139 do_sort:
4140 /* Using the formal argument list, string the actual argument list
4141 together in a way that corresponds with the formal list. */
4142 actual = NULL;
4143
4144 for (f = formal; f; f = f->next)
4145 {
4146 if (f->actual && f->actual->label != NULL && f->ts.type)
4147 {
4148 gfc_error ("ALTERNATE RETURN not permitted at %L", where);
4149 return false;
4150 }
4151
4152 if (f->actual == NULL)
4153 {
4154 a = gfc_get_actual_arglist ();
4155 a->missing_arg_type = f->ts.type;
4156 }
4157 else
4158 a = f->actual;
4159
4160 if (actual == NULL)
4161 *ap = a;
4162 else
4163 actual->next = a;
4164
4165 actual = a;
4166 }
4167 actual->next = NULL; /* End the sorted argument list. */
4168
4169 return true;
4170 }
4171
4172
4173 /* Compare an actual argument list with an intrinsic's formal argument
4174 list. The lists are checked for agreement of type. We don't check
4175 for arrayness here. */
4176
4177 static bool
4178 check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
4179 int error_flag)
4180 {
4181 gfc_actual_arglist *actual;
4182 gfc_intrinsic_arg *formal;
4183 int i;
4184
4185 formal = sym->formal;
4186 actual = *ap;
4187
4188 i = 0;
4189 for (; formal; formal = formal->next, actual = actual->next, i++)
4190 {
4191 gfc_typespec ts;
4192
4193 if (actual->expr == NULL)
4194 continue;
4195
4196 ts = formal->ts;
4197
4198 /* A kind of 0 means we don't check for kind. */
4199 if (ts.kind == 0)
4200 ts.kind = actual->expr->ts.kind;
4201
4202 if (!gfc_compare_types (&ts, &actual->expr->ts))
4203 {
4204 if (error_flag)
4205 gfc_error ("Type of argument %qs in call to %qs at %L should "
4206 "be %s, not %s", gfc_current_intrinsic_arg[i]->name,
4207 gfc_current_intrinsic, &actual->expr->where,
4208 gfc_typename (&formal->ts),
4209 gfc_typename (&actual->expr->ts));
4210 return false;
4211 }
4212
4213 /* If the formal argument is INTENT([IN]OUT), check for definability. */
4214 if (formal->intent == INTENT_INOUT || formal->intent == INTENT_OUT)
4215 {
4216 const char* context = (error_flag
4217 ? _("actual argument to INTENT = OUT/INOUT")
4218 : NULL);
4219
4220 /* No pointer arguments for intrinsics. */
4221 if (!gfc_check_vardef_context (actual->expr, false, false, false, context))
4222 return false;
4223 }
4224 }
4225
4226 return true;
4227 }
4228
4229
4230 /* Given a pointer to an intrinsic symbol and an expression node that
4231 represent the function call to that subroutine, figure out the type
4232 of the result. This may involve calling a resolution subroutine. */
4233
4234 static void
4235 resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
4236 {
4237 gfc_expr *a1, *a2, *a3, *a4, *a5;
4238 gfc_actual_arglist *arg;
4239
4240 if (specific->resolve.f1 == NULL)
4241 {
4242 if (e->value.function.name == NULL)
4243 e->value.function.name = specific->lib_name;
4244
4245 if (e->ts.type == BT_UNKNOWN)
4246 e->ts = specific->ts;
4247 return;
4248 }
4249
4250 arg = e->value.function.actual;
4251
4252 /* Special case hacks for MIN and MAX. */
4253 if (specific->resolve.f1m == gfc_resolve_max
4254 || specific->resolve.f1m == gfc_resolve_min)
4255 {
4256 (*specific->resolve.f1m) (e, arg);
4257 return;
4258 }
4259
4260 if (arg == NULL)
4261 {
4262 (*specific->resolve.f0) (e);
4263 return;
4264 }
4265
4266 a1 = arg->expr;
4267 arg = arg->next;
4268
4269 if (arg == NULL)
4270 {
4271 (*specific->resolve.f1) (e, a1);
4272 return;
4273 }
4274
4275 a2 = arg->expr;
4276 arg = arg->next;
4277
4278 if (arg == NULL)
4279 {
4280 (*specific->resolve.f2) (e, a1, a2);
4281 return;
4282 }
4283
4284 a3 = arg->expr;
4285 arg = arg->next;
4286
4287 if (arg == NULL)
4288 {
4289 (*specific->resolve.f3) (e, a1, a2, a3);
4290 return;
4291 }
4292
4293 a4 = arg->expr;
4294 arg = arg->next;
4295
4296 if (arg == NULL)
4297 {
4298 (*specific->resolve.f4) (e, a1, a2, a3, a4);
4299 return;
4300 }
4301
4302 a5 = arg->expr;
4303 arg = arg->next;
4304
4305 if (arg == NULL)
4306 {
4307 (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
4308 return;
4309 }
4310
4311 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
4312 }
4313
4314
4315 /* Given an intrinsic symbol node and an expression node, call the
4316 simplification function (if there is one), perhaps replacing the
4317 expression with something simpler. We return false on an error
4318 of the simplification, true if the simplification worked, even
4319 if nothing has changed in the expression itself. */
4320
4321 static bool
4322 do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
4323 {
4324 gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
4325 gfc_actual_arglist *arg;
4326
4327 /* Max and min require special handling due to the variable number
4328 of args. */
4329 if (specific->simplify.f1 == gfc_simplify_min)
4330 {
4331 result = gfc_simplify_min (e);
4332 goto finish;
4333 }
4334
4335 if (specific->simplify.f1 == gfc_simplify_max)
4336 {
4337 result = gfc_simplify_max (e);
4338 goto finish;
4339 }
4340
4341 /* Some math intrinsics need to wrap the original expression. */
4342 if (specific->simplify.f1 == gfc_simplify_trigd
4343 || specific->simplify.f1 == gfc_simplify_atrigd
4344 || specific->simplify.f1 == gfc_simplify_cotan)
4345 {
4346 result = (*specific->simplify.f1) (e);
4347 goto finish;
4348 }
4349
4350 if (specific->simplify.f1 == NULL)
4351 {
4352 result = NULL;
4353 goto finish;
4354 }
4355
4356 arg = e->value.function.actual;
4357
4358 if (arg == NULL)
4359 {
4360 result = (*specific->simplify.f0) ();
4361 goto finish;
4362 }
4363
4364 a1 = arg->expr;
4365 arg = arg->next;
4366
4367 if (specific->simplify.cc == gfc_convert_constant
4368 || specific->simplify.cc == gfc_convert_char_constant)
4369 {
4370 result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind);
4371 goto finish;
4372 }
4373
4374 if (arg == NULL)
4375 result = (*specific->simplify.f1) (a1);
4376 else
4377 {
4378 a2 = arg->expr;
4379 arg = arg->next;
4380
4381 if (arg == NULL)
4382 result = (*specific->simplify.f2) (a1, a2);
4383 else
4384 {
4385 a3 = arg->expr;
4386 arg = arg->next;
4387
4388 if (arg == NULL)
4389 result = (*specific->simplify.f3) (a1, a2, a3);
4390 else
4391 {
4392 a4 = arg->expr;
4393 arg = arg->next;
4394
4395 if (arg == NULL)
4396 result = (*specific->simplify.f4) (a1, a2, a3, a4);
4397 else
4398 {
4399 a5 = arg->expr;
4400 arg = arg->next;
4401
4402 if (arg == NULL)
4403 result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
4404 else
4405 gfc_internal_error
4406 ("do_simplify(): Too many args for intrinsic");
4407 }
4408 }
4409 }
4410 }
4411
4412 finish:
4413 if (result == &gfc_bad_expr)
4414 return false;
4415
4416 if (result == NULL)
4417 resolve_intrinsic (specific, e); /* Must call at run-time */
4418 else
4419 {
4420 result->where = e->where;
4421 gfc_replace_expr (e, result);
4422 }
4423
4424 return true;
4425 }
4426
4427
4428 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
4429 error messages. This subroutine returns false if a subroutine
4430 has more than MAX_INTRINSIC_ARGS, in which case the actual argument
4431 list cannot match any intrinsic. */
4432
4433 static void
4434 init_arglist (gfc_intrinsic_sym *isym)
4435 {
4436 gfc_intrinsic_arg *formal;
4437 int i;
4438
4439 gfc_current_intrinsic = isym->name;
4440
4441 i = 0;
4442 for (formal = isym->formal; formal; formal = formal->next)
4443 {
4444 if (i >= MAX_INTRINSIC_ARGS)
4445 gfc_internal_error ("init_arglist(): too many arguments");
4446 gfc_current_intrinsic_arg[i++] = formal;
4447 }
4448 }
4449
4450
4451 /* Given a pointer to an intrinsic symbol and an expression consisting
4452 of a function call, see if the function call is consistent with the
4453 intrinsic's formal argument list. Return true if the expression
4454 and intrinsic match, false otherwise. */
4455
4456 static bool
4457 check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
4458 {
4459 gfc_actual_arglist *arg, **ap;
4460 bool t;
4461
4462 ap = &expr->value.function.actual;
4463
4464 init_arglist (specific);
4465
4466 /* Don't attempt to sort the argument list for min or max. */
4467 if (specific->check.f1m == gfc_check_min_max
4468 || specific->check.f1m == gfc_check_min_max_integer
4469 || specific->check.f1m == gfc_check_min_max_real
4470 || specific->check.f1m == gfc_check_min_max_double)
4471 {
4472 if (!do_ts29113_check (specific, *ap))
4473 return false;
4474 return (*specific->check.f1m) (*ap);
4475 }
4476
4477 if (!sort_actual (specific->name, ap, specific->formal, &expr->where))
4478 return false;
4479
4480 if (!do_ts29113_check (specific, *ap))
4481 return false;
4482
4483 if (specific->check.f3ml == gfc_check_minloc_maxloc)
4484 /* This is special because we might have to reorder the argument list. */
4485 t = gfc_check_minloc_maxloc (*ap);
4486 else if (specific->check.f3red == gfc_check_minval_maxval)
4487 /* This is also special because we also might have to reorder the
4488 argument list. */
4489 t = gfc_check_minval_maxval (*ap);
4490 else if (specific->check.f3red == gfc_check_product_sum)
4491 /* Same here. The difference to the previous case is that we allow a
4492 general numeric type. */
4493 t = gfc_check_product_sum (*ap);
4494 else if (specific->check.f3red == gfc_check_transf_bit_intrins)
4495 /* Same as for PRODUCT and SUM, but different checks. */
4496 t = gfc_check_transf_bit_intrins (*ap);
4497 else
4498 {
4499 if (specific->check.f1 == NULL)
4500 {
4501 t = check_arglist (ap, specific, error_flag);
4502 if (t)
4503 expr->ts = specific->ts;
4504 }
4505 else
4506 t = do_check (specific, *ap);
4507 }
4508
4509 /* Check conformance of elemental intrinsics. */
4510 if (t && specific->elemental)
4511 {
4512 int n = 0;
4513 gfc_expr *first_expr;
4514 arg = expr->value.function.actual;
4515
4516 /* There is no elemental intrinsic without arguments. */
4517 gcc_assert(arg != NULL);
4518 first_expr = arg->expr;
4519
4520 for ( ; arg && arg->expr; arg = arg->next, n++)
4521 if (!gfc_check_conformance (first_expr, arg->expr,
4522 "arguments '%s' and '%s' for "
4523 "intrinsic '%s'",
4524 gfc_current_intrinsic_arg[0]->name,
4525 gfc_current_intrinsic_arg[n]->name,
4526 gfc_current_intrinsic))
4527 return false;
4528 }
4529
4530 if (!t)
4531 remove_nullargs (ap);
4532
4533 return t;
4534 }
4535
4536
4537 /* Check whether an intrinsic belongs to whatever standard the user
4538 has chosen, taking also into account -fall-intrinsics. Here, no
4539 warning/error is emitted; but if symstd is not NULL, it is pointed to a
4540 textual representation of the symbols standard status (like
4541 "new in Fortran 2008", "a GNU extension" or "obsolescent in Fortran 95") that
4542 can be used to construct a detailed warning/error message in case of
4543 a false. */
4544
4545 bool
4546 gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym,
4547 const char** symstd, bool silent, locus where)
4548 {
4549 const char* symstd_msg;
4550
4551 /* For -fall-intrinsics, just succeed. */
4552 if (flag_all_intrinsics)
4553 return true;
4554
4555 /* Find the symbol's standard message for later usage. */
4556 switch (isym->standard)
4557 {
4558 case GFC_STD_F77:
4559 symstd_msg = "available since Fortran 77";
4560 break;
4561
4562 case GFC_STD_F95_OBS:
4563 symstd_msg = "obsolescent in Fortran 95";
4564 break;
4565
4566 case GFC_STD_F95_DEL:
4567 symstd_msg = "deleted in Fortran 95";
4568 break;
4569
4570 case GFC_STD_F95:
4571 symstd_msg = "new in Fortran 95";
4572 break;
4573
4574 case GFC_STD_F2003:
4575 symstd_msg = "new in Fortran 2003";
4576 break;
4577
4578 case GFC_STD_F2008:
4579 symstd_msg = "new in Fortran 2008";
4580 break;
4581
4582 case GFC_STD_F2008_TS:
4583 symstd_msg = "new in TS 29113/TS 18508";
4584 break;
4585
4586 case GFC_STD_GNU:
4587 symstd_msg = "a GNU Fortran extension";
4588 break;
4589
4590 case GFC_STD_LEGACY:
4591 symstd_msg = "for backward compatibility";
4592 break;
4593
4594 default:
4595 gfc_internal_error ("Invalid standard code on intrinsic %qs (%d)",
4596 isym->name, isym->standard);
4597 }
4598
4599 /* If warning about the standard, warn and succeed. */
4600 if (gfc_option.warn_std & isym->standard)
4601 {
4602 /* Do only print a warning if not a GNU extension. */
4603 if (!silent && isym->standard != GFC_STD_GNU)
4604 gfc_warning (0, "Intrinsic %qs (is %s) is used at %L",
4605 isym->name, _(symstd_msg), &where);
4606
4607 return true;
4608 }
4609
4610 /* If allowing the symbol's standard, succeed, too. */
4611 if (gfc_option.allow_std & isym->standard)
4612 return true;
4613
4614 /* Otherwise, fail. */
4615 if (symstd)
4616 *symstd = _(symstd_msg);
4617 return false;
4618 }
4619
4620
4621 /* See if a function call corresponds to an intrinsic function call.
4622 We return:
4623
4624 MATCH_YES if the call corresponds to an intrinsic, simplification
4625 is done if possible.
4626
4627 MATCH_NO if the call does not correspond to an intrinsic
4628
4629 MATCH_ERROR if the call corresponds to an intrinsic but there was an
4630 error during the simplification process.
4631
4632 The error_flag parameter enables an error reporting. */
4633
4634 match
4635 gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
4636 {
4637 gfc_intrinsic_sym *isym, *specific;
4638 gfc_actual_arglist *actual;
4639 const char *name;
4640 int flag;
4641
4642 if (expr->value.function.isym != NULL)
4643 return (!do_simplify(expr->value.function.isym, expr))
4644 ? MATCH_ERROR : MATCH_YES;
4645
4646 if (!error_flag)
4647 gfc_push_suppress_errors ();
4648 flag = 0;
4649
4650 for (actual = expr->value.function.actual; actual; actual = actual->next)
4651 if (actual->expr != NULL)
4652 flag |= (actual->expr->ts.type != BT_INTEGER
4653 && actual->expr->ts.type != BT_CHARACTER);
4654
4655 name = expr->symtree->n.sym->name;
4656
4657 if (expr->symtree->n.sym->intmod_sym_id)
4658 {
4659 gfc_isym_id id = gfc_isym_id_by_intmod_sym (expr->symtree->n.sym);
4660 isym = specific = gfc_intrinsic_function_by_id (id);
4661 }
4662 else
4663 isym = specific = gfc_find_function (name);
4664
4665 if (isym == NULL)
4666 {
4667 if (!error_flag)
4668 gfc_pop_suppress_errors ();
4669 return MATCH_NO;
4670 }
4671
4672 if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
4673 || isym->id == GFC_ISYM_CMPLX)
4674 && gfc_init_expr_flag
4675 && !gfc_notify_std (GFC_STD_F2003, "Function %qs as initialization "
4676 "expression at %L", name, &expr->where))
4677 {
4678 if (!error_flag)
4679 gfc_pop_suppress_errors ();
4680 return MATCH_ERROR;
4681 }
4682
4683 /* F95, 7.1.6.1: Only transformational functions REPEAT, RESHAPE,
4684 SELECTED_INT_KIND, SELECTED_REAL_KIND, TRANSFER, and TRIM are allowed in
4685 initialization expressions. */
4686
4687 if (gfc_init_expr_flag && isym->transformational)
4688 {
4689 gfc_isym_id id = isym->id;
4690 if (id != GFC_ISYM_REPEAT && id != GFC_ISYM_RESHAPE
4691 && id != GFC_ISYM_SI_KIND && id != GFC_ISYM_SR_KIND
4692 && id != GFC_ISYM_TRANSFER && id != GFC_ISYM_TRIM
4693 && !gfc_notify_std (GFC_STD_F2003, "Transformational function %qs "
4694 "at %L is invalid in an initialization "
4695 "expression", name, &expr->where))
4696 {
4697 if (!error_flag)
4698 gfc_pop_suppress_errors ();
4699
4700 return MATCH_ERROR;
4701 }
4702 }
4703
4704 gfc_current_intrinsic_where = &expr->where;
4705
4706 /* Bypass the generic list for min, max and ISO_C_Binding's c_loc. */
4707 if (isym->check.f1m == gfc_check_min_max)
4708 {
4709 init_arglist (isym);
4710
4711 if (isym->check.f1m(expr->value.function.actual))
4712 goto got_specific;
4713
4714 if (!error_flag)
4715 gfc_pop_suppress_errors ();
4716 return MATCH_NO;
4717 }
4718
4719 /* If the function is generic, check all of its specific
4720 incarnations. If the generic name is also a specific, we check
4721 that name last, so that any error message will correspond to the
4722 specific. */
4723 gfc_push_suppress_errors ();
4724
4725 if (isym->generic)
4726 {
4727 for (specific = isym->specific_head; specific;
4728 specific = specific->next)
4729 {
4730 if (specific == isym)
4731 continue;
4732 if (check_specific (specific, expr, 0))
4733 {
4734 gfc_pop_suppress_errors ();
4735 goto got_specific;
4736 }
4737 }
4738 }
4739
4740 gfc_pop_suppress_errors ();
4741
4742 if (!check_specific (isym, expr, error_flag))
4743 {
4744 if (!error_flag)
4745 gfc_pop_suppress_errors ();
4746 return MATCH_NO;
4747 }
4748
4749 specific = isym;
4750
4751 got_specific:
4752 expr->value.function.isym = specific;
4753 if (!expr->symtree->n.sym->module)
4754 gfc_intrinsic_symbol (expr->symtree->n.sym);
4755
4756 if (!error_flag)
4757 gfc_pop_suppress_errors ();
4758
4759 if (!do_simplify (specific, expr))
4760 return MATCH_ERROR;
4761
4762 /* F95, 7.1.6.1, Initialization expressions
4763 (4) An elemental intrinsic function reference of type integer or
4764 character where each argument is an initialization expression
4765 of type integer or character
4766
4767 F2003, 7.1.7 Initialization expression
4768 (4) A reference to an elemental standard intrinsic function,
4769 where each argument is an initialization expression */
4770
4771 if (gfc_init_expr_flag && isym->elemental && flag
4772 && !gfc_notify_std (GFC_STD_F2003, "Elemental function as "
4773 "initialization expression with non-integer/non-"
4774 "character arguments at %L", &expr->where))
4775 return MATCH_ERROR;
4776
4777 return MATCH_YES;
4778 }
4779
4780
4781 /* See if a CALL statement corresponds to an intrinsic subroutine.
4782 Returns MATCH_YES if the subroutine corresponds to an intrinsic,
4783 MATCH_NO if not, and MATCH_ERROR if there was an error (but did
4784 correspond). */
4785
4786 match
4787 gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
4788 {
4789 gfc_intrinsic_sym *isym;
4790 const char *name;
4791
4792 name = c->symtree->n.sym->name;
4793
4794 if (c->symtree->n.sym->intmod_sym_id)
4795 {
4796 gfc_isym_id id;
4797 id = gfc_isym_id_by_intmod_sym (c->symtree->n.sym);
4798 isym = gfc_intrinsic_subroutine_by_id (id);
4799 }
4800 else
4801 isym = gfc_find_subroutine (name);
4802 if (isym == NULL)
4803 return MATCH_NO;
4804
4805 if (!error_flag)
4806 gfc_push_suppress_errors ();
4807
4808 init_arglist (isym);
4809
4810 if (!isym->vararg && !sort_actual (name, &c->ext.actual, isym->formal, &c->loc))
4811 goto fail;
4812
4813 if (!do_ts29113_check (isym, c->ext.actual))
4814 goto fail;
4815
4816 if (isym->check.f1 != NULL)
4817 {
4818 if (!do_check (isym, c->ext.actual))
4819 goto fail;
4820 }
4821 else
4822 {
4823 if (!check_arglist (&c->ext.actual, isym, 1))
4824 goto fail;
4825 }
4826
4827 /* The subroutine corresponds to an intrinsic. Allow errors to be
4828 seen at this point. */
4829 if (!error_flag)
4830 gfc_pop_suppress_errors ();
4831
4832 c->resolved_isym = isym;
4833 if (isym->resolve.s1 != NULL)
4834 isym->resolve.s1 (c);
4835 else
4836 {
4837 c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
4838 c->resolved_sym->attr.elemental = isym->elemental;
4839 }
4840
4841 if (gfc_do_concurrent_flag && !isym->pure)
4842 {
4843 gfc_error ("Subroutine call to intrinsic %qs in DO CONCURRENT "
4844 "block at %L is not PURE", name, &c->loc);
4845 return MATCH_ERROR;
4846 }
4847
4848 if (!isym->pure && gfc_pure (NULL))
4849 {
4850 gfc_error ("Subroutine call to intrinsic %qs at %L is not PURE", name,
4851 &c->loc);
4852 return MATCH_ERROR;
4853 }
4854
4855 if (!isym->pure)
4856 gfc_unset_implicit_pure (NULL);
4857
4858 c->resolved_sym->attr.noreturn = isym->noreturn;
4859
4860 return MATCH_YES;
4861
4862 fail:
4863 if (!error_flag)
4864 gfc_pop_suppress_errors ();
4865 return MATCH_NO;
4866 }
4867
4868
4869 /* Call gfc_convert_type() with warning enabled. */
4870
4871 bool
4872 gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
4873 {
4874 return gfc_convert_type_warn (expr, ts, eflag, 1);
4875 }
4876
4877
4878 /* Try to convert an expression (in place) from one type to another.
4879 'eflag' controls the behavior on error.
4880
4881 The possible values are:
4882
4883 1 Generate a gfc_error()
4884 2 Generate a gfc_internal_error().
4885
4886 'wflag' controls the warning related to conversion. */
4887
4888 bool
4889 gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
4890 {
4891 gfc_intrinsic_sym *sym;
4892 gfc_typespec from_ts;
4893 locus old_where;
4894 gfc_expr *new_expr;
4895 int rank;
4896 mpz_t *shape;
4897
4898 from_ts = expr->ts; /* expr->ts gets clobbered */
4899
4900 if (ts->type == BT_UNKNOWN)
4901 goto bad;
4902
4903 /* NULL and zero size arrays get their type here. */
4904 if (expr->expr_type == EXPR_NULL
4905 || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL))
4906 {
4907 /* Sometimes the RHS acquire the type. */
4908 expr->ts = *ts;
4909 return true;
4910 }
4911
4912 if (expr->ts.type == BT_UNKNOWN)
4913 goto bad;
4914
4915 if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
4916 && gfc_compare_types (&expr->ts, ts))
4917 return true;
4918
4919 sym = find_conv (&expr->ts, ts);
4920 if (sym == NULL)
4921 goto bad;
4922
4923 /* At this point, a conversion is necessary. A warning may be needed. */
4924 if ((gfc_option.warn_std & sym->standard) != 0)
4925 {
4926 gfc_warning_now (0, "Extension: Conversion from %s to %s at %L",
4927 gfc_typename (&from_ts), gfc_typename (ts),
4928 &expr->where);
4929 }
4930 else if (wflag)
4931 {
4932 if (flag_range_check && expr->expr_type == EXPR_CONSTANT
4933 && from_ts.type == ts->type)
4934 {
4935 /* Do nothing. Constants of the same type are range-checked
4936 elsewhere. If a value too large for the target type is
4937 assigned, an error is generated. Not checking here avoids
4938 duplications of warnings/errors.
4939 If range checking was disabled, but -Wconversion enabled,
4940 a non range checked warning is generated below. */
4941 }
4942 else if (from_ts.type == BT_LOGICAL || ts->type == BT_LOGICAL)
4943 {
4944 /* Do nothing. This block exists only to simplify the other
4945 else-if expressions.
4946 LOGICAL <> LOGICAL no warning, independent of kind values
4947 LOGICAL <> INTEGER extension, warned elsewhere
4948 LOGICAL <> REAL invalid, error generated elsewhere
4949 LOGICAL <> COMPLEX invalid, error generated elsewhere */
4950 }
4951 else if (from_ts.type == ts->type
4952 || (from_ts.type == BT_INTEGER && ts->type == BT_REAL)
4953 || (from_ts.type == BT_INTEGER && ts->type == BT_COMPLEX)
4954 || (from_ts.type == BT_REAL && ts->type == BT_COMPLEX))
4955 {
4956 /* Larger kinds can hold values of smaller kinds without problems.
4957 Hence, only warn if target kind is smaller than the source
4958 kind - or if -Wconversion-extra is specified. */
4959 if (expr->expr_type != EXPR_CONSTANT)
4960 {
4961 if (warn_conversion && from_ts.kind > ts->kind)
4962 gfc_warning_now (OPT_Wconversion, "Possible change of value in "
4963 "conversion from %s to %s at %L",
4964 gfc_typename (&from_ts), gfc_typename (ts),
4965 &expr->where);
4966 else if (warn_conversion_extra)
4967 gfc_warning_now (OPT_Wconversion_extra, "Conversion from %s to %s "
4968 "at %L", gfc_typename (&from_ts),
4969 gfc_typename (ts), &expr->where);
4970 }
4971 }
4972 else if ((from_ts.type == BT_REAL && ts->type == BT_INTEGER)
4973 || (from_ts.type == BT_COMPLEX && ts->type == BT_INTEGER)
4974 || (from_ts.type == BT_COMPLEX && ts->type == BT_REAL))
4975 {
4976 /* Conversion from REAL/COMPLEX to INTEGER or COMPLEX to REAL
4977 usually comes with a loss of information, regardless of kinds. */
4978 if (warn_conversion && expr->expr_type != EXPR_CONSTANT)
4979 gfc_warning_now (OPT_Wconversion, "Possible change of value in "
4980 "conversion from %s to %s at %L",
4981 gfc_typename (&from_ts), gfc_typename (ts),
4982 &expr->where);
4983 }
4984 else if (from_ts.type == BT_HOLLERITH || ts->type == BT_HOLLERITH)
4985 {
4986 /* If HOLLERITH is involved, all bets are off. */
4987 if (warn_conversion)
4988 gfc_warning_now (OPT_Wconversion, "Conversion from %s to %s at %L",
4989 gfc_typename (&from_ts), gfc_typename (ts),
4990 &expr->where);
4991 }
4992 else
4993 gcc_unreachable ();
4994 }
4995
4996 /* Insert a pre-resolved function call to the right function. */
4997 old_where = expr->where;
4998 rank = expr->rank;
4999 shape = expr->shape;
5000
5001 new_expr = gfc_get_expr ();
5002 *new_expr = *expr;
5003
5004 new_expr = gfc_build_conversion (new_expr);
5005 new_expr->value.function.name = sym->lib_name;
5006 new_expr->value.function.isym = sym;
5007 new_expr->where = old_where;
5008 new_expr->ts = *ts;
5009 new_expr->rank = rank;
5010 new_expr->shape = gfc_copy_shape (shape, rank);
5011
5012 gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
5013 new_expr->symtree->n.sym->result = new_expr->symtree->n.sym;
5014 new_expr->symtree->n.sym->ts.type = ts->type;
5015 new_expr->symtree->n.sym->ts.kind = ts->kind;
5016 new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5017 new_expr->symtree->n.sym->attr.function = 1;
5018 new_expr->symtree->n.sym->attr.elemental = 1;
5019 new_expr->symtree->n.sym->attr.pure = 1;
5020 new_expr->symtree->n.sym->attr.referenced = 1;
5021 gfc_intrinsic_symbol(new_expr->symtree->n.sym);
5022 gfc_commit_symbol (new_expr->symtree->n.sym);
5023
5024 *expr = *new_expr;
5025
5026 free (new_expr);
5027 expr->ts = *ts;
5028
5029 if (gfc_is_constant_expr (expr->value.function.actual->expr)
5030 && !do_simplify (sym, expr))
5031 {
5032
5033 if (eflag == 2)
5034 goto bad;
5035 return false; /* Error already generated in do_simplify() */
5036 }
5037
5038 return true;
5039
5040 bad:
5041 if (eflag == 1)
5042 {
5043 gfc_error ("Can't convert %s to %s at %L",
5044 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
5045 return false;
5046 }
5047
5048 gfc_internal_error ("Can't convert %qs to %qs at %L",
5049 gfc_typename (&from_ts), gfc_typename (ts),
5050 &expr->where);
5051 /* Not reached */
5052 }
5053
5054
5055 bool
5056 gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
5057 {
5058 gfc_intrinsic_sym *sym;
5059 locus old_where;
5060 gfc_expr *new_expr;
5061 int rank;
5062 mpz_t *shape;
5063
5064 gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER);
5065
5066 sym = find_char_conv (&expr->ts, ts);
5067 gcc_assert (sym);
5068
5069 /* Insert a pre-resolved function call to the right function. */
5070 old_where = expr->where;
5071 rank = expr->rank;
5072 shape = expr->shape;
5073
5074 new_expr = gfc_get_expr ();
5075 *new_expr = *expr;
5076
5077 new_expr = gfc_build_conversion (new_expr);
5078 new_expr->value.function.name = sym->lib_name;
5079 new_expr->value.function.isym = sym;
5080 new_expr->where = old_where;
5081 new_expr->ts = *ts;
5082 new_expr->rank = rank;
5083 new_expr->shape = gfc_copy_shape (shape, rank);
5084
5085 gfc_get_ha_sym_tree (sym->name, &new_expr->symtree);
5086 new_expr->symtree->n.sym->ts.type = ts->type;
5087 new_expr->symtree->n.sym->ts.kind = ts->kind;
5088 new_expr->symtree->n.sym->attr.flavor = FL_PROCEDURE;
5089 new_expr->symtree->n.sym->attr.function = 1;
5090 new_expr->symtree->n.sym->attr.elemental = 1;
5091 new_expr->symtree->n.sym->attr.referenced = 1;
5092 gfc_intrinsic_symbol(new_expr->symtree->n.sym);
5093 gfc_commit_symbol (new_expr->symtree->n.sym);
5094
5095 *expr = *new_expr;
5096
5097 free (new_expr);
5098 expr->ts = *ts;
5099
5100 if (gfc_is_constant_expr (expr->value.function.actual->expr)
5101 && !do_simplify (sym, expr))
5102 {
5103 /* Error already generated in do_simplify() */
5104 return false;
5105 }
5106
5107 return true;
5108 }
5109
5110
5111 /* Check if the passed name is name of an intrinsic (taking into account the
5112 current -std=* and -fall-intrinsic settings). If it is, see if we should
5113 warn about this as a user-procedure having the same name as an intrinsic
5114 (-Wintrinsic-shadow enabled) and do so if we should. */
5115
5116 void
5117 gfc_warn_intrinsic_shadow (const gfc_symbol* sym, bool in_module, bool func)
5118 {
5119 gfc_intrinsic_sym* isym;
5120
5121 /* If the warning is disabled, do nothing at all. */
5122 if (!warn_intrinsic_shadow)
5123 return;
5124
5125 /* Try to find an intrinsic of the same name. */
5126 if (func)
5127 isym = gfc_find_function (sym->name);
5128 else
5129 isym = gfc_find_subroutine (sym->name);
5130
5131 /* If no intrinsic was found with this name or it's not included in the
5132 selected standard, everything's fine. */
5133 if (!isym || !gfc_check_intrinsic_standard (isym, NULL, true,
5134 sym->declared_at))
5135 return;
5136
5137 /* Emit the warning. */
5138 if (in_module || sym->ns->proc_name)
5139 gfc_warning (OPT_Wintrinsic_shadow,
5140 "%qs declared at %L may shadow the intrinsic of the same"
5141 " name. In order to call the intrinsic, explicit INTRINSIC"
5142 " declarations may be required.",
5143 sym->name, &sym->declared_at);
5144 else
5145 gfc_warning (OPT_Wintrinsic_shadow,
5146 "%qs declared at %L is also the name of an intrinsic. It can"
5147 " only be called via an explicit interface or if declared"
5148 " EXTERNAL.", sym->name, &sym->declared_at);
5149 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org