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