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