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