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