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