]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/intrinsic.c
projects / thirdparty / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
arith.c: Change copyright header to refer to version 3 of the GNU General Public...
[thirdparty/gcc.git] / gcc / fortran / intrinsic.c
1 /* Build up a list of intrinsic subroutines and functions for the
2 name-resolution stage.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007
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 NULL, 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_1 ("achar", GFC_ISYM_ACHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
950 gfc_check_achar, gfc_simplify_achar, gfc_resolve_achar,
951 i, BT_INTEGER, di, REQUIRED);
952
953 make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);
954
955 add_sym_1 ("acos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
956 gfc_check_fn_r, gfc_simplify_acos, gfc_resolve_acos,
957 x, BT_REAL, dr, REQUIRED);
958
959 add_sym_1 ("dacos", GFC_ISYM_ACOS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
960 NULL, gfc_simplify_acos, gfc_resolve_acos,
961 x, BT_REAL, dd, REQUIRED);
962
963 make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);
964
965 add_sym_1 ("acosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_GNU,
966 gfc_check_fn_r, gfc_simplify_acosh, gfc_resolve_acosh,
967 x, BT_REAL, dr, REQUIRED);
968
969 add_sym_1 ("dacosh", GFC_ISYM_ACOSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
970 NULL, gfc_simplify_acosh, gfc_resolve_acosh,
971 x, BT_REAL, dd, REQUIRED);
972
973 make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_GNU);
974
975 add_sym_1 ("adjustl", GFC_ISYM_ADJUSTL, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
976 NULL, gfc_simplify_adjustl, NULL,
977 stg, BT_CHARACTER, dc, REQUIRED);
978
979 make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);
980
981 add_sym_1 ("adjustr", GFC_ISYM_ADJUSTR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
982 NULL, gfc_simplify_adjustr, NULL,
983 stg, BT_CHARACTER, dc, REQUIRED);
984
985 make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);
986
987 add_sym_1 ("aimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
988 gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
989 z, BT_COMPLEX, dz, REQUIRED);
990
991 make_alias ("imag", GFC_STD_GNU);
992 make_alias ("imagpart", GFC_STD_GNU);
993
994 add_sym_1 ("dimag", GFC_ISYM_AIMAG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
995 NULL, gfc_simplify_aimag, gfc_resolve_aimag,
996 z, BT_COMPLEX, dd, REQUIRED);
997
998 make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
999
1000 add_sym_2 ("aint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1001 gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
1002 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1003
1004 add_sym_1 ("dint", GFC_ISYM_AINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1005 NULL, gfc_simplify_dint, gfc_resolve_dint,
1006 a, BT_REAL, dd, REQUIRED);
1007
1008 make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
1009
1010 add_sym_2 ("all", GFC_ISYM_ALL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1011 gfc_check_all_any, NULL, gfc_resolve_all,
1012 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1013
1014 make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
1015
1016 add_sym_1 ("allocated", GFC_ISYM_ALLOCATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1017 gfc_check_allocated, NULL, NULL,
1018 ar, BT_UNKNOWN, 0, REQUIRED);
1019
1020 make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95);
1021
1022 add_sym_2 ("anint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1023 gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
1024 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1025
1026 add_sym_1 ("dnint", GFC_ISYM_ANINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1027 NULL, gfc_simplify_dnint, gfc_resolve_dnint,
1028 a, BT_REAL, dd, REQUIRED);
1029
1030 make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
1031
1032 add_sym_2 ("any", GFC_ISYM_ANY, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1033 gfc_check_all_any, NULL, gfc_resolve_any,
1034 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1035
1036 make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
1037
1038 add_sym_1 ("asin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1039 gfc_check_fn_r, gfc_simplify_asin, gfc_resolve_asin,
1040 x, BT_REAL, dr, REQUIRED);
1041
1042 add_sym_1 ("dasin", GFC_ISYM_ASIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1043 NULL, gfc_simplify_asin, gfc_resolve_asin,
1044 x, BT_REAL, dd, REQUIRED);
1045
1046 make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
1047
1048 add_sym_1 ("asinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_GNU,
1049 gfc_check_fn_r, gfc_simplify_asinh, gfc_resolve_asinh,
1050 x, BT_REAL, dr, REQUIRED);
1051
1052 add_sym_1 ("dasinh", GFC_ISYM_ASINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
1053 NULL, gfc_simplify_asinh, gfc_resolve_asinh,
1054 x, BT_REAL, dd, REQUIRED);
1055
1056 make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_GNU);
1057
1058 add_sym_2 ("associated", GFC_ISYM_ASSOCIATED, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl,
1059 GFC_STD_F95, gfc_check_associated, NULL, NULL,
1060 pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL);
1061
1062 make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);
1063
1064 add_sym_1 ("atan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1065 gfc_check_fn_r, gfc_simplify_atan, gfc_resolve_atan,
1066 x, BT_REAL, dr, REQUIRED);
1067
1068 add_sym_1 ("datan", GFC_ISYM_ATAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1069 NULL, gfc_simplify_atan, gfc_resolve_atan,
1070 x, BT_REAL, dd, REQUIRED);
1071
1072 make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
1073
1074 add_sym_1 ("atanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_GNU,
1075 gfc_check_fn_r, gfc_simplify_atanh, gfc_resolve_atanh,
1076 x, BT_REAL, dr, REQUIRED);
1077
1078 add_sym_1 ("datanh", GFC_ISYM_ATANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_GNU,
1079 NULL, gfc_simplify_atanh, gfc_resolve_atanh,
1080 x, BT_REAL, dd, REQUIRED);
1081
1082 make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_GNU);
1083
1084 add_sym_2 ("atan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1085 gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2,
1086 y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
1087
1088 add_sym_2 ("datan2", GFC_ISYM_ATAN2, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1089 NULL, gfc_simplify_atan2, gfc_resolve_atan2,
1090 y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
1091
1092 make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
1093
1094 /* Bessel and Neumann functions for G77 compatibility. */
1095 add_sym_1 ("besj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1096 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1097 x, BT_REAL, dr, REQUIRED);
1098
1099 add_sym_1 ("dbesj0", GFC_ISYM_J0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1100 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1101 x, BT_REAL, dd, REQUIRED);
1102
1103 make_generic ("besj0", GFC_ISYM_J0, GFC_STD_GNU);
1104
1105 add_sym_1 ("besj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1106 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1107 x, BT_REAL, dr, REQUIRED);
1108
1109 add_sym_1 ("dbesj1", GFC_ISYM_J1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1110 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1111 x, BT_REAL, dd, REQUIRED);
1112
1113 make_generic ("besj1", GFC_ISYM_J1, GFC_STD_GNU);
1114
1115 add_sym_2 ("besjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1116 gfc_check_besn, NULL, gfc_resolve_besn,
1117 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1118
1119 add_sym_2 ("dbesjn", GFC_ISYM_JN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1120 gfc_check_besn, NULL, gfc_resolve_besn,
1121 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1122
1123 make_generic ("besjn", GFC_ISYM_JN, GFC_STD_GNU);
1124
1125 add_sym_1 ("besy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1126 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1127 x, BT_REAL, dr, REQUIRED);
1128
1129 add_sym_1 ("dbesy0", GFC_ISYM_Y0, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1130 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1131 x, BT_REAL, dd, REQUIRED);
1132
1133 make_generic ("besy0", GFC_ISYM_Y0, GFC_STD_GNU);
1134
1135 add_sym_1 ("besy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1136 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1137 x, BT_REAL, dr, REQUIRED);
1138
1139 add_sym_1 ("dbesy1", GFC_ISYM_Y1, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1140 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1141 x, BT_REAL, dd, REQUIRED);
1142
1143 make_generic ("besy1", GFC_ISYM_Y1, GFC_STD_GNU);
1144
1145 add_sym_2 ("besyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1146 gfc_check_besn, NULL, gfc_resolve_besn,
1147 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1148
1149 add_sym_2 ("dbesyn", GFC_ISYM_YN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1150 gfc_check_besn, NULL, gfc_resolve_besn,
1151 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1152
1153 make_generic ("besyn", GFC_ISYM_YN, GFC_STD_GNU);
1154
1155 add_sym_1 ("bit_size", GFC_ISYM_BIT_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1156 gfc_check_i, gfc_simplify_bit_size, NULL,
1157 i, BT_INTEGER, di, REQUIRED);
1158
1159 make_generic ("bit_size", GFC_ISYM_BIT_SIZE, GFC_STD_F95);
1160
1161 add_sym_2 ("btest", GFC_ISYM_BTEST, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1162 gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest,
1163 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1164
1165 make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);
1166
1167 add_sym_2 ("ceiling", GFC_ISYM_CEILING, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1168 gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
1169 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1170
1171 make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);
1172
1173 add_sym_2 ("char", GFC_ISYM_CHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F77,
1174 gfc_check_char, gfc_simplify_char, gfc_resolve_char,
1175 i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1176
1177 make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
1178
1179 add_sym_1 ("chdir", GFC_ISYM_CHDIR, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1180 gfc_check_chdir, NULL, gfc_resolve_chdir,
1181 a, BT_CHARACTER, dc, REQUIRED);
1182
1183 make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
1184
1185 add_sym_2 ("chmod", GFC_ISYM_CHMOD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1186 gfc_check_chmod, NULL, gfc_resolve_chmod,
1187 nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
1188
1189 make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU);
1190
1191 add_sym_3 ("cmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_F77,
1192 gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
1193 x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
1194 kind, BT_INTEGER, di, OPTIONAL);
1195
1196 make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
1197
1198 add_sym_0 ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT, CLASS_INQUIRY,
1199 ACTUAL_NO, BT_INTEGER, di, GFC_STD_F2003, NULL, NULL, NULL);
1200
1201 make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
1202 GFC_STD_F2003);
1203
1204 add_sym_2 ("complex", GFC_ISYM_COMPLEX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dz, GFC_STD_GNU,
1205 gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
1206 x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
1207
1208 make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU);
1209
1210 /* Making dcmplx a specific of cmplx causes cmplx to return a double
1211 complex instead of the default complex. */
1212
1213 add_sym_2 ("dcmplx", GFC_ISYM_CMPLX, CLASS_ELEMENTAL, ACTUAL_NO, BT_COMPLEX, dd, GFC_STD_GNU,
1214 gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
1215 x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);
1216
1217 make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);
1218
1219 add_sym_1 ("conjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
1220 gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
1221 z, BT_COMPLEX, dz, REQUIRED);
1222
1223 add_sym_1 ("dconjg", GFC_ISYM_CONJG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
1224 NULL, gfc_simplify_conjg, gfc_resolve_conjg,
1225 z, BT_COMPLEX, dd, REQUIRED);
1226
1227 make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
1228
1229 add_sym_1 ("cos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1230 gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1231 x, BT_REAL, dr, REQUIRED);
1232
1233 add_sym_1 ("dcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1234 gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1235 x, BT_REAL, dd, REQUIRED);
1236
1237 add_sym_1 ("ccos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
1238 NULL, gfc_simplify_cos, gfc_resolve_cos,
1239 x, BT_COMPLEX, dz, REQUIRED);
1240
1241 add_sym_1 ("zcos", GFC_ISYM_COS, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
1242 NULL, gfc_simplify_cos, gfc_resolve_cos,
1243 x, BT_COMPLEX, dd, REQUIRED);
1244
1245 make_alias ("cdcos", GFC_STD_GNU);
1246
1247 make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);
1248
1249 add_sym_1 ("cosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1250 gfc_check_fn_r, gfc_simplify_cosh, gfc_resolve_cosh,
1251 x, BT_REAL, dr, REQUIRED);
1252
1253 add_sym_1 ("dcosh", GFC_ISYM_COSH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1254 NULL, gfc_simplify_cosh, gfc_resolve_cosh,
1255 x, BT_REAL, dd, REQUIRED);
1256
1257 make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
1258
1259 add_sym_2 ("count", GFC_ISYM_COUNT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1260 gfc_check_count, NULL, gfc_resolve_count,
1261 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1262
1263 make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
1264
1265 add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1266 gfc_check_cshift, NULL, gfc_resolve_cshift,
1267 ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1268 dm, BT_INTEGER, ii, OPTIONAL);
1269
1270 make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
1271
1272 add_sym_1 ("ctime", GFC_ISYM_CTIME, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
1273 gfc_check_ctime, NULL, gfc_resolve_ctime,
1274 tm, BT_INTEGER, di, REQUIRED);
1275
1276 make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);
1277
1278 add_sym_1 ("dble", GFC_ISYM_DBLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
1279 gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
1280 a, BT_REAL, dr, REQUIRED);
1281
1282 make_alias ("dfloat", GFC_STD_GNU);
1283
1284 make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
1285
1286 add_sym_1 ("digits", GFC_ISYM_DIGITS, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1287 gfc_check_digits, gfc_simplify_digits, NULL,
1288 x, BT_UNKNOWN, dr, REQUIRED);
1289
1290 make_generic ("digits", GFC_ISYM_DIGITS, GFC_STD_F95);
1291
1292 add_sym_2 ("dim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1293 gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
1294 x, BT_REAL, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
1295
1296 add_sym_2 ("idim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
1297 NULL, gfc_simplify_dim, gfc_resolve_dim,
1298 x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED);
1299
1300 add_sym_2 ("ddim", GFC_ISYM_DIM, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1301 NULL, gfc_simplify_dim, gfc_resolve_dim,
1302 x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED);
1303
1304 make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
1305
1306 add_sym_2 ("dot_product", GFC_ISYM_DOT_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr,
1307 GFC_STD_F95, gfc_check_dot_product, NULL, gfc_resolve_dot_product,
1308 va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
1309
1310 make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95);
1311
1312 add_sym_2 ("dprod", GFC_ISYM_DPROD,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1313 NULL, gfc_simplify_dprod, gfc_resolve_dprod,
1314 x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1315
1316 make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
1317
1318 add_sym_1 ("dreal", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1319 NULL, NULL, NULL,
1320 a, BT_COMPLEX, dd, REQUIRED);
1321
1322 make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
1323
1324 add_sym_4 ("eoshift", GFC_ISYM_EOSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1325 gfc_check_eoshift, NULL, gfc_resolve_eoshift,
1326 ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, REQUIRED,
1327 bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, OPTIONAL);
1328
1329 make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
1330
1331 add_sym_1 ("epsilon", GFC_ISYM_EPSILON, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1332 gfc_check_x, gfc_simplify_epsilon, NULL,
1333 x, BT_REAL, dr, REQUIRED);
1334
1335 make_generic ("epsilon", GFC_ISYM_EPSILON, GFC_STD_F95);
1336
1337 /* G77 compatibility for the ERF() and ERFC() functions. */
1338 add_sym_1 ("erf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1339 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1340 x, BT_REAL, dr, REQUIRED);
1341
1342 add_sym_1 ("derf", GFC_ISYM_ERF, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1343 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1344 x, BT_REAL, dd, REQUIRED);
1345
1346 make_generic ("erf", GFC_ISYM_ERF, GFC_STD_GNU);
1347
1348 add_sym_1 ("erfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1349 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1350 x, BT_REAL, dr, REQUIRED);
1351
1352 add_sym_1 ("derfc", GFC_ISYM_ERFC, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_GNU,
1353 gfc_check_fn_r, NULL, gfc_resolve_g77_math1,
1354 x, BT_REAL, dd, REQUIRED);
1355
1356 make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_GNU);
1357
1358 /* G77 compatibility */
1359 add_sym_1 ("etime", GFC_ISYM_ETIME, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
1360 gfc_check_etime, NULL, NULL,
1361 x, BT_REAL, 4, REQUIRED);
1362
1363 make_alias ("dtime", GFC_STD_GNU);
1364
1365 make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
1366
1367 add_sym_1 ("exp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1368 gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp,
1369 x, BT_REAL, dr, REQUIRED);
1370
1371 add_sym_1 ("dexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1372 NULL, gfc_simplify_exp, gfc_resolve_exp,
1373 x, BT_REAL, dd, REQUIRED);
1374
1375 add_sym_1 ("cexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
1376 NULL, gfc_simplify_exp, gfc_resolve_exp,
1377 x, BT_COMPLEX, dz, REQUIRED);
1378
1379 add_sym_1 ("zexp", GFC_ISYM_EXP, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
1380 NULL, gfc_simplify_exp, gfc_resolve_exp,
1381 x, BT_COMPLEX, dd, REQUIRED);
1382
1383 make_alias ("cdexp", GFC_STD_GNU);
1384
1385 make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77);
1386
1387 add_sym_1 ("exponent", GFC_ISYM_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1388 gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
1389 x, BT_REAL, dr, REQUIRED);
1390
1391 make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
1392
1393 add_sym_0 ("fdate", GFC_ISYM_FDATE, NO_CLASS, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_GNU,
1394 NULL, NULL, gfc_resolve_fdate);
1395
1396 make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU);
1397
1398 add_sym_2 ("floor", GFC_ISYM_FLOOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1399 gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
1400 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1401
1402 make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
1403
1404 /* G77 compatible fnum */
1405 add_sym_1 ("fnum", GFC_ISYM_FNUM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1406 gfc_check_fnum, NULL, gfc_resolve_fnum,
1407 ut, BT_INTEGER, di, REQUIRED);
1408
1409 make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
1410
1411 add_sym_1 ("fraction", GFC_ISYM_FRACTION, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1412 gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
1413 x, BT_REAL, dr, REQUIRED);
1414
1415 make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
1416
1417 add_sym_2 ("fstat", GFC_ISYM_FSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1418 gfc_check_fstat, NULL, gfc_resolve_fstat,
1419 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1420
1421 make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
1422
1423 add_sym_1 ("ftell", GFC_ISYM_FTELL, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
1424 gfc_check_ftell, NULL, gfc_resolve_ftell,
1425 ut, BT_INTEGER, di, REQUIRED);
1426
1427 make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU);
1428
1429 add_sym_2 ("fgetc", GFC_ISYM_FGETC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1430 gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
1431 ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
1432
1433 make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU);
1434
1435 add_sym_1 ("fget", GFC_ISYM_FGET, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1436 gfc_check_fgetput, NULL, gfc_resolve_fget,
1437 c, BT_CHARACTER, dc, REQUIRED);
1438
1439 make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU);
1440
1441 add_sym_2 ("fputc", GFC_ISYM_FPUTC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1442 gfc_check_fgetputc, NULL, gfc_resolve_fputc,
1443 ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
1444
1445 make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU);
1446
1447 add_sym_1 ("fput", GFC_ISYM_FPUT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1448 gfc_check_fgetput, NULL, gfc_resolve_fput,
1449 c, BT_CHARACTER, dc, REQUIRED);
1450
1451 make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
1452
1453 /* Unix IDs (g77 compatibility) */
1454 add_sym_1 ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1455 NULL, NULL, gfc_resolve_getcwd,
1456 c, BT_CHARACTER, dc, REQUIRED);
1457
1458 make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
1459
1460 add_sym_0 ("getgid", GFC_ISYM_GETGID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1461 NULL, NULL, gfc_resolve_getgid);
1462
1463 make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
1464
1465 add_sym_0 ("getpid", GFC_ISYM_GETPID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1466 NULL, NULL, gfc_resolve_getpid);
1467
1468 make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
1469
1470 add_sym_0 ("getuid", GFC_ISYM_GETUID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1471 NULL, NULL, gfc_resolve_getuid);
1472
1473 make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
1474
1475 add_sym_1 ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1476 gfc_check_hostnm, NULL, gfc_resolve_hostnm,
1477 a, BT_CHARACTER, dc, REQUIRED);
1478
1479 make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
1480
1481 add_sym_1 ("huge", GFC_ISYM_HUGE, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1482 gfc_check_huge, gfc_simplify_huge, NULL,
1483 x, BT_UNKNOWN, dr, REQUIRED);
1484
1485 make_generic ("huge", GFC_ISYM_HUGE, GFC_STD_F95);
1486
1487 add_sym_1 ("iachar", GFC_ISYM_IACHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1488 gfc_check_ichar_iachar, gfc_simplify_iachar, NULL,
1489 c, BT_CHARACTER, dc, REQUIRED);
1490
1491 make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
1492
1493 add_sym_2 ("iand", GFC_ISYM_IAND, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1494 gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1495 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1496
1497 make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
1498
1499 add_sym_2 ("and", GFC_ISYM_AND, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
1500 gfc_check_and, gfc_simplify_and, gfc_resolve_and,
1501 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1502
1503 make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
1504
1505 add_sym_0 ("iargc", GFC_ISYM_IARGC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1506 NULL, NULL, NULL);
1507
1508 make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
1509
1510 add_sym_2 ("ibclr", GFC_ISYM_IBCLR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1511 gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
1512 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1513
1514 make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
1515
1516 add_sym_3 ("ibits", GFC_ISYM_IBITS, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1517 gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
1518 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
1519 ln, BT_INTEGER, di, REQUIRED);
1520
1521 make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
1522
1523 add_sym_2 ("ibset", GFC_ISYM_IBSET, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1524 gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset,
1525 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1526
1527 make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
1528
1529 add_sym_1 ("ichar", GFC_ISYM_ICHAR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1530 gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
1531 c, BT_CHARACTER, dc, REQUIRED);
1532
1533 make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
1534
1535 add_sym_2 ("ieor", GFC_ISYM_IEOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1536 gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
1537 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1538
1539 make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
1540
1541 add_sym_2 ("xor", GFC_ISYM_XOR, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
1542 gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
1543 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1544
1545 make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU);
1546
1547 add_sym_0 ("ierrno", GFC_ISYM_IERRNO, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1548 NULL, NULL, gfc_resolve_ierrno);
1549
1550 make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
1551
1552 /* The resolution function for INDEX is called gfc_resolve_index_func
1553 because the name gfc_resolve_index is already used in resolve.c. */
1554 add_sym_3 ("index", GFC_ISYM_INDEX, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
1555 gfc_check_index, gfc_simplify_index, gfc_resolve_index_func,
1556 stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
1557 bck, BT_LOGICAL, dl, OPTIONAL);
1558
1559 make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
1560
1561 add_sym_2 ("int", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1562 gfc_check_int, gfc_simplify_int, gfc_resolve_int,
1563 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1564
1565 add_sym_1 ("ifix", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1566 NULL, gfc_simplify_ifix, NULL,
1567 a, BT_REAL, dr, REQUIRED);
1568
1569 add_sym_1 ("idint", GFC_ISYM_INT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1570 NULL, gfc_simplify_idint, NULL,
1571 a, BT_REAL, dd, REQUIRED);
1572
1573 make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
1574
1575 add_sym_1 ("int2", GFC_ISYM_INT2, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1576 gfc_check_intconv, gfc_simplify_int2, gfc_resolve_int2,
1577 a, BT_REAL, dr, REQUIRED);
1578
1579 make_alias ("short", GFC_STD_GNU);
1580
1581 make_generic ("int2", GFC_ISYM_INT2, GFC_STD_GNU);
1582
1583 add_sym_1 ("int8", GFC_ISYM_INT8, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1584 gfc_check_intconv, gfc_simplify_int8, gfc_resolve_int8,
1585 a, BT_REAL, dr, REQUIRED);
1586
1587 make_generic ("int8", GFC_ISYM_INT8, GFC_STD_GNU);
1588
1589 add_sym_1 ("long", GFC_ISYM_LONG, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1590 gfc_check_intconv, gfc_simplify_long, gfc_resolve_long,
1591 a, BT_REAL, dr, REQUIRED);
1592
1593 make_generic ("long", GFC_ISYM_LONG, GFC_STD_GNU);
1594
1595 add_sym_2 ("ior", GFC_ISYM_IOR, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1596 gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
1597 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1598
1599 make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
1600
1601 add_sym_2 ("or", GFC_ISYM_OR, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
1602 gfc_check_and, gfc_simplify_or, gfc_resolve_or,
1603 i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
1604
1605 make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
1606
1607 /* The following function is for G77 compatibility. */
1608 add_sym_1 ("irand", GFC_ISYM_IRAND, NO_CLASS, ACTUAL_NO, BT_INTEGER, 4, GFC_STD_GNU,
1609 gfc_check_irand, NULL, NULL,
1610 i, BT_INTEGER, 4, OPTIONAL);
1611
1612 make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
1613
1614 add_sym_1 ("isatty", GFC_ISYM_ISATTY, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
1615 gfc_check_isatty, NULL, gfc_resolve_isatty,
1616 ut, BT_INTEGER, di, REQUIRED);
1617
1618 make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU);
1619
1620 add_sym_2 ("rshift", GFC_ISYM_RSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1621 gfc_check_ishft, NULL, gfc_resolve_rshift,
1622 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1623
1624 make_generic ("rshift", GFC_ISYM_RSHIFT, GFC_STD_GNU);
1625
1626 add_sym_2 ("lshift", GFC_ISYM_LSHIFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1627 gfc_check_ishft, NULL, gfc_resolve_lshift,
1628 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1629
1630 make_generic ("lshift", GFC_ISYM_LSHIFT, GFC_STD_GNU);
1631
1632 add_sym_2 ("ishft", GFC_ISYM_ISHFT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1633 gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
1634 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1635
1636 make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
1637
1638 add_sym_3 ("ishftc", GFC_ISYM_ISHFTC, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1639 gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
1640 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1641 sz, BT_INTEGER, di, OPTIONAL);
1642
1643 make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
1644
1645 add_sym_2 ("kill", GFC_ISYM_KILL, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1646 gfc_check_kill, NULL, gfc_resolve_kill,
1647 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1648
1649 make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
1650
1651 add_sym_1 ("kind", GFC_ISYM_KIND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1652 gfc_check_kind, gfc_simplify_kind, NULL,
1653 x, BT_REAL, dr, REQUIRED);
1654
1655 make_generic ("kind", GFC_ISYM_KIND, GFC_STD_F95);
1656
1657 add_sym_2 ("lbound", GFC_ISYM_LBOUND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1658 gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
1659 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL);
1660
1661 make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
1662
1663 add_sym_1 ("len", GFC_ISYM_LEN, CLASS_INQUIRY, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
1664 NULL, gfc_simplify_len, gfc_resolve_len,
1665 stg, BT_CHARACTER, dc, REQUIRED);
1666
1667 make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
1668
1669 add_sym_1 ("len_trim", GFC_ISYM_LEN_TRIM, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1670 NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
1671 stg, BT_CHARACTER, dc, REQUIRED);
1672
1673 make_alias ("lnblnk", GFC_STD_GNU);
1674
1675 make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
1676
1677 add_sym_2 ("lge", GFC_ISYM_LGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77,
1678 NULL, gfc_simplify_lge, NULL,
1679 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1680
1681 make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
1682
1683 add_sym_2 ("lgt", GFC_ISYM_LGT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77,
1684 NULL, gfc_simplify_lgt, NULL,
1685 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1686
1687 make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
1688
1689 add_sym_2 ("lle",GFC_ISYM_LLE, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77,
1690 NULL, gfc_simplify_lle, NULL,
1691 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1692
1693 make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
1694
1695 add_sym_2 ("llt", GFC_ISYM_LLT, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F77,
1696 NULL, gfc_simplify_llt, NULL,
1697 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1698
1699 make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
1700
1701 add_sym_2 ("link", GFC_ISYM_LINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1702 gfc_check_link, NULL, gfc_resolve_link,
1703 a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1704
1705 make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
1706
1707 add_sym_1 ("log", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1708 gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
1709 x, BT_REAL, dr, REQUIRED);
1710
1711 add_sym_1 ("alog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1712 NULL, gfc_simplify_log, gfc_resolve_log,
1713 x, BT_REAL, dr, REQUIRED);
1714
1715 add_sym_1 ("dlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1716 NULL, gfc_simplify_log, gfc_resolve_log,
1717 x, BT_REAL, dd, REQUIRED);
1718
1719 add_sym_1 ("clog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
1720 NULL, gfc_simplify_log, gfc_resolve_log,
1721 x, BT_COMPLEX, dz, REQUIRED);
1722
1723 add_sym_1 ("zlog", GFC_ISYM_LOG, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
1724 NULL, gfc_simplify_log, gfc_resolve_log,
1725 x, BT_COMPLEX, dd, REQUIRED);
1726
1727 make_alias ("cdlog", GFC_STD_GNU);
1728
1729 make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
1730
1731 add_sym_1 ("log10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1732 gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
1733 x, BT_REAL, dr, REQUIRED);
1734
1735 add_sym_1 ("alog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1736 NULL, gfc_simplify_log10, gfc_resolve_log10,
1737 x, BT_REAL, dr, REQUIRED);
1738
1739 add_sym_1 ("dlog10", GFC_ISYM_LOG10, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1740 NULL, gfc_simplify_log10, gfc_resolve_log10,
1741 x, BT_REAL, dd, REQUIRED);
1742
1743 make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
1744
1745 add_sym_2 ("logical", GFC_ISYM_LOGICAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1746 gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
1747 l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1748
1749 make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
1750
1751 add_sym_2 ("lstat", GFC_ISYM_LSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1752 gfc_check_stat, NULL, gfc_resolve_lstat,
1753 a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1754
1755 make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU);
1756
1757 add_sym_1 ("malloc", GFC_ISYM_MALLOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
1758 gfc_check_malloc, NULL, gfc_resolve_malloc, a, BT_INTEGER, di,
1759 REQUIRED);
1760
1761 make_generic ("malloc", GFC_ISYM_MALLOC, GFC_STD_GNU);
1762
1763 add_sym_2 ("matmul", GFC_ISYM_MATMUL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1764 gfc_check_matmul, NULL, gfc_resolve_matmul,
1765 ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
1766
1767 make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
1768
1769 /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1770 int(max). The max function must take at least two arguments. */
1771
1772 add_sym_1m ("max", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
1773 gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
1774 a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
1775
1776 add_sym_1m ("max0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1777 gfc_check_min_max_integer, gfc_simplify_max, NULL,
1778 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1779
1780 add_sym_1m ("amax0", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1781 gfc_check_min_max_integer, gfc_simplify_max, NULL,
1782 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1783
1784 add_sym_1m ("amax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1785 gfc_check_min_max_real, gfc_simplify_max, NULL,
1786 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1787
1788 add_sym_1m ("max1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1789 gfc_check_min_max_real, gfc_simplify_max, NULL,
1790 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1791
1792 add_sym_1m ("dmax1", GFC_ISYM_MAX, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
1793 gfc_check_min_max_double, gfc_simplify_max, NULL,
1794 a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1795
1796 make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
1797
1798 add_sym_1 ("maxexponent", GFC_ISYM_MAXEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
1799 GFC_STD_F95, gfc_check_x, gfc_simplify_maxexponent, NULL,
1800 x, BT_UNKNOWN, dr, REQUIRED);
1801
1802 make_generic ("maxexponent", GFC_ISYM_MAXEXPONENT, GFC_STD_F95);
1803
1804 add_sym_3ml ("maxloc", GFC_ISYM_MAXLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1805 gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
1806 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1807 msk, BT_LOGICAL, dl, OPTIONAL);
1808
1809 make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
1810
1811 add_sym_3red ("maxval", GFC_ISYM_MAXVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1812 gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
1813 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1814 msk, BT_LOGICAL, dl, OPTIONAL);
1815
1816 make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
1817
1818 add_sym_0 ("mclock", GFC_ISYM_MCLOCK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1819 NULL, NULL, gfc_resolve_mclock);
1820
1821 make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU);
1822
1823 add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
1824 NULL, NULL, gfc_resolve_mclock8);
1825
1826 make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU);
1827
1828 add_sym_3 ("merge", GFC_ISYM_MERGE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1829 gfc_check_merge, NULL, gfc_resolve_merge,
1830 ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
1831 msk, BT_LOGICAL, dl, REQUIRED);
1832
1833 make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
1834
1835 /* Note: amin0 is equivalent to real(min), min1 is equivalent to
1836 int(min). */
1837
1838 add_sym_1m ("min", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_UNKNOWN, 0, GFC_STD_F77,
1839 gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
1840 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1841
1842 add_sym_1m ("min0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1843 gfc_check_min_max_integer, gfc_simplify_min, NULL,
1844 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1845
1846 add_sym_1m ("amin0", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1847 gfc_check_min_max_integer, gfc_simplify_min, NULL,
1848 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1849
1850 add_sym_1m ("amin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1851 gfc_check_min_max_real, gfc_simplify_min, NULL,
1852 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1853
1854 add_sym_1m ("min1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F77,
1855 gfc_check_min_max_real, gfc_simplify_min, NULL,
1856 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1857
1858 add_sym_1m ("dmin1", GFC_ISYM_MIN, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dd, GFC_STD_F77,
1859 gfc_check_min_max_double, gfc_simplify_min, NULL,
1860 a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1861
1862 make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
1863
1864 add_sym_1 ("minexponent", GFC_ISYM_MINEXPONENT, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
1865 GFC_STD_F95, gfc_check_x, gfc_simplify_minexponent, NULL,
1866 x, BT_UNKNOWN, dr, REQUIRED);
1867
1868 make_generic ("minexponent", GFC_ISYM_MINEXPONENT, GFC_STD_F95);
1869
1870 add_sym_3ml ("minloc", GFC_ISYM_MINLOC, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1871 gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
1872 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1873 msk, BT_LOGICAL, dl, OPTIONAL);
1874
1875 make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
1876
1877 add_sym_3red ("minval", GFC_ISYM_MINVAL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1878 gfc_check_minval_maxval, NULL, gfc_resolve_minval,
1879 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1880 msk, BT_LOGICAL, dl, OPTIONAL);
1881
1882 make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
1883
1884 add_sym_2 ("mod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
1885 gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
1886 a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
1887
1888 add_sym_2 ("amod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
1889 NULL, gfc_simplify_mod, gfc_resolve_mod,
1890 a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
1891
1892 add_sym_2 ("dmod", GFC_ISYM_MOD, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
1893 NULL, gfc_simplify_mod, gfc_resolve_mod,
1894 a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
1895
1896 make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
1897
1898 add_sym_2 ("modulo", GFC_ISYM_MODULO, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, di, GFC_STD_F95,
1899 gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
1900 a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
1901
1902 make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
1903
1904 add_sym_2 ("nearest", GFC_ISYM_NEAREST, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1905 gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
1906 x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
1907
1908 make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
1909
1910 add_sym_1 ("new_line", GFC_ISYM_NEW_LINE, CLASS_INQUIRY, ACTUAL_NO, BT_CHARACTER, dc,
1911 GFC_STD_F2003, gfc_check_new_line, gfc_simplify_new_line, NULL,
1912 a, BT_CHARACTER, dc, REQUIRED);
1913
1914 make_generic ("new_line", GFC_ISYM_NEW_LINE, GFC_STD_F2003);
1915
1916 add_sym_2 ("nint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
1917 gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
1918 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1919
1920 add_sym_1 ("idnint", GFC_ISYM_NINT, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
1921 gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
1922 a, BT_REAL, dd, REQUIRED);
1923
1924 make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
1925
1926 add_sym_1 ("not", GFC_ISYM_NOT, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1927 gfc_check_i, gfc_simplify_not, gfc_resolve_not,
1928 i, BT_INTEGER, di, REQUIRED);
1929
1930 make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
1931
1932 add_sym_1 ("null", GFC_ISYM_NULL, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1933 gfc_check_null, gfc_simplify_null, NULL,
1934 mo, BT_INTEGER, di, OPTIONAL);
1935
1936 make_generic ("null", GFC_ISYM_NULL, GFC_STD_F95);
1937
1938 add_sym_3 ("pack", GFC_ISYM_PACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1939 gfc_check_pack, NULL, gfc_resolve_pack,
1940 ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
1941 v, BT_REAL, dr, OPTIONAL);
1942
1943 make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
1944
1945 add_sym_1 ("precision", GFC_ISYM_PRECISION, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1946 gfc_check_precision, gfc_simplify_precision, NULL,
1947 x, BT_UNKNOWN, 0, REQUIRED);
1948
1949 make_generic ("precision", GFC_ISYM_PRECISION, GFC_STD_F95);
1950
1951 add_sym_1 ("present", GFC_ISYM_PRESENT, CLASS_INQUIRY, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_F95,
1952 gfc_check_present, NULL, NULL,
1953 a, BT_REAL, dr, REQUIRED);
1954
1955 make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
1956
1957 add_sym_3red ("product", GFC_ISYM_PRODUCT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
1958 gfc_check_product_sum, NULL, gfc_resolve_product,
1959 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1960 msk, BT_LOGICAL, dl, OPTIONAL);
1961
1962 make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
1963
1964 add_sym_1 ("radix", GFC_ISYM_RADIX, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1965 gfc_check_radix, gfc_simplify_radix, NULL,
1966 x, BT_UNKNOWN, 0, REQUIRED);
1967
1968 make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95);
1969
1970 /* The following function is for G77 compatibility. */
1971 add_sym_1 ("rand", GFC_ISYM_RAND, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
1972 gfc_check_rand, NULL, NULL,
1973 i, BT_INTEGER, 4, OPTIONAL);
1974
1975 /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran()
1976 use slightly different shoddy multiplicative congruential PRNG. */
1977 make_alias ("ran", GFC_STD_GNU);
1978
1979 make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
1980
1981 add_sym_1 ("range", GFC_ISYM_RANGE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
1982 gfc_check_range, gfc_simplify_range, NULL,
1983 x, BT_REAL, dr, REQUIRED);
1984
1985 make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95);
1986
1987 add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1988 gfc_check_real, gfc_simplify_real, gfc_resolve_real,
1989 a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1990
1991 /* This provides compatibility with g77. */
1992 add_sym_1 ("realpart", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
1993 gfc_check_fn_c, gfc_simplify_realpart, gfc_resolve_realpart,
1994 a, BT_UNKNOWN, dr, REQUIRED);
1995
1996 add_sym_1 ("float", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
1997 gfc_check_i, gfc_simplify_float, NULL,
1998 a, BT_INTEGER, di, REQUIRED);
1999
2000 add_sym_1 ("sngl", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77,
2001 NULL, gfc_simplify_sngl, NULL,
2002 a, BT_REAL, dd, REQUIRED);
2003
2004 make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
2005
2006 add_sym_2 ("rename", GFC_ISYM_RENAME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2007 gfc_check_rename, NULL, gfc_resolve_rename,
2008 a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
2009
2010 make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
2011
2012 add_sym_2 ("repeat", GFC_ISYM_REPEAT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
2013 gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
2014 stg, BT_CHARACTER, dc, REQUIRED, ncopies, BT_INTEGER, di, REQUIRED);
2015
2016 make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
2017
2018 add_sym_4 ("reshape", GFC_ISYM_RESHAPE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2019 gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
2020 src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
2021 pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
2022
2023 make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
2024
2025 add_sym_1 ("rrspacing", GFC_ISYM_RRSPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2026 gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
2027 x, BT_REAL, dr, REQUIRED);
2028
2029 make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
2030
2031 add_sym_2 ("scale", GFC_ISYM_SCALE, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2032 gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
2033 x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
2034
2035 make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
2036
2037 add_sym_3 ("scan", GFC_ISYM_SCAN, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2038 gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
2039 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2040 bck, BT_LOGICAL, dl, OPTIONAL);
2041
2042 make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
2043
2044 /* Added for G77 compatibility garbage. */
2045 add_sym_0 ("second", GFC_ISYM_SECOND, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
2046 NULL, NULL, NULL);
2047
2048 make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
2049
2050 /* Added for G77 compatibility. */
2051 add_sym_1 ("secnds", GFC_ISYM_SECNDS, NO_CLASS, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
2052 gfc_check_secnds, NULL, gfc_resolve_secnds,
2053 x, BT_REAL, dr, REQUIRED);
2054
2055 make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
2056
2057 add_sym_1 ("selected_int_kind", GFC_ISYM_SI_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
2058 GFC_STD_F95, gfc_check_selected_int_kind,
2059 gfc_simplify_selected_int_kind, NULL, r, BT_INTEGER, di, REQUIRED);
2060
2061 make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
2062
2063 add_sym_2 ("selected_real_kind", GFC_ISYM_SR_KIND, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_INTEGER, di,
2064 GFC_STD_F95, gfc_check_selected_real_kind,
2065 gfc_simplify_selected_real_kind, NULL,
2066 p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL);
2067
2068 make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
2069
2070 add_sym_2 ("set_exponent", GFC_ISYM_SET_EXPONENT, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2071 gfc_check_set_exponent, gfc_simplify_set_exponent,
2072 gfc_resolve_set_exponent,
2073 x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
2074
2075 make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
2076
2077 add_sym_1 ("shape", GFC_ISYM_SHAPE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2078 gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
2079 src, BT_REAL, dr, REQUIRED);
2080
2081 make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
2082
2083 add_sym_2 ("sign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2084 gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
2085 a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
2086
2087 add_sym_2 ("isign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_INTEGER, di, GFC_STD_F77,
2088 NULL, gfc_simplify_sign, gfc_resolve_sign,
2089 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
2090
2091 add_sym_2 ("dsign", GFC_ISYM_SIGN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2092 NULL, gfc_simplify_sign, gfc_resolve_sign,
2093 a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
2094
2095 make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
2096
2097 add_sym_2 ("signal", GFC_ISYM_SIGNAL, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2098 gfc_check_signal, NULL, gfc_resolve_signal,
2099 num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED);
2100
2101 make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
2102
2103 add_sym_1 ("sin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2104 gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
2105 x, BT_REAL, dr, REQUIRED);
2106
2107 add_sym_1 ("dsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2108 NULL, gfc_simplify_sin, gfc_resolve_sin,
2109 x, BT_REAL, dd, REQUIRED);
2110
2111 add_sym_1 ("csin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2112 NULL, gfc_simplify_sin, gfc_resolve_sin,
2113 x, BT_COMPLEX, dz, REQUIRED);
2114
2115 add_sym_1 ("zsin", GFC_ISYM_SIN, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
2116 NULL, gfc_simplify_sin, gfc_resolve_sin,
2117 x, BT_COMPLEX, dd, REQUIRED);
2118
2119 make_alias ("cdsin", GFC_STD_GNU);
2120
2121 make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
2122
2123 add_sym_1 ("sinh", GFC_ISYM_SINH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2124 gfc_check_fn_r, gfc_simplify_sinh, gfc_resolve_sinh,
2125 x, BT_REAL, dr, REQUIRED);
2126
2127 add_sym_1 ("dsinh", GFC_ISYM_SINH,CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2128 NULL, gfc_simplify_sinh, gfc_resolve_sinh,
2129 x, BT_REAL, dd, REQUIRED);
2130
2131 make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
2132
2133 add_sym_2 ("size", GFC_ISYM_SIZE, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2134 gfc_check_size, gfc_simplify_size, NULL,
2135 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
2136
2137 make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
2138
2139 add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
2140 GFC_STD_GNU, gfc_check_sizeof, NULL, NULL,
2141 i, BT_UNKNOWN, 0, REQUIRED);
2142
2143 make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
2144
2145 add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2146 gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
2147 x, BT_REAL, dr, REQUIRED);
2148
2149 make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
2150
2151 add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2152 gfc_check_spread, NULL, gfc_resolve_spread,
2153 src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
2154 ncopies, BT_INTEGER, di, REQUIRED);
2155
2156 make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
2157
2158 add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2159 gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
2160 x, BT_REAL, dr, REQUIRED);
2161
2162 add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2163 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2164 x, BT_REAL, dd, REQUIRED);
2165
2166 add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2167 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2168 x, BT_COMPLEX, dz, REQUIRED);
2169
2170 add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
2171 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2172 x, BT_COMPLEX, dd, REQUIRED);
2173
2174 make_alias ("cdsqrt", GFC_STD_GNU);
2175
2176 make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
2177
2178 add_sym_2 ("stat", GFC_ISYM_STAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2179 gfc_check_stat, NULL, gfc_resolve_stat,
2180 a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
2181
2182 make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
2183
2184 add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2185 gfc_check_product_sum, NULL, gfc_resolve_sum,
2186 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2187 msk, BT_LOGICAL, dl, OPTIONAL);
2188
2189 make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
2190
2191 add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2192 gfc_check_symlnk, NULL, gfc_resolve_symlnk,
2193 a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
2194
2195 make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
2196
2197 add_sym_1 ("system", GFC_ISYM_SYSTEM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2198 NULL, NULL, NULL,
2199 c, BT_CHARACTER, dc, REQUIRED);
2200
2201 make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
2202
2203 add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2204 gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan,
2205 x, BT_REAL, dr, REQUIRED);
2206
2207 add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2208 NULL, gfc_simplify_tan, gfc_resolve_tan,
2209 x, BT_REAL, dd, REQUIRED);
2210
2211 make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
2212
2213 add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2214 gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh,
2215 x, BT_REAL, dr, REQUIRED);
2216
2217 add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2218 NULL, gfc_simplify_tanh, gfc_resolve_tanh,
2219 x, BT_REAL, dd, REQUIRED);
2220
2221 make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
2222
2223 add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2224 NULL, NULL, gfc_resolve_time);
2225
2226 make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
2227
2228 add_sym_0 ("time8", GFC_ISYM_TIME8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2229 NULL, NULL, gfc_resolve_time8);
2230
2231 make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
2232
2233 add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2234 gfc_check_x, gfc_simplify_tiny, NULL,
2235 x, BT_REAL, dr, REQUIRED);
2236
2237 make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95);
2238
2239 add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2240 gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer,
2241 src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
2242 sz, BT_INTEGER, di, OPTIONAL);
2243
2244 make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
2245
2246 add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2247 gfc_check_transpose, NULL, gfc_resolve_transpose,
2248 m, BT_REAL, dr, REQUIRED);
2249
2250 make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
2251
2252 add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
2253 gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
2254 stg, BT_CHARACTER, dc, REQUIRED);
2255
2256 make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
2257
2258 add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
2259 gfc_check_ttynam, NULL, gfc_resolve_ttynam,
2260 ut, BT_INTEGER, di, REQUIRED);
2261
2262 make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
2263
2264 add_sym_2 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2265 gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
2266 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
2267
2268 make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
2269
2270 /* g77 compatibility for UMASK. */
2271 add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2272 gfc_check_umask, NULL, gfc_resolve_umask,
2273 a, BT_INTEGER, di, REQUIRED);
2274
2275 make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
2276
2277 /* g77 compatibility for UNLINK. */
2278 add_sym_1 ("unlink", GFC_ISYM_UNLINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2279 gfc_check_unlink, NULL, gfc_resolve_unlink,
2280 a, BT_CHARACTER, dc, REQUIRED);
2281
2282 make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
2283
2284 add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2285 gfc_check_unpack, NULL, gfc_resolve_unpack,
2286 v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2287 f, BT_REAL, dr, REQUIRED);
2288
2289 make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
2290
2291 add_sym_3 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO, BT_INTEGER, di, GFC_STD_F95,
2292 gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
2293 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2294 bck, BT_LOGICAL, dl, OPTIONAL);
2295
2296 make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
2297
2298 add_sym_1 ("loc", GFC_ISYM_LOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
2299 gfc_check_loc, NULL, gfc_resolve_loc,
2300 ar, BT_UNKNOWN, 0, REQUIRED);
2301
2302 make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
2303 }
2304
2305
2306 /* Add intrinsic subroutines. */
2307
2308 static void
2309 add_subroutines (void)
2310 {
2311 /* Argument names as in the standard (to be used as argument keywords). */
2312 const char
2313 *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
2314 *c = "count", *tm = "time", *tp = "topos", *gt = "get",
2315 *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
2316 *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
2317 *com = "command", *length = "length", *st = "status",
2318 *val = "value", *num = "number", *name = "name",
2319 *trim_name = "trim_name", *ut = "unit", *han = "handler",
2320 *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
2321 *whence = "whence";
2322
2323 int di, dr, dc, dl, ii;
2324
2325 di = gfc_default_integer_kind;
2326 dr = gfc_default_real_kind;
2327 dc = gfc_default_character_kind;
2328 dl = gfc_default_logical_kind;
2329 ii = gfc_index_integer_kind;
2330
2331 add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL);
2332
2333 make_noreturn();
2334
2335 add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2336 gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
2337 tm, BT_REAL, dr, REQUIRED);
2338
2339 /* More G77 compatibility garbage. */
2340 add_sym_2s ("ctime", GFC_ISYM_CTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2341 gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
2342 tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED);
2343
2344 add_sym_1s ("idate", GFC_ISYM_IDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2345 gfc_check_itime_idate, NULL, gfc_resolve_idate,
2346 vl, BT_INTEGER, 4, REQUIRED);
2347
2348 add_sym_1s ("itime", GFC_ISYM_ITIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2349 gfc_check_itime_idate, NULL, gfc_resolve_itime,
2350 vl, BT_INTEGER, 4, REQUIRED);
2351
2352 add_sym_2s ("ltime", GFC_ISYM_LTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2353 gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime,
2354 tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
2355
2356 add_sym_2s ("gmtime", GFC_ISYM_GMTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2357 gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime,
2358 tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
2359
2360 add_sym_1s ("second", GFC_ISYM_SECOND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2361 gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2362 tm, BT_REAL, dr, REQUIRED);
2363
2364 add_sym_2s ("chdir", GFC_ISYM_CHDIR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2365 gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
2366 name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2367
2368 add_sym_3s ("chmod", GFC_ISYM_CHMOD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2369 gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
2370 name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED,
2371 st, BT_INTEGER, di, OPTIONAL);
2372
2373 add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2374 gfc_check_date_and_time, NULL, NULL,
2375 dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
2376 zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
2377
2378 /* More G77 compatibility garbage. */
2379 add_sym_2s ("etime", GFC_ISYM_ETIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2380 gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2381 vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2382
2383 add_sym_2s ("dtime", GFC_ISYM_DTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2384 gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2385 vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2386
2387 add_sym_1s ("fdate", GFC_ISYM_FDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2388 gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
2389 dt, BT_CHARACTER, dc, REQUIRED);
2390
2391 add_sym_1s ("gerror", GFC_ISYM_GERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2392 gfc_check_gerror, NULL, gfc_resolve_gerror, res, BT_CHARACTER,
2393 dc, REQUIRED);
2394
2395 add_sym_2s ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2396 gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2397 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2398
2399 add_sym_2s ("getenv", GFC_ISYM_GETENV, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2400 NULL, NULL, NULL,
2401 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc,
2402 REQUIRED);
2403
2404 add_sym_2s ("getarg", GFC_ISYM_GETARG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2405 NULL, NULL, gfc_resolve_getarg,
2406 c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
2407
2408 add_sym_1s ("getlog", GFC_ISYM_GETLOG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2409 gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
2410 dc, REQUIRED);
2411
2412 /* F2003 commandline routines. */
2413
2414 add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2415 NULL, NULL, gfc_resolve_get_command,
2416 com, BT_CHARACTER, dc, OPTIONAL,
2417 length, BT_INTEGER, di, OPTIONAL,
2418 st, BT_INTEGER, di, OPTIONAL);
2419
2420 add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2421 NULL, NULL, gfc_resolve_get_command_argument,
2422 num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2423 length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
2424
2425 /* F2003 subroutine to get environment variables. */
2426
2427 add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2428 NULL, NULL, gfc_resolve_get_environment_variable,
2429 name, BT_CHARACTER, dc, REQUIRED,
2430 val, BT_CHARACTER, dc, OPTIONAL,
2431 length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2432 trim_name, BT_LOGICAL, dl, OPTIONAL);
2433
2434 add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2435 gfc_check_move_alloc, NULL, NULL,
2436 f, BT_UNKNOWN, 0, REQUIRED,
2437 t, BT_UNKNOWN, 0, REQUIRED);
2438
2439 add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_F95,
2440 gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2441 f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2442 ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
2443 tp, BT_INTEGER, di, REQUIRED);
2444
2445 add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2446 gfc_check_random_number, NULL, gfc_resolve_random_number,
2447 h, BT_REAL, dr, REQUIRED);
2448
2449 add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2450 gfc_check_random_seed, NULL, NULL,
2451 sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
2452 gt, BT_INTEGER, di, OPTIONAL);
2453
2454 /* More G77 compatibility garbage. */
2455 add_sym_3s ("alarm", GFC_ISYM_ALARM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2456 gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
2457 sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2458 st, BT_INTEGER, di, OPTIONAL);
2459
2460 add_sym_1s ("srand", GFC_ISYM_SRAND, NO_CLASS, BT_UNKNOWN, di, GFC_STD_GNU,
2461 gfc_check_srand, NULL, gfc_resolve_srand,
2462 c, BT_INTEGER, 4, REQUIRED);
2463
2464 add_sym_1s ("exit", GFC_ISYM_EXIT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2465 gfc_check_exit, NULL, gfc_resolve_exit,
2466 st, BT_INTEGER, di, OPTIONAL);
2467
2468 make_noreturn();
2469
2470 add_sym_3s ("fgetc", GFC_ISYM_FGETC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2471 gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
2472 ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2473 st, BT_INTEGER, di, OPTIONAL);
2474
2475 add_sym_2s ("fget", GFC_ISYM_FGET, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2476 gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
2477 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2478
2479 add_sym_1s ("flush", GFC_ISYM_FLUSH, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2480 gfc_check_flush, NULL, gfc_resolve_flush,
2481 c, BT_INTEGER, di, OPTIONAL);
2482
2483 add_sym_3s ("fputc", GFC_ISYM_FPUTC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2484 gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
2485 ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2486 st, BT_INTEGER, di, OPTIONAL);
2487
2488 add_sym_2s ("fput", GFC_ISYM_FPUT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2489 gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
2490 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2491
2492 add_sym_1s ("free", GFC_ISYM_FREE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
2493 NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
2494
2495 add_sym_4s ("fseek", GFC_ISYM_FSEEK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2496 gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
2497 ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, di, REQUIRED,
2498 whence, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2499
2500 add_sym_2s ("ftell", GFC_ISYM_FTELL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2501 gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
2502 ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
2503
2504 add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2505 gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
2506 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2507
2508 add_sym_3s ("kill", GFC_ISYM_KILL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
2509 NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
2510 val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2511
2512 add_sym_3s ("link", GFC_ISYM_LINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2513 gfc_check_link_sub, NULL, gfc_resolve_link_sub,
2514 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2515 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2516
2517 add_sym_1s ("perror", GFC_ISYM_PERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2518 gfc_check_perror, NULL, gfc_resolve_perror,
2519 c, BT_CHARACTER, dc, REQUIRED);
2520
2521 add_sym_3s ("rename", GFC_ISYM_RENAME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2522 gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
2523 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2524 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2525
2526 add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2527 gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
2528 val, BT_CHARACTER, dc, REQUIRED);
2529
2530 add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2531 gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2532 ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2533 st, BT_INTEGER, di, OPTIONAL);
2534
2535 add_sym_3s ("lstat", GFC_ISYM_LSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2536 gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub,
2537 name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2538 st, BT_INTEGER, di, OPTIONAL);
2539
2540 add_sym_3s ("stat", GFC_ISYM_STAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2541 gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2542 name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2543 st, BT_INTEGER, di, OPTIONAL);
2544
2545 add_sym_3s ("signal", GFC_ISYM_SIGNAL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2546 gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
2547 num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2548 st, BT_INTEGER, di, OPTIONAL);
2549
2550 add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2551 gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
2552 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2553 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2554
2555 add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2556 NULL, NULL, gfc_resolve_system_sub,
2557 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2558
2559 add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2560 gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2561 c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
2562 cm, BT_INTEGER, di, OPTIONAL);
2563
2564 add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2565 gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
2566 ut, BT_INTEGER, di, REQUIRED, name, BT_CHARACTER, dc, REQUIRED);
2567
2568 add_sym_2s ("umask", GFC_ISYM_UMASK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2569 gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2570 val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
2571
2572 add_sym_2s ("unlink", GFC_ISYM_UNLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2573 gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2574 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2575 }
2576
2577
2578 /* Add a function to the list of conversion symbols. */
2579
2580 static void
2581 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
2582 {
2583 gfc_typespec from, to;
2584 gfc_intrinsic_sym *sym;
2585
2586 if (sizing == SZ_CONVS)
2587 {
2588 nconv++;
2589 return;
2590 }
2591
2592 gfc_clear_ts (&from);
2593 from.type = from_type;
2594 from.kind = from_kind;
2595
2596 gfc_clear_ts (&to);
2597 to.type = to_type;
2598 to.kind = to_kind;
2599
2600 sym = conversion + nconv;
2601
2602 sym->name = conv_name (&from, &to);
2603 sym->lib_name = sym->name;
2604 sym->simplify.cc = gfc_convert_constant;
2605 sym->standard = standard;
2606 sym->elemental = 1;
2607 sym->conversion = 1;
2608 sym->ts = to;
2609 sym->id = GFC_ISYM_CONVERSION;
2610
2611 nconv++;
2612 }
2613
2614
2615 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2616 functions by looping over the kind tables. */
2617
2618 static void
2619 add_conversions (void)
2620 {
2621 int i, j;
2622
2623 /* Integer-Integer conversions. */
2624 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2625 for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2626 {
2627 if (i == j)
2628 continue;
2629
2630 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2631 BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
2632 }
2633
2634 /* Integer-Real/Complex conversions. */
2635 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2636 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2637 {
2638 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2639 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2640
2641 add_conv (BT_REAL, gfc_real_kinds[j].kind,
2642 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2643
2644 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2645 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2646
2647 add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2648 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2649 }
2650
2651 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2652 {
2653 /* Hollerith-Integer conversions. */
2654 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2655 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2656 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2657 /* Hollerith-Real conversions. */
2658 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2659 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2660 BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2661 /* Hollerith-Complex conversions. */
2662 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2663 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2664 BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2665
2666 /* Hollerith-Character conversions. */
2667 add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
2668 gfc_default_character_kind, GFC_STD_LEGACY);
2669
2670 /* Hollerith-Logical conversions. */
2671 for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
2672 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2673 BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
2674 }
2675
2676 /* Real/Complex - Real/Complex conversions. */
2677 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2678 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2679 {
2680 if (i != j)
2681 {
2682 add_conv (BT_REAL, gfc_real_kinds[i].kind,
2683 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2684
2685 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2686 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2687 }
2688
2689 add_conv (BT_REAL, gfc_real_kinds[i].kind,
2690 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2691
2692 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2693 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2694 }
2695
2696 /* Logical/Logical kind conversion. */
2697 for (i = 0; gfc_logical_kinds[i].kind; i++)
2698 for (j = 0; gfc_logical_kinds[j].kind; j++)
2699 {
2700 if (i == j)
2701 continue;
2702
2703 add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2704 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
2705 }
2706
2707 /* Integer-Logical and Logical-Integer conversions. */
2708 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2709 for (i=0; gfc_integer_kinds[i].kind; i++)
2710 for (j=0; gfc_logical_kinds[j].kind; j++)
2711 {
2712 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2713 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
2714 add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
2715 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2716 }
2717 }
2718
2719
2720 /* Initialize the table of intrinsics. */
2721 void
2722 gfc_intrinsic_init_1 (void)
2723 {
2724 int i;
2725
2726 nargs = nfunc = nsub = nconv = 0;
2727
2728 /* Create a namespace to hold the resolved intrinsic symbols. */
2729 gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2730
2731 sizing = SZ_FUNCS;
2732 add_functions ();
2733 sizing = SZ_SUBS;
2734 add_subroutines ();
2735 sizing = SZ_CONVS;
2736 add_conversions ();
2737
2738 functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2739 + sizeof (gfc_intrinsic_arg) * nargs);
2740
2741 next_sym = functions;
2742 subroutines = functions + nfunc;
2743
2744 conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2745
2746 next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2747
2748 sizing = SZ_NOTHING;
2749 nconv = 0;
2750
2751 add_functions ();
2752 add_subroutines ();
2753 add_conversions ();
2754
2755 /* Set the pure flag. All intrinsic functions are pure, and
2756 intrinsic subroutines are pure if they are elemental. */
2757
2758 for (i = 0; i < nfunc; i++)
2759 functions[i].pure = 1;
2760
2761 for (i = 0; i < nsub; i++)
2762 subroutines[i].pure = subroutines[i].elemental;
2763 }
2764
2765
2766 void
2767 gfc_intrinsic_done_1 (void)
2768 {
2769 gfc_free (functions);
2770 gfc_free (conversion);
2771 gfc_free_namespace (gfc_intrinsic_namespace);
2772 }
2773
2774
2775 /******** Subroutines to check intrinsic interfaces ***********/
2776
2777 /* Given a formal argument list, remove any NULL arguments that may
2778 have been left behind by a sort against some formal argument list. */
2779
2780 static void
2781 remove_nullargs (gfc_actual_arglist **ap)
2782 {
2783 gfc_actual_arglist *head, *tail, *next;
2784
2785 tail = NULL;
2786
2787 for (head = *ap; head; head = next)
2788 {
2789 next = head->next;
2790
2791 if (head->expr == NULL && !head->label)
2792 {
2793 head->next = NULL;
2794 gfc_free_actual_arglist (head);
2795 }
2796 else
2797 {
2798 if (tail == NULL)
2799 *ap = head;
2800 else
2801 tail->next = head;
2802
2803 tail = head;
2804 tail->next = NULL;
2805 }
2806 }
2807
2808 if (tail == NULL)
2809 *ap = NULL;
2810 }
2811
2812
2813 /* Given an actual arglist and a formal arglist, sort the actual
2814 arglist so that its arguments are in a one-to-one correspondence
2815 with the format arglist. Arguments that are not present are given
2816 a blank gfc_actual_arglist structure. If something is obviously
2817 wrong (say, a missing required argument) we abort sorting and
2818 return FAILURE. */
2819
2820 static try
2821 sort_actual (const char *name, gfc_actual_arglist **ap,
2822 gfc_intrinsic_arg *formal, locus *where)
2823 {
2824 gfc_actual_arglist *actual, *a;
2825 gfc_intrinsic_arg *f;
2826
2827 remove_nullargs (ap);
2828 actual = *ap;
2829
2830 for (f = formal; f; f = f->next)
2831 f->actual = NULL;
2832
2833 f = formal;
2834 a = actual;
2835
2836 if (f == NULL && a == NULL) /* No arguments */
2837 return SUCCESS;
2838
2839 for (;;)
2840 { /* Put the nonkeyword arguments in a 1:1 correspondence */
2841 if (f == NULL)
2842 break;
2843 if (a == NULL)
2844 goto optional;
2845
2846 if (a->name != NULL)
2847 goto keywords;
2848
2849 f->actual = a;
2850
2851 f = f->next;
2852 a = a->next;
2853 }
2854
2855 if (a == NULL)
2856 goto do_sort;
2857
2858 gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2859 return FAILURE;
2860
2861 keywords:
2862 /* Associate the remaining actual arguments, all of which have
2863 to be keyword arguments. */
2864 for (; a; a = a->next)
2865 {
2866 for (f = formal; f; f = f->next)
2867 if (strcmp (a->name, f->name) == 0)
2868 break;
2869
2870 if (f == NULL)
2871 {
2872 if (a->name[0] == '%')
2873 gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
2874 "are not allowed in this context at %L", where);
2875 else
2876 gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2877 a->name, name, where);
2878 return FAILURE;
2879 }
2880
2881 if (f->actual != NULL)
2882 {
2883 gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2884 f->name, name, where);
2885 return FAILURE;
2886 }
2887
2888 f->actual = a;
2889 }
2890
2891 optional:
2892 /* At this point, all unmatched formal args must be optional. */
2893 for (f = formal; f; f = f->next)
2894 {
2895 if (f->actual == NULL && f->optional == 0)
2896 {
2897 gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2898 f->name, name, where);
2899 return FAILURE;
2900 }
2901 }
2902
2903 do_sort:
2904 /* Using the formal argument list, string the actual argument list
2905 together in a way that corresponds with the formal list. */
2906 actual = NULL;
2907
2908 for (f = formal; f; f = f->next)
2909 {
2910 if (f->actual && f->actual->label != NULL && f->ts.type)
2911 {
2912 gfc_error ("ALTERNATE RETURN not permitted at %L", where);
2913 return FAILURE;
2914 }
2915
2916 if (f->actual == NULL)
2917 {
2918 a = gfc_get_actual_arglist ();
2919 a->missing_arg_type = f->ts.type;
2920 }
2921 else
2922 a = f->actual;
2923
2924 if (actual == NULL)
2925 *ap = a;
2926 else
2927 actual->next = a;
2928
2929 actual = a;
2930 }
2931 actual->next = NULL; /* End the sorted argument list. */
2932
2933 return SUCCESS;
2934 }
2935
2936
2937 /* Compare an actual argument list with an intrinsic's formal argument
2938 list. The lists are checked for agreement of type. We don't check
2939 for arrayness here. */
2940
2941 static try
2942 check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
2943 int error_flag)
2944 {
2945 gfc_actual_arglist *actual;
2946 gfc_intrinsic_arg *formal;
2947 int i;
2948
2949 formal = sym->formal;
2950 actual = *ap;
2951
2952 i = 0;
2953 for (; formal; formal = formal->next, actual = actual->next, i++)
2954 {
2955 if (actual->expr == NULL)
2956 continue;
2957
2958 if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2959 {
2960 if (error_flag)
2961 gfc_error ("Type of argument '%s' in call to '%s' at %L should "
2962 "be %s, not %s", gfc_current_intrinsic_arg[i],
2963 gfc_current_intrinsic, &actual->expr->where,
2964 gfc_typename (&formal->ts),
2965 gfc_typename (&actual->expr->ts));
2966 return FAILURE;
2967 }
2968 }
2969
2970 return SUCCESS;
2971 }
2972
2973
2974 /* Given a pointer to an intrinsic symbol and an expression node that
2975 represent the function call to that subroutine, figure out the type
2976 of the result. This may involve calling a resolution subroutine. */
2977
2978 static void
2979 resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
2980 {
2981 gfc_expr *a1, *a2, *a3, *a4, *a5;
2982 gfc_actual_arglist *arg;
2983
2984 if (specific->resolve.f1 == NULL)
2985 {
2986 if (e->value.function.name == NULL)
2987 e->value.function.name = specific->lib_name;
2988
2989 if (e->ts.type == BT_UNKNOWN)
2990 e->ts = specific->ts;
2991 return;
2992 }
2993
2994 arg = e->value.function.actual;
2995
2996 /* Special case hacks for MIN and MAX. */
2997 if (specific->resolve.f1m == gfc_resolve_max
2998 || specific->resolve.f1m == gfc_resolve_min)
2999 {
3000 (*specific->resolve.f1m) (e, arg);
3001 return;
3002 }
3003
3004 if (arg == NULL)
3005 {
3006 (*specific->resolve.f0) (e);
3007 return;
3008 }
3009
3010 a1 = arg->expr;
3011 arg = arg->next;
3012
3013 if (arg == NULL)
3014 {
3015 (*specific->resolve.f1) (e, a1);
3016 return;
3017 }
3018
3019 a2 = arg->expr;
3020 arg = arg->next;
3021
3022 if (arg == NULL)
3023 {
3024 (*specific->resolve.f2) (e, a1, a2);
3025 return;
3026 }
3027
3028 a3 = arg->expr;
3029 arg = arg->next;
3030
3031 if (arg == NULL)
3032 {
3033 (*specific->resolve.f3) (e, a1, a2, a3);
3034 return;
3035 }
3036
3037 a4 = arg->expr;
3038 arg = arg->next;
3039
3040 if (arg == NULL)
3041 {
3042 (*specific->resolve.f4) (e, a1, a2, a3, a4);
3043 return;
3044 }
3045
3046 a5 = arg->expr;
3047 arg = arg->next;
3048
3049 if (arg == NULL)
3050 {
3051 (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
3052 return;
3053 }
3054
3055 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
3056 }
3057
3058
3059 /* Given an intrinsic symbol node and an expression node, call the
3060 simplification function (if there is one), perhaps replacing the
3061 expression with something simpler. We return FAILURE on an error
3062 of the simplification, SUCCESS if the simplification worked, even
3063 if nothing has changed in the expression itself. */
3064
3065 static try
3066 do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
3067 {
3068 gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
3069 gfc_actual_arglist *arg;
3070
3071 /* Max and min require special handling due to the variable number
3072 of args. */
3073 if (specific->simplify.f1 == gfc_simplify_min)
3074 {
3075 result = gfc_simplify_min (e);
3076 goto finish;
3077 }
3078
3079 if (specific->simplify.f1 == gfc_simplify_max)
3080 {
3081 result = gfc_simplify_max (e);
3082 goto finish;
3083 }
3084
3085 if (specific->simplify.f1 == NULL)
3086 {
3087 result = NULL;
3088 goto finish;
3089 }
3090
3091 arg = e->value.function.actual;
3092
3093 if (arg == NULL)
3094 {
3095 result = (*specific->simplify.f0) ();
3096 goto finish;
3097 }
3098
3099 a1 = arg->expr;
3100 arg = arg->next;
3101
3102 if (specific->simplify.cc == gfc_convert_constant)
3103 {
3104 result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
3105 goto finish;
3106 }
3107
3108 /* TODO: Warn if -pedantic and initialization expression and arg
3109 types not integer or character */
3110
3111 if (arg == NULL)
3112 result = (*specific->simplify.f1) (a1);
3113 else
3114 {
3115 a2 = arg->expr;
3116 arg = arg->next;
3117
3118 if (arg == NULL)
3119 result = (*specific->simplify.f2) (a1, a2);
3120 else
3121 {
3122 a3 = arg->expr;
3123 arg = arg->next;
3124
3125 if (arg == NULL)
3126 result = (*specific->simplify.f3) (a1, a2, a3);
3127 else
3128 {
3129 a4 = arg->expr;
3130 arg = arg->next;
3131
3132 if (arg == NULL)
3133 result = (*specific->simplify.f4) (a1, a2, a3, a4);
3134 else
3135 {
3136 a5 = arg->expr;
3137 arg = arg->next;
3138
3139 if (arg == NULL)
3140 result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
3141 else
3142 gfc_internal_error
3143 ("do_simplify(): Too many args for intrinsic");
3144 }
3145 }
3146 }
3147 }
3148
3149 finish:
3150 if (result == &gfc_bad_expr)
3151 return FAILURE;
3152
3153 if (result == NULL)
3154 resolve_intrinsic (specific, e); /* Must call at run-time */
3155 else
3156 {
3157 result->where = e->where;
3158 gfc_replace_expr (e, result);
3159 }
3160
3161 return SUCCESS;
3162 }
3163
3164
3165 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
3166 error messages. This subroutine returns FAILURE if a subroutine
3167 has more than MAX_INTRINSIC_ARGS, in which case the actual argument
3168 list cannot match any intrinsic. */
3169
3170 static void
3171 init_arglist (gfc_intrinsic_sym *isym)
3172 {
3173 gfc_intrinsic_arg *formal;
3174 int i;
3175
3176 gfc_current_intrinsic = isym->name;
3177
3178 i = 0;
3179 for (formal = isym->formal; formal; formal = formal->next)
3180 {
3181 if (i >= MAX_INTRINSIC_ARGS)
3182 gfc_internal_error ("init_arglist(): too many arguments");
3183 gfc_current_intrinsic_arg[i++] = formal->name;
3184 }
3185 }
3186
3187
3188 /* Given a pointer to an intrinsic symbol and an expression consisting
3189 of a function call, see if the function call is consistent with the
3190 intrinsic's formal argument list. Return SUCCESS if the expression
3191 and intrinsic match, FAILURE otherwise. */
3192
3193 static try
3194 check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
3195 {
3196 gfc_actual_arglist *arg, **ap;
3197 try t;
3198
3199 ap = &expr->value.function.actual;
3200
3201 init_arglist (specific);
3202
3203 /* Don't attempt to sort the argument list for min or max. */
3204 if (specific->check.f1m == gfc_check_min_max
3205 || specific->check.f1m == gfc_check_min_max_integer
3206 || specific->check.f1m == gfc_check_min_max_real
3207 || specific->check.f1m == gfc_check_min_max_double)
3208 return (*specific->check.f1m) (*ap);
3209
3210 if (sort_actual (specific->name, ap, specific->formal,
3211 &expr->where) == FAILURE)
3212 return FAILURE;
3213
3214 if (specific->check.f3ml == gfc_check_minloc_maxloc)
3215 /* This is special because we might have to reorder the argument list. */
3216 t = gfc_check_minloc_maxloc (*ap);
3217 else if (specific->check.f3red == gfc_check_minval_maxval)
3218 /* This is also special because we also might have to reorder the
3219 argument list. */
3220 t = gfc_check_minval_maxval (*ap);
3221 else if (specific->check.f3red == gfc_check_product_sum)
3222 /* Same here. The difference to the previous case is that we allow a
3223 general numeric type. */
3224 t = gfc_check_product_sum (*ap);
3225 else
3226 {
3227 if (specific->check.f1 == NULL)
3228 {
3229 t = check_arglist (ap, specific, error_flag);
3230 if (t == SUCCESS)
3231 expr->ts = specific->ts;
3232 }
3233 else
3234 t = do_check (specific, *ap);
3235 }
3236
3237 /* Check conformance of elemental intrinsics. */
3238 if (t == SUCCESS && specific->elemental)
3239 {
3240 int n = 0;
3241 gfc_expr *first_expr;
3242 arg = expr->value.function.actual;
3243
3244 /* There is no elemental intrinsic without arguments. */
3245 gcc_assert(arg != NULL);
3246 first_expr = arg->expr;
3247
3248 for ( ; arg && arg->expr; arg = arg->next, n++)
3249 {
3250 char buffer[80];
3251 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
3252 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n],
3253 gfc_current_intrinsic);
3254 if (gfc_check_conformance (buffer, first_expr, arg->expr) == FAILURE)
3255 return FAILURE;
3256 }
3257 }
3258
3259 if (t == FAILURE)
3260 remove_nullargs (ap);
3261
3262 return t;
3263 }
3264
3265
3266 /* Check whether an intrinsic belongs to whatever standard the user
3267 has chosen. */
3268
3269 static try
3270 check_intrinsic_standard (const char *name, int standard, locus *where)
3271 {
3272 /* Do not warn about GNU-extensions if -std=gnu. */
3273 if (!gfc_option.warn_nonstd_intrinsics
3274 || (standard == GFC_STD_GNU && gfc_option.warn_std & GFC_STD_GNU))
3275 return SUCCESS;
3276
3277 if (gfc_notify_std (standard, "Intrinsic '%s' at %L is not included "
3278 "in the selected standard", name, where) == FAILURE)
3279 return FAILURE;
3280
3281 return SUCCESS;
3282 }
3283
3284
3285 /* See if a function call corresponds to an intrinsic function call.
3286 We return:
3287
3288 MATCH_YES if the call corresponds to an intrinsic, simplification
3289 is done if possible.
3290
3291 MATCH_NO if the call does not correspond to an intrinsic
3292
3293 MATCH_ERROR if the call corresponds to an intrinsic but there was an
3294 error during the simplification process.
3295
3296 The error_flag parameter enables an error reporting. */
3297
3298 match
3299 gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
3300 {
3301 gfc_intrinsic_sym *isym, *specific;
3302 gfc_actual_arglist *actual;
3303 const char *name;
3304 int flag;
3305
3306 if (expr->value.function.isym != NULL)
3307 return (do_simplify (expr->value.function.isym, expr) == FAILURE)
3308 ? MATCH_ERROR : MATCH_YES;
3309
3310 gfc_suppress_error = !error_flag;
3311 flag = 0;
3312
3313 for (actual = expr->value.function.actual; actual; actual = actual->next)
3314 if (actual->expr != NULL)
3315 flag |= (actual->expr->ts.type != BT_INTEGER
3316 && actual->expr->ts.type != BT_CHARACTER);
3317
3318 name = expr->symtree->n.sym->name;
3319
3320 isym = specific = gfc_find_function (name);
3321 if (isym == NULL)
3322 {
3323 gfc_suppress_error = 0;
3324 return MATCH_NO;
3325 }
3326
3327 if (check_intrinsic_standard (name, isym->standard, &expr->where) == FAILURE)
3328 return MATCH_ERROR;
3329
3330 gfc_current_intrinsic_where = &expr->where;
3331
3332 /* Bypass the generic list for min and max. */
3333 if (isym->check.f1m == gfc_check_min_max)
3334 {
3335 init_arglist (isym);
3336
3337 if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
3338 goto got_specific;
3339
3340 gfc_suppress_error = 0;
3341 return MATCH_NO;
3342 }
3343
3344 /* If the function is generic, check all of its specific
3345 incarnations. If the generic name is also a specific, we check
3346 that name last, so that any error message will correspond to the
3347 specific. */
3348 gfc_suppress_error = 1;
3349
3350 if (isym->generic)
3351 {
3352 for (specific = isym->specific_head; specific;
3353 specific = specific->next)
3354 {
3355 if (specific == isym)
3356 continue;
3357 if (check_specific (specific, expr, 0) == SUCCESS)
3358 goto got_specific;
3359 }
3360 }
3361
3362 gfc_suppress_error = !error_flag;
3363
3364 if (check_specific (isym, expr, error_flag) == FAILURE)
3365 {
3366 gfc_suppress_error = 0;
3367 return MATCH_NO;
3368 }
3369
3370 specific = isym;
3371
3372 got_specific:
3373 expr->value.function.isym = specific;
3374 gfc_intrinsic_symbol (expr->symtree->n.sym);
3375
3376 gfc_suppress_error = 0;
3377 if (do_simplify (specific, expr) == FAILURE)
3378 return MATCH_ERROR;
3379
3380 /* F95, 7.1.6.1, Initialization expressions
3381 (4) An elemental intrinsic function reference of type integer or
3382 character where each argument is an initialization expression
3383 of type integer or character
3384
3385 F2003, 7.1.7 Initialization expression
3386 (4) A reference to an elemental standard intrinsic function,
3387 where each argument is an initialization expression */
3388
3389 if (gfc_init_expr
3390 && isym->elemental
3391 && (expr->ts.type != BT_INTEGER || expr->ts.type != BT_CHARACTER)
3392 && gfc_notify_std (GFC_STD_F2003, "Extension: Evaluation of "
3393 "nonstandard initialization expression at %L",
3394 &expr->where) == FAILURE)
3395 return MATCH_ERROR;
3396
3397 return MATCH_YES;
3398 }
3399
3400
3401 /* See if a CALL statement corresponds to an intrinsic subroutine.
3402 Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3403 MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3404 correspond). */
3405
3406 match
3407 gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
3408 {
3409 gfc_intrinsic_sym *isym;
3410 const char *name;
3411
3412 name = c->symtree->n.sym->name;
3413
3414 isym = gfc_find_subroutine (name);
3415 if (isym == NULL)
3416 return MATCH_NO;
3417
3418 if (check_intrinsic_standard (name, isym->standard, &c->loc) == FAILURE)
3419 return MATCH_ERROR;
3420
3421 gfc_suppress_error = !error_flag;
3422
3423 init_arglist (isym);
3424
3425 if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3426 goto fail;
3427
3428 if (isym->check.f1 != NULL)
3429 {
3430 if (do_check (isym, c->ext.actual) == FAILURE)
3431 goto fail;
3432 }
3433 else
3434 {
3435 if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3436 goto fail;
3437 }
3438
3439 /* The subroutine corresponds to an intrinsic. Allow errors to be
3440 seen at this point. */
3441 gfc_suppress_error = 0;
3442
3443 if (isym->resolve.s1 != NULL)
3444 isym->resolve.s1 (c);
3445 else
3446 c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3447
3448 if (gfc_pure (NULL) && !isym->elemental)
3449 {
3450 gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3451 &c->loc);
3452 return MATCH_ERROR;
3453 }
3454
3455 c->resolved_sym->attr.noreturn = isym->noreturn;
3456
3457 return MATCH_YES;
3458
3459 fail:
3460 gfc_suppress_error = 0;
3461 return MATCH_NO;
3462 }
3463
3464
3465 /* Call gfc_convert_type() with warning enabled. */
3466
3467 try
3468 gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
3469 {
3470 return gfc_convert_type_warn (expr, ts, eflag, 1);
3471 }
3472
3473
3474 /* Try to convert an expression (in place) from one type to another.
3475 'eflag' controls the behavior on error.
3476
3477 The possible values are:
3478
3479 1 Generate a gfc_error()
3480 2 Generate a gfc_internal_error().
3481
3482 'wflag' controls the warning related to conversion. */
3483
3484 try
3485 gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
3486 {
3487 gfc_intrinsic_sym *sym;
3488 gfc_typespec from_ts;
3489 locus old_where;
3490 gfc_expr *new;
3491 int rank;
3492 mpz_t *shape;
3493
3494 from_ts = expr->ts; /* expr->ts gets clobbered */
3495
3496 if (ts->type == BT_UNKNOWN)
3497 goto bad;
3498
3499 /* NULL and zero size arrays get their type here. */
3500 if (expr->expr_type == EXPR_NULL
3501 || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL))
3502 {
3503 /* Sometimes the RHS acquire the type. */
3504 expr->ts = *ts;
3505 return SUCCESS;
3506 }
3507
3508 if (expr->ts.type == BT_UNKNOWN)
3509 goto bad;
3510
3511 if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
3512 && gfc_compare_types (&expr->ts, ts))
3513 return SUCCESS;
3514
3515 sym = find_conv (&expr->ts, ts);
3516 if (sym == NULL)
3517 goto bad;
3518
3519 /* At this point, a conversion is necessary. A warning may be needed. */
3520 if ((gfc_option.warn_std & sym->standard) != 0)
3521 gfc_warning_now ("Extension: Conversion from %s to %s at %L",
3522 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3523 else if (wflag && gfc_option.warn_conversion)
3524 gfc_warning_now ("Conversion from %s to %s at %L",
3525 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3526
3527 /* Insert a pre-resolved function call to the right function. */
3528 old_where = expr->where;
3529 rank = expr->rank;
3530 shape = expr->shape;
3531
3532 new = gfc_get_expr ();
3533 *new = *expr;
3534
3535 new = gfc_build_conversion (new);
3536 new->value.function.name = sym->lib_name;
3537 new->value.function.isym = sym;
3538 new->where = old_where;
3539 new->rank = rank;
3540 new->shape = gfc_copy_shape (shape, rank);
3541
3542 gfc_get_ha_sym_tree (sym->name, &new->symtree);
3543 new->symtree->n.sym->ts = *ts;
3544 new->symtree->n.sym->attr.flavor = FL_PROCEDURE;
3545 new->symtree->n.sym->attr.function = 1;
3546 new->symtree->n.sym->attr.elemental = 1;
3547 new->symtree->n.sym->attr.pure = 1;
3548 new->symtree->n.sym->attr.referenced = 1;
3549 gfc_intrinsic_symbol(new->symtree->n.sym);
3550 gfc_commit_symbol (new->symtree->n.sym);
3551
3552 *expr = *new;
3553
3554 gfc_free (new);
3555 expr->ts = *ts;
3556
3557 if (gfc_is_constant_expr (expr->value.function.actual->expr)
3558 && do_simplify (sym, expr) == FAILURE)
3559 {
3560
3561 if (eflag == 2)
3562 goto bad;
3563 return FAILURE; /* Error already generated in do_simplify() */
3564 }
3565
3566 return SUCCESS;
3567
3568 bad:
3569 if (eflag == 1)
3570 {
3571 gfc_error ("Can't convert %s to %s at %L",
3572 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3573 return FAILURE;
3574 }
3575
3576 gfc_internal_error ("Can't convert %s to %s at %L",
3577 gfc_typename (&from_ts), gfc_typename (ts),
3578 &expr->where);
3579 /* Not reached */
3580 }
Mirror of https://gcc.gnu.org/git/gcc.git