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