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