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