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