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