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