]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/fortran/intrinsic.c
projects / thirdparty / gcc.git / blob
? search:


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