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