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