?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2005-07-07 Adrian Straetling <straetling@de.ibm.com>
[official-gcc.git] / gcc / fortran / intrinsic.c
blob67d95df2f3a1a773ad896887c6ce106b80ece5a7
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
847 /* Add intrinsic functions. */
848
849 static void
850 add_functions (void)
851 {
852
853 /* Argument names as in the standard (to be used as argument keywords). */
854 const char
855 *a = "a", *f = "field", *pt = "pointer", *tg = "target",
856 *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
857 *c = "c", *n = "ncopies", *pos = "pos", *bck = "back",
858 *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
859 *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
860 *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
861 *p = "p", *ar = "array", *shp = "shape", *src = "source",
862 *r = "r", *bd = "boundary", *pad = "pad", *set = "set",
863 *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
864 *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
865 *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
866 *z = "z", *ln = "len", *ut = "unit";
867
868 int di, dr, dd, dl, dc, dz, ii;
869
870 di = gfc_default_integer_kind;
871 dr = gfc_default_real_kind;
872 dd = gfc_default_double_kind;
873 dl = gfc_default_logical_kind;
874 dc = gfc_default_character_kind;
875 dz = gfc_default_complex_kind;
876 ii = gfc_index_integer_kind;
877
878 add_sym_1 ("abs", 1, 1, BT_REAL, dr, GFC_STD_F77,
879 gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs,
880 a, BT_REAL, dr, REQUIRED);
881
882 add_sym_1 ("iabs", 1, 1, BT_INTEGER, di, GFC_STD_F77,
883 NULL, gfc_simplify_abs, gfc_resolve_abs,
884 a, BT_INTEGER, di, REQUIRED);
885
886 add_sym_1 ("dabs", 1, 1, BT_REAL, dd, GFC_STD_F77,
887 NULL, gfc_simplify_abs, gfc_resolve_abs,
888 a, BT_REAL, dd, REQUIRED);
889
890 add_sym_1 ("cabs", 1, 1, BT_REAL, dr, GFC_STD_F77,
891 NULL, gfc_simplify_abs, gfc_resolve_abs,
892 a, BT_COMPLEX, dz, REQUIRED);
893
894 add_sym_1 ("zabs", 1, 1, BT_REAL, dd, GFC_STD_GNU,
895 NULL, gfc_simplify_abs, gfc_resolve_abs,
896 a, BT_COMPLEX, dd, REQUIRED);
897
898 make_alias ("cdabs", GFC_STD_GNU);
899
900 make_generic ("abs", GFC_ISYM_ABS, GFC_STD_F77);
901
902 add_sym_1 ("achar", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
903 gfc_check_achar, gfc_simplify_achar, NULL,
904 i, BT_INTEGER, di, REQUIRED);
905
906 make_generic ("achar", GFC_ISYM_ACHAR, GFC_STD_F95);
907
908 add_sym_1 ("acos", 1, 1, BT_REAL, dr, GFC_STD_F77,
909 gfc_check_fn_r, gfc_simplify_acos, gfc_resolve_acos,
910 x, BT_REAL, dr, REQUIRED);
911
912 add_sym_1 ("dacos", 1, 1, BT_REAL, dd, GFC_STD_F77,
913 NULL, gfc_simplify_acos, gfc_resolve_acos,
914 x, BT_REAL, dd, REQUIRED);
915
916 make_generic ("acos", GFC_ISYM_ACOS, GFC_STD_F77);
917
918 add_sym_1 ("acosh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
919 gfc_check_fn_r, gfc_simplify_acosh, gfc_resolve_acosh,
920 x, BT_REAL, dr, REQUIRED);
921
922 add_sym_1 ("dacosh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
923 NULL, gfc_simplify_acosh, gfc_resolve_acosh,
924 x, BT_REAL, dd, REQUIRED);
925
926 make_generic ("acosh", GFC_ISYM_ACOSH, GFC_STD_GNU);
927
928 add_sym_1 ("adjustl", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
929 NULL, gfc_simplify_adjustl, NULL,
930 stg, BT_CHARACTER, dc, REQUIRED);
931
932 make_generic ("adjustl", GFC_ISYM_ADJUSTL, GFC_STD_F95);
933
934 add_sym_1 ("adjustr", 1, 1, BT_CHARACTER, dc, GFC_STD_F95,
935 NULL, gfc_simplify_adjustr, NULL,
936 stg, BT_CHARACTER, dc, REQUIRED);
937
938 make_generic ("adjustr", GFC_ISYM_ADJUSTR, GFC_STD_F95);
939
940 add_sym_1 ("aimag", 1, 1, BT_REAL, dr, GFC_STD_F77,
941 gfc_check_fn_c, gfc_simplify_aimag, gfc_resolve_aimag,
942 z, BT_COMPLEX, dz, REQUIRED);
943
944 add_sym_1 ("dimag", 1, 1, BT_REAL, dd, GFC_STD_GNU,
945 NULL, gfc_simplify_aimag, gfc_resolve_aimag,
946 z, BT_COMPLEX, dd, REQUIRED);
947
948 make_generic ("aimag", GFC_ISYM_AIMAG, GFC_STD_F77);
949
950 add_sym_2 ("aint", 1, 1, BT_REAL, dr, GFC_STD_F77,
951 gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
952 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
953
954 add_sym_1 ("dint", 1, 1, BT_REAL, dd, GFC_STD_F77,
955 NULL, gfc_simplify_dint, gfc_resolve_dint,
956 a, BT_REAL, dd, REQUIRED);
957
958 make_generic ("aint", GFC_ISYM_AINT, GFC_STD_F77);
959
960 add_sym_2 ("all", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
961 gfc_check_all_any, NULL, gfc_resolve_all,
962 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
963
964 make_generic ("all", GFC_ISYM_ALL, GFC_STD_F95);
965
966 add_sym_1 ("allocated", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
967 gfc_check_allocated, NULL, NULL,
968 ar, BT_UNKNOWN, 0, REQUIRED);
969
970 make_generic ("allocated", GFC_ISYM_ALLOCATED, GFC_STD_F95);
971
972 add_sym_2 ("anint", 1, 1, BT_REAL, dr, GFC_STD_F77,
973 gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
974 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
975
976 add_sym_1 ("dnint", 1, 1, BT_REAL, dd, GFC_STD_F77,
977 NULL, gfc_simplify_dnint, gfc_resolve_dnint,
978 a, BT_REAL, dd, REQUIRED);
979
980 make_generic ("anint", GFC_ISYM_ANINT, GFC_STD_F77);
981
982 add_sym_2 ("any", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
983 gfc_check_all_any, NULL, gfc_resolve_any,
984 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
985
986 make_generic ("any", GFC_ISYM_ANY, GFC_STD_F95);
987
988 add_sym_1 ("asin", 1, 1, BT_REAL, dr, GFC_STD_F77,
989 gfc_check_fn_r, gfc_simplify_asin, gfc_resolve_asin,
990 x, BT_REAL, dr, REQUIRED);
991
992 add_sym_1 ("dasin", 1, 1, BT_REAL, dd, GFC_STD_F77,
993 NULL, gfc_simplify_asin, gfc_resolve_asin,
994 x, BT_REAL, dd, REQUIRED);
995
996 make_generic ("asin", GFC_ISYM_ASIN, GFC_STD_F77);
997
998 add_sym_1 ("asinh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
999 gfc_check_fn_r, gfc_simplify_asinh, gfc_resolve_asinh,
1000 x, BT_REAL, dr, REQUIRED);
1001
1002 add_sym_1 ("dasinh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
1003 NULL, gfc_simplify_asinh, gfc_resolve_asinh,
1004 x, BT_REAL, dd, REQUIRED);
1005
1006 make_generic ("asinh", GFC_ISYM_ASINH, GFC_STD_GNU);
1007
1008 add_sym_2 ("associated", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1009 gfc_check_associated, NULL, NULL,
1010 pt, BT_UNKNOWN, 0, REQUIRED, tg, BT_UNKNOWN, 0, OPTIONAL);
1011
1012 make_generic ("associated", GFC_ISYM_ASSOCIATED, GFC_STD_F95);
1013
1014 add_sym_1 ("atan", 1, 1, BT_REAL, dr, GFC_STD_F77,
1015 gfc_check_fn_r, gfc_simplify_atan, gfc_resolve_atan,
1016 x, BT_REAL, dr, REQUIRED);
1017
1018 add_sym_1 ("datan", 1, 1, BT_REAL, dd, GFC_STD_F77,
1019 NULL, gfc_simplify_atan, gfc_resolve_atan,
1020 x, BT_REAL, dd, REQUIRED);
1021
1022 make_generic ("atan", GFC_ISYM_ATAN, GFC_STD_F77);
1023
1024 add_sym_1 ("atanh", 1, 1, BT_REAL, dr, GFC_STD_GNU,
1025 gfc_check_fn_r, gfc_simplify_atanh, gfc_resolve_atanh,
1026 x, BT_REAL, dr, REQUIRED);
1027
1028 add_sym_1 ("datanh", 1, 1, BT_REAL, dd, GFC_STD_GNU,
1029 NULL, gfc_simplify_atanh, gfc_resolve_atanh,
1030 x, BT_REAL, dd, REQUIRED);
1031
1032 make_generic ("atanh", GFC_ISYM_ATANH, GFC_STD_GNU);
1033
1034 add_sym_2 ("atan2", 1, 1, BT_REAL, dr, GFC_STD_F77,
1035 gfc_check_atan2, gfc_simplify_atan2, gfc_resolve_atan2,
1036 y, BT_REAL, dr, REQUIRED, x, BT_REAL, dr, REQUIRED);
1037
1038 add_sym_2 ("datan2", 1, 1, BT_REAL, dd, GFC_STD_F77,
1039 NULL, gfc_simplify_atan2, gfc_resolve_atan2,
1040 y, BT_REAL, dd, REQUIRED, x, BT_REAL, dd, REQUIRED);
1041
1042 make_generic ("atan2", GFC_ISYM_ATAN2, GFC_STD_F77);
1043
1044 /* Bessel and Neumann functions for G77 compatibility. */
1045 add_sym_1 ("besj0", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1046 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1047 x, BT_REAL, dr, REQUIRED);
1048
1049 add_sym_1 ("dbesj0", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1050 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1051 x, BT_REAL, dd, REQUIRED);
1052
1053 make_generic ("besj0", GFC_ISYM_J0, GFC_STD_GNU);
1054
1055 add_sym_1 ("besj1", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1056 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1057 x, BT_REAL, dr, REQUIRED);
1058
1059 add_sym_1 ("dbesj1", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1060 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1061 x, BT_REAL, dd, REQUIRED);
1062
1063 make_generic ("besj1", GFC_ISYM_J1, GFC_STD_GNU);
1064
1065 add_sym_2 ("besjn", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1066 gfc_check_besn, NULL, gfc_resolve_besn,
1067 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1068
1069 add_sym_2 ("dbesjn", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1070 gfc_check_besn, NULL, gfc_resolve_besn,
1071 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1072
1073 make_generic ("besjn", GFC_ISYM_JN, GFC_STD_GNU);
1074
1075 add_sym_1 ("besy0", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1076 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1077 x, BT_REAL, dr, REQUIRED);
1078
1079 add_sym_1 ("dbesy0", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1080 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1081 x, BT_REAL, dd, REQUIRED);
1082
1083 make_generic ("besy0", GFC_ISYM_Y0, GFC_STD_GNU);
1084
1085 add_sym_1 ("besy1", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1086 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1087 x, BT_REAL, dr, REQUIRED);
1088
1089 add_sym_1 ("dbesy1", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1090 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1091 x, BT_REAL, dd, REQUIRED);
1092
1093 make_generic ("besy1", GFC_ISYM_Y1, GFC_STD_GNU);
1094
1095 add_sym_2 ("besyn", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1096 gfc_check_besn, NULL, gfc_resolve_besn,
1097 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dr, REQUIRED);
1098
1099 add_sym_2 ("dbesyn", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1100 gfc_check_besn, NULL, gfc_resolve_besn,
1101 n, BT_INTEGER, di, REQUIRED, x, BT_REAL, dd, REQUIRED);
1102
1103 make_generic ("besyn", GFC_ISYM_YN, GFC_STD_GNU);
1104
1105 add_sym_1 ("bit_size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1106 gfc_check_i, gfc_simplify_bit_size, NULL,
1107 i, BT_INTEGER, di, REQUIRED);
1108
1109 make_generic ("bit_size", GFC_ISYM_NONE, GFC_STD_F95);
1110
1111 add_sym_2 ("btest", 1, 1, BT_LOGICAL, dl, GFC_STD_F95,
1112 gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest,
1113 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1114
1115 make_generic ("btest", GFC_ISYM_BTEST, GFC_STD_F95);
1116
1117 add_sym_2 ("ceiling", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1118 gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
1119 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1120
1121 make_generic ("ceiling", GFC_ISYM_CEILING, GFC_STD_F95);
1122
1123 add_sym_2 ("char", 1, 0, BT_CHARACTER, dc, GFC_STD_F77,
1124 gfc_check_char, gfc_simplify_char, gfc_resolve_char,
1125 i, BT_INTEGER, di, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1126
1127 make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
1128
1129 add_sym_1 ("chdir", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1130 gfc_check_chdir, NULL, gfc_resolve_chdir,
1131 a, BT_CHARACTER, dc, REQUIRED);
1132
1133 make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
1134
1135 add_sym_3 ("cmplx", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1136 gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
1137 x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
1138 kind, BT_INTEGER, di, OPTIONAL);
1139
1140 make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
1141
1142 /* Making dcmplx a specific of cmplx causes cmplx to return a double
1143 complex instead of the default complex. */
1144
1145 add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1146 gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
1147 x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, OPTIONAL);
1148
1149 make_generic ("dcmplx", GFC_ISYM_CMPLX, GFC_STD_GNU);
1150
1151 add_sym_1 ("conjg", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1152 gfc_check_fn_c, gfc_simplify_conjg, gfc_resolve_conjg,
1153 z, BT_COMPLEX, dz, REQUIRED);
1154
1155 add_sym_1 ("dconjg", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1156 NULL, gfc_simplify_conjg, gfc_resolve_conjg,
1157 z, BT_COMPLEX, dd, REQUIRED);
1158
1159 make_generic ("conjg", GFC_ISYM_CONJG, GFC_STD_F77);
1160
1161 add_sym_1 ("cos", 1, 1, BT_REAL, dr, GFC_STD_F77,
1162 gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1163 x, BT_REAL, dr, REQUIRED);
1164
1165 add_sym_1 ("dcos", 1, 1, BT_REAL, dd, GFC_STD_F77,
1166 gfc_check_fn_rc, gfc_simplify_cos, gfc_resolve_cos,
1167 x, BT_REAL, dd, REQUIRED);
1168
1169 add_sym_1 ("ccos", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1170 NULL, gfc_simplify_cos, gfc_resolve_cos,
1171 x, BT_COMPLEX, dz, REQUIRED);
1172
1173 add_sym_1 ("zcos", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1174 NULL, gfc_simplify_cos, gfc_resolve_cos,
1175 x, BT_COMPLEX, dd, REQUIRED);
1176
1177 make_alias ("cdcos", GFC_STD_GNU);
1178
1179 make_generic ("cos", GFC_ISYM_COS, GFC_STD_F77);
1180
1181 add_sym_1 ("cosh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1182 gfc_check_fn_r, gfc_simplify_cosh, gfc_resolve_cosh,
1183 x, BT_REAL, dr, REQUIRED);
1184
1185 add_sym_1 ("dcosh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1186 NULL, gfc_simplify_cosh, gfc_resolve_cosh,
1187 x, BT_REAL, dd, REQUIRED);
1188
1189 make_generic ("cosh", GFC_ISYM_COSH, GFC_STD_F77);
1190
1191 add_sym_2 ("count", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1192 gfc_check_count, NULL, gfc_resolve_count,
1193 msk, BT_LOGICAL, dl, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1194
1195 make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95);
1196
1197 add_sym_3 ("cshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
1198 gfc_check_cshift, NULL, gfc_resolve_cshift,
1199 ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1200 dm, BT_INTEGER, ii, OPTIONAL);
1201
1202 make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
1203
1204 add_sym_1 ("dble", 1, 1, BT_REAL, dd, GFC_STD_F77,
1205 gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
1206 a, BT_REAL, dr, REQUIRED);
1207
1208 make_alias ("dfloat", GFC_STD_GNU);
1209
1210 make_generic ("dble", GFC_ISYM_DBLE, GFC_STD_F77);
1211
1212 add_sym_1 ("digits", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1213 gfc_check_digits, gfc_simplify_digits, NULL,
1214 x, BT_UNKNOWN, dr, REQUIRED);
1215
1216 make_generic ("digits", GFC_ISYM_NONE, GFC_STD_F95);
1217
1218 add_sym_2 ("dim", 1, 1, BT_REAL, dr, GFC_STD_F77,
1219 gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
1220 x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
1221
1222 add_sym_2 ("idim", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1223 NULL, gfc_simplify_dim, gfc_resolve_dim,
1224 x, BT_INTEGER, di, REQUIRED, y, BT_INTEGER, di, REQUIRED);
1225
1226 add_sym_2 ("ddim", 1, 1, BT_REAL, dd, GFC_STD_F77,
1227 NULL, gfc_simplify_dim, gfc_resolve_dim,
1228 x, BT_REAL, dd, REQUIRED, y, BT_REAL, dd, REQUIRED);
1229
1230 make_generic ("dim", GFC_ISYM_DIM, GFC_STD_F77);
1231
1232 add_sym_2 ("dot_product", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
1233 gfc_check_dot_product, NULL, gfc_resolve_dot_product,
1234 va, BT_REAL, dr, REQUIRED, vb, BT_REAL, dr, REQUIRED);
1235
1236 make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT, GFC_STD_F95);
1237
1238 add_sym_2 ("dprod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1239 NULL, gfc_simplify_dprod, gfc_resolve_dprod,
1240 x, BT_REAL, dr, REQUIRED, y, BT_REAL, dr, REQUIRED);
1241
1242 make_generic ("dprod", GFC_ISYM_DPROD, GFC_STD_F77);
1243
1244 add_sym_1 ("dreal", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1245 NULL, NULL, NULL,
1246 a, BT_COMPLEX, dd, REQUIRED);
1247
1248 make_generic ("dreal", GFC_ISYM_REAL, GFC_STD_GNU);
1249
1250 add_sym_4 ("eoshift", 0, 1, BT_REAL, dr, GFC_STD_F95,
1251 gfc_check_eoshift, NULL, gfc_resolve_eoshift,
1252 ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, REQUIRED,
1253 bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, OPTIONAL);
1254
1255 make_generic ("eoshift", GFC_ISYM_EOSHIFT, GFC_STD_F95);
1256
1257 add_sym_1 ("epsilon", 0, 1, BT_REAL, dr, GFC_STD_F95,
1258 gfc_check_x, gfc_simplify_epsilon, NULL,
1259 x, BT_REAL, dr, REQUIRED);
1260
1261 make_generic ("epsilon", GFC_ISYM_NONE, GFC_STD_F95);
1262
1263 /* G77 compatibility for the ERF() and ERFC() functions. */
1264 add_sym_1 ("erf", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1265 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1266 x, BT_REAL, dr, REQUIRED);
1267
1268 add_sym_1 ("derf", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1269 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1270 x, BT_REAL, dd, REQUIRED);
1271
1272 make_generic ("erf", GFC_ISYM_ERF, GFC_STD_GNU);
1273
1274 add_sym_1 ("erfc", 1, 0, BT_REAL, dr, GFC_STD_GNU,
1275 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1276 x, BT_REAL, dr, REQUIRED);
1277
1278 add_sym_1 ("derfc", 1, 0, BT_REAL, dd, GFC_STD_GNU,
1279 gfc_check_g77_math1, NULL, gfc_resolve_g77_math1,
1280 x, BT_REAL, dd, REQUIRED);
1281
1282 make_generic ("erfc", GFC_ISYM_ERFC, GFC_STD_GNU);
1283
1284 /* G77 compatibility */
1285 add_sym_1 ("etime", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1286 gfc_check_etime, NULL, NULL,
1287 x, BT_REAL, 4, REQUIRED);
1288
1289 make_alias ("dtime", GFC_STD_GNU);
1290
1291 make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
1292
1293 add_sym_1 ("exp", 1, 1, BT_REAL, dr, GFC_STD_F77,
1294 gfc_check_fn_rc, gfc_simplify_exp, gfc_resolve_exp,
1295 x, BT_REAL, dr, REQUIRED);
1296
1297 add_sym_1 ("dexp", 1, 1, BT_REAL, dd, GFC_STD_F77,
1298 NULL, gfc_simplify_exp, gfc_resolve_exp,
1299 x, BT_REAL, dd, REQUIRED);
1300
1301 add_sym_1 ("cexp", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1302 NULL, gfc_simplify_exp, gfc_resolve_exp,
1303 x, BT_COMPLEX, dz, REQUIRED);
1304
1305 add_sym_1 ("zexp", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1306 NULL, gfc_simplify_exp, gfc_resolve_exp,
1307 x, BT_COMPLEX, dd, REQUIRED);
1308
1309 make_alias ("cdexp", GFC_STD_GNU);
1310
1311 make_generic ("exp", GFC_ISYM_EXP, GFC_STD_F77);
1312
1313 add_sym_1 ("exponent", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1314 gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
1315 x, BT_REAL, dr, REQUIRED);
1316
1317 make_generic ("exponent", GFC_ISYM_EXPONENT, GFC_STD_F95);
1318
1319 add_sym_2 ("floor", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1320 gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
1321 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1322
1323 make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
1324
1325 /* G77 compatible fnum */
1326 add_sym_1 ("fnum", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1327 gfc_check_fnum, NULL, gfc_resolve_fnum,
1328 ut, BT_INTEGER, di, REQUIRED);
1329
1330 make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
1331
1332 add_sym_1 ("fraction", 1, 1, BT_REAL, dr, GFC_STD_F95,
1333 gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
1334 x, BT_REAL, dr, REQUIRED);
1335
1336 make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
1337
1338 add_sym_2 ("fstat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1339 gfc_check_fstat, NULL, gfc_resolve_fstat,
1340 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1341
1342 make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
1343
1344 /* Unix IDs (g77 compatibility) */
1345 add_sym_1 ("getcwd", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1346 NULL, NULL, gfc_resolve_getcwd,
1347 c, BT_CHARACTER, dc, REQUIRED);
1348
1349 make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
1350
1351 add_sym_0 ("getgid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1352 NULL, NULL, gfc_resolve_getgid);
1353
1354 make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
1355
1356 add_sym_0 ("getpid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1357 NULL, NULL, gfc_resolve_getpid);
1358
1359 make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
1360
1361 add_sym_0 ("getuid", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1362 NULL, NULL, gfc_resolve_getuid);
1363
1364 make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
1365
1366 add_sym_1 ("hostnm", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1367 gfc_check_hostnm, NULL, gfc_resolve_hostnm,
1368 a, BT_CHARACTER, dc, REQUIRED);
1369
1370 make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
1371
1372 add_sym_1 ("huge", 0, 1, BT_REAL, dr, GFC_STD_F95,
1373 gfc_check_huge, gfc_simplify_huge, NULL,
1374 x, BT_UNKNOWN, dr, REQUIRED);
1375
1376 make_generic ("huge", GFC_ISYM_NONE, GFC_STD_F95);
1377
1378 add_sym_1 ("iachar", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1379 gfc_check_ichar_iachar, gfc_simplify_iachar, NULL,
1380 c, BT_CHARACTER, dc, REQUIRED);
1381
1382 make_generic ("iachar", GFC_ISYM_IACHAR, GFC_STD_F95);
1383
1384 add_sym_2 ("iand", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1385 gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1386 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1387
1388 make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
1389
1390 add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1391 NULL, NULL, NULL);
1392
1393 make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
1394
1395 add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER, di, GFC_STD_F2003,
1396 NULL, NULL, NULL);
1397
1398 make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT,
1399 GFC_STD_F2003);
1400
1401 add_sym_2 ("ibclr", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1402 gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
1403 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1404
1405 make_generic ("ibclr", GFC_ISYM_IBCLR, GFC_STD_F95);
1406
1407 add_sym_3 ("ibits", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1408 gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
1409 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED,
1410 ln, BT_INTEGER, di, REQUIRED);
1411
1412 make_generic ("ibits", GFC_ISYM_IBITS, GFC_STD_F95);
1413
1414 add_sym_2 ("ibset", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1415 gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset,
1416 i, BT_INTEGER, di, REQUIRED, pos, BT_INTEGER, di, REQUIRED);
1417
1418 make_generic ("ibset", GFC_ISYM_IBSET, GFC_STD_F95);
1419
1420 add_sym_1 ("ichar", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1421 gfc_check_ichar_iachar, gfc_simplify_ichar, gfc_resolve_ichar,
1422 c, BT_CHARACTER, dc, REQUIRED);
1423
1424 make_generic ("ichar", GFC_ISYM_ICHAR, GFC_STD_F77);
1425
1426 add_sym_2 ("ieor", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1427 gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
1428 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1429
1430 make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
1431
1432 add_sym_0 ("ierrno", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
1433 NULL, NULL, gfc_resolve_ierrno);
1434
1435 make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
1436
1437 add_sym_3 ("index", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1438 gfc_check_index, gfc_simplify_index, NULL,
1439 stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
1440 bck, BT_LOGICAL, dl, OPTIONAL);
1441
1442 make_generic ("index", GFC_ISYM_INDEX, GFC_STD_F77);
1443
1444 add_sym_2 ("int", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1445 gfc_check_int, gfc_simplify_int, gfc_resolve_int,
1446 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1447
1448 add_sym_1 ("ifix", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1449 NULL, gfc_simplify_ifix, NULL,
1450 a, BT_REAL, dr, REQUIRED);
1451
1452 add_sym_1 ("idint", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1453 NULL, gfc_simplify_idint, NULL,
1454 a, BT_REAL, dd, REQUIRED);
1455
1456 make_generic ("int", GFC_ISYM_INT, GFC_STD_F77);
1457
1458 add_sym_2 ("ior", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1459 gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
1460 i, BT_INTEGER, di, REQUIRED, j, BT_INTEGER, di, REQUIRED);
1461
1462 make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
1463
1464 /* The following function is for G77 compatibility. */
1465 add_sym_1 ("irand", 0, 1, BT_INTEGER, 4, GFC_STD_GNU,
1466 gfc_check_irand, NULL, NULL,
1467 i, BT_INTEGER, 4, OPTIONAL);
1468
1469 make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
1470
1471 add_sym_2 ("ishft", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1472 gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
1473 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
1474
1475 make_generic ("ishft", GFC_ISYM_ISHFT, GFC_STD_F95);
1476
1477 add_sym_3 ("ishftc", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1478 gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
1479 i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED,
1480 sz, BT_INTEGER, di, OPTIONAL);
1481
1482 make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
1483
1484 add_sym_2 ("kill", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1485 gfc_check_kill, NULL, gfc_resolve_kill,
1486 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1487
1488 make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
1489
1490 add_sym_1 ("kind", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1491 gfc_check_kind, gfc_simplify_kind, NULL,
1492 x, BT_REAL, dr, REQUIRED);
1493
1494 make_generic ("kind", GFC_ISYM_NONE, GFC_STD_F95);
1495
1496 add_sym_2 ("lbound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1497 gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
1498 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, di, OPTIONAL);
1499
1500 make_generic ("lbound", GFC_ISYM_LBOUND, GFC_STD_F95);
1501
1502 add_sym_1 ("len", 0, 1, BT_INTEGER, di, GFC_STD_F77,
1503 NULL, gfc_simplify_len, gfc_resolve_len,
1504 stg, BT_CHARACTER, dc, REQUIRED);
1505
1506 make_generic ("len", GFC_ISYM_LEN, GFC_STD_F77);
1507
1508 add_sym_1 ("len_trim", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1509 NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
1510 stg, BT_CHARACTER, dc, REQUIRED);
1511
1512 make_alias ("lnblnk", GFC_STD_GNU);
1513
1514 make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
1515
1516 add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1517 NULL, gfc_simplify_lge, NULL,
1518 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1519
1520 make_generic ("lge", GFC_ISYM_LGE, GFC_STD_F77);
1521
1522 add_sym_2 ("lgt", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1523 NULL, gfc_simplify_lgt, NULL,
1524 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1525
1526 make_generic ("lgt", GFC_ISYM_LGT, GFC_STD_F77);
1527
1528 add_sym_2 ("lle", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1529 NULL, gfc_simplify_lle, NULL,
1530 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1531
1532 make_generic ("lle", GFC_ISYM_LLE, GFC_STD_F77);
1533
1534 add_sym_2 ("llt", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
1535 NULL, gfc_simplify_llt, NULL,
1536 sta, BT_CHARACTER, dc, REQUIRED, stb, BT_CHARACTER, dc, REQUIRED);
1537
1538 make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
1539
1540 add_sym_2 ("link", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1541 gfc_check_link, NULL, gfc_resolve_link,
1542 a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1543
1544 make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
1545
1546 add_sym_1 ("log", 1, 1, BT_REAL, dr, GFC_STD_F77,
1547 gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
1548 x, BT_REAL, dr, REQUIRED);
1549
1550 add_sym_1 ("alog", 1, 1, BT_REAL, dr, GFC_STD_F77,
1551 NULL, gfc_simplify_log, gfc_resolve_log,
1552 x, BT_REAL, dr, REQUIRED);
1553
1554 add_sym_1 ("dlog", 1, 1, BT_REAL, dd, GFC_STD_F77,
1555 NULL, gfc_simplify_log, gfc_resolve_log,
1556 x, BT_REAL, dd, REQUIRED);
1557
1558 add_sym_1 ("clog", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1559 NULL, gfc_simplify_log, gfc_resolve_log,
1560 x, BT_COMPLEX, dz, REQUIRED);
1561
1562 add_sym_1 ("zlog", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1563 NULL, gfc_simplify_log, gfc_resolve_log,
1564 x, BT_COMPLEX, dd, REQUIRED);
1565
1566 make_alias ("cdlog", GFC_STD_GNU);
1567
1568 make_generic ("log", GFC_ISYM_LOG, GFC_STD_F77);
1569
1570 add_sym_1 ("log10", 1, 1, BT_REAL, dr, GFC_STD_F77,
1571 gfc_check_fn_r, gfc_simplify_log10, gfc_resolve_log10,
1572 x, BT_REAL, dr, REQUIRED);
1573
1574 add_sym_1 ("alog10", 1, 1, BT_REAL, dr, GFC_STD_F77,
1575 NULL, gfc_simplify_log10, gfc_resolve_log10,
1576 x, BT_REAL, dr, REQUIRED);
1577
1578 add_sym_1 ("dlog10", 1, 1, BT_REAL, dd, GFC_STD_F77,
1579 NULL, gfc_simplify_log10, gfc_resolve_log10,
1580 x, BT_REAL, dd, REQUIRED);
1581
1582 make_generic ("log10", GFC_ISYM_LOG10, GFC_STD_F77);
1583
1584 add_sym_2 ("logical", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1585 gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
1586 l, BT_LOGICAL, dl, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1587
1588 make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
1589
1590 add_sym_2 ("matmul", 0, 1, BT_REAL, dr, GFC_STD_F95,
1591 gfc_check_matmul, NULL, gfc_resolve_matmul,
1592 ma, BT_REAL, dr, REQUIRED, mb, BT_REAL, dr, REQUIRED);
1593
1594 make_generic ("matmul", GFC_ISYM_MATMUL, GFC_STD_F95);
1595
1596 /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1597 int(max). The max function must take at least two arguments. */
1598
1599 add_sym_1m ("max", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1600 gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
1601 a1, BT_UNKNOWN, dr, REQUIRED, a2, BT_UNKNOWN, dr, REQUIRED);
1602
1603 add_sym_1m ("max0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1604 gfc_check_min_max_integer, gfc_simplify_max, NULL,
1605 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1606
1607 add_sym_1m ("amax0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1608 gfc_check_min_max_integer, gfc_simplify_max, NULL,
1609 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1610
1611 add_sym_1m ("amax1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1612 gfc_check_min_max_real, gfc_simplify_max, NULL,
1613 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1614
1615 add_sym_1m ("max1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1616 gfc_check_min_max_real, gfc_simplify_max, NULL,
1617 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1618
1619 add_sym_1m ("dmax1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1620 gfc_check_min_max_double, gfc_simplify_max, NULL,
1621 a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1622
1623 make_generic ("max", GFC_ISYM_MAX, GFC_STD_F77);
1624
1625 add_sym_1 ("maxexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1626 gfc_check_x, gfc_simplify_maxexponent, NULL,
1627 x, BT_UNKNOWN, dr, REQUIRED);
1628
1629 make_generic ("maxexponent", GFC_ISYM_NONE, GFC_STD_F95);
1630
1631 add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1632 gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
1633 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1634 msk, BT_LOGICAL, dl, OPTIONAL);
1635
1636 make_generic ("maxloc", GFC_ISYM_MAXLOC, GFC_STD_F95);
1637
1638 add_sym_3red ("maxval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1639 gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
1640 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1641 msk, BT_LOGICAL, dl, OPTIONAL);
1642
1643 make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
1644
1645 add_sym_3 ("merge", 1, 1, BT_REAL, dr, GFC_STD_F95,
1646 gfc_check_merge, NULL, gfc_resolve_merge,
1647 ts, BT_REAL, dr, REQUIRED, fs, BT_REAL, dr, REQUIRED,
1648 msk, BT_LOGICAL, dl, REQUIRED);
1649
1650 make_generic ("merge", GFC_ISYM_MERGE, GFC_STD_F95);
1651
1652 /* Note: amin0 is equivalent to real(min), min1 is equivalent to
1653 int(min). */
1654
1655 add_sym_1m ("min", 1, 0, BT_UNKNOWN, 0, GFC_STD_F77,
1656 gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
1657 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1658
1659 add_sym_1m ("min0", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1660 gfc_check_min_max_integer, gfc_simplify_min, NULL,
1661 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1662
1663 add_sym_1m ("amin0", 1, 0, BT_REAL, dr, GFC_STD_F77,
1664 gfc_check_min_max_integer, gfc_simplify_min, NULL,
1665 a1, BT_INTEGER, di, REQUIRED, a2, BT_INTEGER, di, REQUIRED);
1666
1667 add_sym_1m ("amin1", 1, 0, BT_REAL, dr, GFC_STD_F77,
1668 gfc_check_min_max_real, gfc_simplify_min, NULL,
1669 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1670
1671 add_sym_1m ("min1", 1, 0, BT_INTEGER, di, GFC_STD_F77,
1672 gfc_check_min_max_real, gfc_simplify_min, NULL,
1673 a1, BT_REAL, dr, REQUIRED, a2, BT_REAL, dr, REQUIRED);
1674
1675 add_sym_1m ("dmin1", 1, 0, BT_REAL, dd, GFC_STD_F77,
1676 gfc_check_min_max_double, gfc_simplify_min, NULL,
1677 a1, BT_REAL, dd, REQUIRED, a2, BT_REAL, dd, REQUIRED);
1678
1679 make_generic ("min", GFC_ISYM_MIN, GFC_STD_F77);
1680
1681 add_sym_1 ("minexponent", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1682 gfc_check_x, gfc_simplify_minexponent, NULL,
1683 x, BT_UNKNOWN, dr, REQUIRED);
1684
1685 make_generic ("minexponent", GFC_ISYM_NONE, GFC_STD_F95);
1686
1687 add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1688 gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
1689 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1690 msk, BT_LOGICAL, dl, OPTIONAL);
1691
1692 make_generic ("minloc", GFC_ISYM_MINLOC, GFC_STD_F95);
1693
1694 add_sym_3red ("minval", 0, 1, BT_REAL, dr, GFC_STD_F95,
1695 gfc_check_minval_maxval, NULL, gfc_resolve_minval,
1696 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1697 msk, BT_LOGICAL, dl, OPTIONAL);
1698
1699 make_generic ("minval", GFC_ISYM_MINVAL, GFC_STD_F95);
1700
1701 add_sym_2 ("mod", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1702 gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
1703 a, BT_INTEGER, di, REQUIRED, p, BT_INTEGER, di, REQUIRED);
1704
1705 add_sym_2 ("amod", 1, 1, BT_REAL, dr, GFC_STD_F77,
1706 NULL, gfc_simplify_mod, gfc_resolve_mod,
1707 a, BT_REAL, dr, REQUIRED, p, BT_REAL, dr, REQUIRED);
1708
1709 add_sym_2 ("dmod", 1, 1, BT_REAL, dd, GFC_STD_F77,
1710 NULL, gfc_simplify_mod, gfc_resolve_mod,
1711 a, BT_REAL, dd, REQUIRED, p, BT_REAL, dd, REQUIRED);
1712
1713 make_generic ("mod", GFC_ISYM_MOD, GFC_STD_F77);
1714
1715 add_sym_2 ("modulo", 1, 1, BT_REAL, di, GFC_STD_F95,
1716 gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
1717 a, BT_REAL, di, REQUIRED, p, BT_REAL, di, REQUIRED);
1718
1719 make_generic ("modulo", GFC_ISYM_MODULO, GFC_STD_F95);
1720
1721 add_sym_2 ("nearest", 1, 1, BT_REAL, dr, GFC_STD_F95,
1722 gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
1723 x, BT_REAL, dr, REQUIRED, s, BT_REAL, dr, REQUIRED);
1724
1725 make_generic ("nearest", GFC_ISYM_NEAREST, GFC_STD_F95);
1726
1727 add_sym_2 ("nint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1728 gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
1729 a, BT_REAL, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1730
1731 add_sym_1 ("idnint", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1732 gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
1733 a, BT_REAL, dd, REQUIRED);
1734
1735 make_generic ("nint", GFC_ISYM_NINT, GFC_STD_F77);
1736
1737 add_sym_1 ("not", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1738 gfc_check_i, gfc_simplify_not, gfc_resolve_not,
1739 i, BT_INTEGER, di, REQUIRED);
1740
1741 make_generic ("not", GFC_ISYM_NOT, GFC_STD_F95);
1742
1743 add_sym_1 ("null", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1744 gfc_check_null, gfc_simplify_null, NULL,
1745 mo, BT_INTEGER, di, OPTIONAL);
1746
1747 make_generic ("null", GFC_ISYM_NONE, GFC_STD_F95);
1748
1749 add_sym_3 ("pack", 0, 1, BT_REAL, dr, GFC_STD_F95,
1750 gfc_check_pack, NULL, gfc_resolve_pack,
1751 ar, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
1752 v, BT_REAL, dr, OPTIONAL);
1753
1754 make_generic ("pack", GFC_ISYM_PACK, GFC_STD_F95);
1755
1756 add_sym_1 ("precision", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1757 gfc_check_precision, gfc_simplify_precision, NULL,
1758 x, BT_UNKNOWN, 0, REQUIRED);
1759
1760 make_generic ("precision", GFC_ISYM_NONE, GFC_STD_F95);
1761
1762 add_sym_1 ("present", 0, 1, BT_LOGICAL, dl, GFC_STD_F95,
1763 gfc_check_present, NULL, NULL,
1764 a, BT_REAL, dr, REQUIRED);
1765
1766 make_generic ("present", GFC_ISYM_PRESENT, GFC_STD_F95);
1767
1768 add_sym_3red ("product", 0, 1, BT_REAL, dr, GFC_STD_F95,
1769 gfc_check_product_sum, NULL, gfc_resolve_product,
1770 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1771 msk, BT_LOGICAL, dl, OPTIONAL);
1772
1773 make_generic ("product", GFC_ISYM_PRODUCT, GFC_STD_F95);
1774
1775 add_sym_1 ("radix", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1776 gfc_check_radix, gfc_simplify_radix, NULL,
1777 x, BT_UNKNOWN, 0, REQUIRED);
1778
1779 make_generic ("radix", GFC_ISYM_NONE, GFC_STD_F95);
1780
1781 /* The following function is for G77 compatibility. */
1782 add_sym_1 ("rand", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1783 gfc_check_rand, NULL, NULL,
1784 i, BT_INTEGER, 4, OPTIONAL);
1785
1786 /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran()
1787 use slightly different shoddy multiplicative congruential PRNG. */
1788 make_alias ("ran", GFC_STD_GNU);
1789
1790 make_generic ("rand", GFC_ISYM_RAND, GFC_STD_GNU);
1791
1792 add_sym_1 ("range", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1793 gfc_check_range, gfc_simplify_range, NULL,
1794 x, BT_REAL, dr, REQUIRED);
1795
1796 make_generic ("range", GFC_ISYM_NONE, GFC_STD_F95);
1797
1798 add_sym_2 ("real", 1, 0, BT_REAL, dr, GFC_STD_F77,
1799 gfc_check_real, gfc_simplify_real, gfc_resolve_real,
1800 a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL);
1801
1802 add_sym_1 ("float", 1, 0, BT_REAL, dr, GFC_STD_F77,
1803 NULL, gfc_simplify_float, NULL,
1804 a, BT_INTEGER, di, REQUIRED);
1805
1806 add_sym_1 ("sngl", 1, 0, BT_REAL, dr, GFC_STD_F77,
1807 NULL, gfc_simplify_sngl, NULL,
1808 a, BT_REAL, dd, REQUIRED);
1809
1810 make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
1811
1812 add_sym_2 ("rename", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1813 gfc_check_rename, NULL, gfc_resolve_rename,
1814 a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1815
1816 make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
1817
1818 add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
1819 gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
1820 stg, BT_CHARACTER, dc, REQUIRED, n, BT_INTEGER, di, REQUIRED);
1821
1822 make_generic ("repeat", GFC_ISYM_REPEAT, GFC_STD_F95);
1823
1824 add_sym_4 ("reshape", 0, 1, BT_REAL, dr, GFC_STD_F95,
1825 gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
1826 src, BT_REAL, dr, REQUIRED, shp, BT_INTEGER, ii, REQUIRED,
1827 pad, BT_REAL, dr, OPTIONAL, ord, BT_INTEGER, ii, OPTIONAL);
1828
1829 make_generic ("reshape", GFC_ISYM_RESHAPE, GFC_STD_F95);
1830
1831 add_sym_1 ("rrspacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1832 gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
1833 x, BT_REAL, dr, REQUIRED);
1834
1835 make_generic ("rrspacing", GFC_ISYM_RRSPACING, GFC_STD_F95);
1836
1837 add_sym_2 ("scale", 1, 1, BT_REAL, dr, GFC_STD_F95,
1838 gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
1839 x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1840
1841 make_generic ("scale", GFC_ISYM_SCALE, GFC_STD_F95);
1842
1843 add_sym_3 ("scan", 1, 1, BT_INTEGER, di, GFC_STD_F95,
1844 gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
1845 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
1846 bck, BT_LOGICAL, dl, OPTIONAL);
1847
1848 make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
1849
1850 /* Added for G77 compatibility garbage. */
1851 add_sym_0 ("second", 0, 1, BT_REAL, 4, GFC_STD_GNU,
1852 NULL, NULL, NULL);
1853
1854 make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
1855
1856 add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1857 gfc_check_selected_int_kind, gfc_simplify_selected_int_kind, NULL,
1858 r, BT_INTEGER, di, REQUIRED);
1859
1860 make_generic ("selected_int_kind", GFC_ISYM_SI_KIND, GFC_STD_F95);
1861
1862 add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1863 gfc_check_selected_real_kind, gfc_simplify_selected_real_kind,
1864 NULL,
1865 p, BT_INTEGER, di, OPTIONAL, r, BT_INTEGER, di, OPTIONAL);
1866
1867 make_generic ("selected_real_kind", GFC_ISYM_SR_KIND, GFC_STD_F95);
1868
1869 add_sym_2 ("set_exponent", 1, 1, BT_REAL, dr, GFC_STD_F95,
1870 gfc_check_set_exponent, gfc_simplify_set_exponent,
1871 gfc_resolve_set_exponent,
1872 x, BT_REAL, dr, REQUIRED, i, BT_INTEGER, di, REQUIRED);
1873
1874 make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT, GFC_STD_F95);
1875
1876 add_sym_1 ("shape", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1877 gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
1878 src, BT_REAL, dr, REQUIRED);
1879
1880 make_generic ("shape", GFC_ISYM_SHAPE, GFC_STD_F95);
1881
1882 add_sym_2 ("sign", 1, 1, BT_REAL, dr, GFC_STD_F77,
1883 gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
1884 a, BT_REAL, dr, REQUIRED, b, BT_REAL, dr, REQUIRED);
1885
1886 add_sym_2 ("isign", 1, 1, BT_INTEGER, di, GFC_STD_F77,
1887 NULL, gfc_simplify_sign, gfc_resolve_sign,
1888 a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1889
1890 add_sym_2 ("dsign", 1, 1, BT_REAL, dd, GFC_STD_F77,
1891 NULL, gfc_simplify_sign, gfc_resolve_sign,
1892 a, BT_REAL, dd, REQUIRED, b, BT_REAL, dd, REQUIRED);
1893
1894 make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
1895
1896 add_sym_1 ("sin", 1, 1, BT_REAL, dr, GFC_STD_F77,
1897 gfc_check_fn_rc, gfc_simplify_sin, gfc_resolve_sin,
1898 x, BT_REAL, dr, REQUIRED);
1899
1900 add_sym_1 ("dsin", 1, 1, BT_REAL, dd, GFC_STD_F77,
1901 NULL, gfc_simplify_sin, gfc_resolve_sin,
1902 x, BT_REAL, dd, REQUIRED);
1903
1904 add_sym_1 ("csin", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1905 NULL, gfc_simplify_sin, gfc_resolve_sin,
1906 x, BT_COMPLEX, dz, REQUIRED);
1907
1908 add_sym_1 ("zsin", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1909 NULL, gfc_simplify_sin, gfc_resolve_sin,
1910 x, BT_COMPLEX, dd, REQUIRED);
1911
1912 make_alias ("cdsin", GFC_STD_GNU);
1913
1914 make_generic ("sin", GFC_ISYM_SIN, GFC_STD_F77);
1915
1916 add_sym_1 ("sinh", 1, 1, BT_REAL, dr, GFC_STD_F77,
1917 gfc_check_fn_r, gfc_simplify_sinh, gfc_resolve_sinh,
1918 x, BT_REAL, dr, REQUIRED);
1919
1920 add_sym_1 ("dsinh", 1, 1, BT_REAL, dd, GFC_STD_F77,
1921 NULL, gfc_simplify_sinh, gfc_resolve_sinh,
1922 x, BT_REAL, dd, REQUIRED);
1923
1924 make_generic ("sinh", GFC_ISYM_SINH, GFC_STD_F77);
1925
1926 add_sym_2 ("size", 0, 1, BT_INTEGER, di, GFC_STD_F95,
1927 gfc_check_size, gfc_simplify_size, NULL,
1928 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
1929
1930 make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
1931
1932 add_sym_1 ("spacing", 1, 1, BT_REAL, dr, GFC_STD_F95,
1933 gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
1934 x, BT_REAL, dr, REQUIRED);
1935
1936 make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
1937
1938 add_sym_3 ("spread", 0, 1, BT_REAL, dr, GFC_STD_F95,
1939 gfc_check_spread, NULL, gfc_resolve_spread,
1940 src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
1941 n, BT_INTEGER, di, REQUIRED);
1942
1943 make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
1944
1945 add_sym_1 ("sqrt", 1, 1, BT_REAL, dr, GFC_STD_F77,
1946 gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
1947 x, BT_REAL, dr, REQUIRED);
1948
1949 add_sym_1 ("dsqrt", 1, 1, BT_REAL, dd, GFC_STD_F77,
1950 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1951 x, BT_REAL, dd, REQUIRED);
1952
1953 add_sym_1 ("csqrt", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
1954 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1955 x, BT_COMPLEX, dz, REQUIRED);
1956
1957 add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX, dd, GFC_STD_GNU,
1958 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1959 x, BT_COMPLEX, dd, REQUIRED);
1960
1961 make_alias ("cdsqrt", GFC_STD_GNU);
1962
1963 make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
1964
1965 add_sym_2 ("stat", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1966 gfc_check_stat, NULL, gfc_resolve_stat,
1967 a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
1968
1969 make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
1970
1971 add_sym_3red ("sum", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
1972 gfc_check_product_sum, NULL, gfc_resolve_sum,
1973 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
1974 msk, BT_LOGICAL, dl, OPTIONAL);
1975
1976 make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
1977
1978 add_sym_2 ("symlnk", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
1979 gfc_check_symlnk, NULL, gfc_resolve_symlnk,
1980 a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
1981
1982 make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
1983
1984 add_sym_1 ("system", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
1985 NULL, NULL, NULL,
1986 c, BT_CHARACTER, dc, REQUIRED);
1987
1988 make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
1989
1990 add_sym_1 ("tan", 1, 1, BT_REAL, dr, GFC_STD_F77,
1991 gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan,
1992 x, BT_REAL, dr, REQUIRED);
1993
1994 add_sym_1 ("dtan", 1, 1, BT_REAL, dd, GFC_STD_F77,
1995 NULL, gfc_simplify_tan, gfc_resolve_tan,
1996 x, BT_REAL, dd, REQUIRED);
1997
1998 make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
1999
2000 add_sym_1 ("tanh", 1, 1, BT_REAL, dr, GFC_STD_F77,
2001 gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh,
2002 x, BT_REAL, dr, REQUIRED);
2003
2004 add_sym_1 ("dtanh", 1, 1, BT_REAL, dd, GFC_STD_F77,
2005 NULL, gfc_simplify_tanh, gfc_resolve_tanh,
2006 x, BT_REAL, dd, REQUIRED);
2007
2008 make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
2009
2010 add_sym_0 ("time", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
2011 NULL, NULL, gfc_resolve_time);
2012
2013 make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
2014
2015 add_sym_0 ("time8", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
2016 NULL, NULL, gfc_resolve_time8);
2017
2018 make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
2019
2020 add_sym_1 ("tiny", 0, 1, BT_REAL, dr, GFC_STD_F95,
2021 gfc_check_x, gfc_simplify_tiny, NULL,
2022 x, BT_REAL, dr, REQUIRED);
2023
2024 make_generic ("tiny", GFC_ISYM_NONE, GFC_STD_F95);
2025
2026 add_sym_3 ("transfer", 0, 1, BT_REAL, dr, GFC_STD_F95,
2027 gfc_check_transfer, NULL, gfc_resolve_transfer,
2028 src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
2029 sz, BT_INTEGER, di, OPTIONAL);
2030
2031 make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
2032
2033 add_sym_1 ("transpose", 0, 1, BT_REAL, dr, GFC_STD_F95,
2034 gfc_check_transpose, NULL, gfc_resolve_transpose,
2035 m, BT_REAL, dr, REQUIRED);
2036
2037 make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
2038
2039 add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
2040 gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
2041 stg, BT_CHARACTER, dc, REQUIRED);
2042
2043 make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
2044
2045 add_sym_2 ("ubound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
2046 gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
2047 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
2048
2049 make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
2050
2051 /* g77 compatibility for UMASK. */
2052 add_sym_1 ("umask", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2053 gfc_check_umask, NULL, gfc_resolve_umask,
2054 a, BT_INTEGER, di, REQUIRED);
2055
2056 make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
2057
2058 /* g77 compatibility for UNLINK. */
2059 add_sym_1 ("unlink", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
2060 gfc_check_unlink, NULL, gfc_resolve_unlink,
2061 a, BT_CHARACTER, dc, REQUIRED);
2062
2063 make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
2064
2065 add_sym_3 ("unpack", 0, 1, BT_REAL, dr, GFC_STD_F95,
2066 gfc_check_unpack, NULL, gfc_resolve_unpack,
2067 v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2068 f, BT_REAL, dr, REQUIRED);
2069
2070 make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
2071
2072 add_sym_3 ("verify", 1, 1, BT_INTEGER, di, GFC_STD_F95,
2073 gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
2074 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2075 bck, BT_LOGICAL, dl, OPTIONAL);
2076
2077 make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
2078 }
2079
2080
2081 /* Add intrinsic subroutines. */
2082
2083 static void
2084 add_subroutines (void)
2085 {
2086 /* Argument names as in the standard (to be used as argument keywords). */
2087 const char
2088 *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
2089 *c = "count", *tm = "time", *tp = "topos", *gt = "get",
2090 *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
2091 *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
2092 *com = "command", *length = "length", *st = "status",
2093 *val = "value", *num = "number", *name = "name",
2094 *trim_name = "trim_name", *ut = "unit";
2095
2096 int di, dr, dc, dl;
2097
2098 di = gfc_default_integer_kind;
2099 dr = gfc_default_real_kind;
2100 dc = gfc_default_character_kind;
2101 dl = gfc_default_logical_kind;
2102
2103 add_sym_0s ("abort", 1, GFC_STD_GNU, NULL);
2104
2105 add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2106 gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
2107 tm, BT_REAL, dr, REQUIRED);
2108
2109 /* More G77 compatibility garbage. */
2110 add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2111 gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2112 tm, BT_REAL, dr, REQUIRED);
2113
2114 add_sym_2s ("chdir", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2115 gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
2116 name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2117
2118 add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2119 gfc_check_date_and_time, NULL, NULL,
2120 dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
2121 zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
2122
2123 /* More G77 compatibility garbage. */
2124 add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2125 gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2126 vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2127
2128 add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2129 gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
2130 vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2131
2132 add_sym_1s ("gerror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2133 gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
2134 dc, REQUIRED);
2135
2136 add_sym_2s ("getcwd", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2137 gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2138 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2139
2140 add_sym_2s ("getenv", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2141 NULL, NULL, NULL,
2142 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
2143
2144 add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2145 NULL, NULL, gfc_resolve_getarg,
2146 c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
2147
2148 add_sym_1s ("getlog", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2149 gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
2150 dc, REQUIRED);
2151
2152 /* F2003 commandline routines. */
2153
2154 add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2155 NULL, NULL, gfc_resolve_get_command,
2156 com, BT_CHARACTER, dc, OPTIONAL, length, BT_INTEGER, di, OPTIONAL,
2157 st, BT_INTEGER, di, OPTIONAL);
2158
2159 add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2160 NULL, NULL, gfc_resolve_get_command_argument,
2161 num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2162 length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
2163
2164 /* F2003 subroutine to get environment variables. */
2165
2166 add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
2167 NULL, NULL, gfc_resolve_get_environment_variable,
2168 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2169 length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2170 trim_name, BT_LOGICAL, dl, OPTIONAL);
2171
2172 add_sym_5s ("mvbits", 1, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2173 gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2174 f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2175 ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
2176 tp, BT_INTEGER, di, REQUIRED);
2177
2178 add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2179 gfc_check_random_number, NULL, gfc_resolve_random_number,
2180 h, BT_REAL, dr, REQUIRED);
2181
2182 add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2183 gfc_check_random_seed, NULL, NULL,
2184 sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
2185 gt, BT_INTEGER, di, OPTIONAL);
2186
2187 /* More G77 compatibility garbage. */
2188 add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di, GFC_STD_GNU,
2189 gfc_check_srand, NULL, gfc_resolve_srand,
2190 c, BT_INTEGER, 4, REQUIRED);
2191
2192 add_sym_1s ("exit", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2193 gfc_check_exit, NULL, gfc_resolve_exit,
2194 c, BT_INTEGER, di, OPTIONAL);
2195
2196 add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2197 gfc_check_flush, NULL, gfc_resolve_flush,
2198 c, BT_INTEGER, di, OPTIONAL);
2199
2200 add_sym_2s ("hostnm", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2201 gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
2202 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2203
2204 add_sym_3s ("kill", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
2205 NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
2206 val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2207
2208 add_sym_3s ("link", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2209 gfc_check_link_sub, NULL, gfc_resolve_link_sub,
2210 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2211 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2212
2213 add_sym_1s ("perror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2214 gfc_check_perror, NULL, gfc_resolve_perror,
2215 c, BT_CHARACTER, dc, REQUIRED);
2216
2217 add_sym_3s ("rename", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2218 gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
2219 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2220 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2221
2222 add_sym_1s ("sleep", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2223 gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
2224 val, BT_CHARACTER, dc, REQUIRED);
2225
2226 add_sym_3s ("fstat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2227 gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2228 ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2229 st, BT_INTEGER, di, OPTIONAL);
2230
2231 add_sym_3s ("stat", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2232 gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2233 name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2234 st, BT_INTEGER, di, OPTIONAL);
2235
2236 add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2237 gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
2238 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2239 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2240
2241 add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2242 NULL, NULL, gfc_resolve_system_sub,
2243 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2244
2245 add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
2246 gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2247 c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
2248 cm, BT_INTEGER, di, OPTIONAL);
2249
2250 add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2251 gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2252 val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
2253
2254 add_sym_2s ("unlink", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
2255 gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2256 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2257
2258 }
2259
2260
2261 /* Add a function to the list of conversion symbols. */
2262
2263 static void
2264 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
2265 {
2266
2267 gfc_typespec from, to;
2268 gfc_intrinsic_sym *sym;
2269
2270 if (sizing == SZ_CONVS)
2271 {
2272 nconv++;
2273 return;
2274 }
2275
2276 gfc_clear_ts (&from);
2277 from.type = from_type;
2278 from.kind = from_kind;
2279
2280 gfc_clear_ts (&to);
2281 to.type = to_type;
2282 to.kind = to_kind;
2283
2284 sym = conversion + nconv;
2285
2286 sym->name = conv_name (&from, &to);
2287 sym->lib_name = sym->name;
2288 sym->simplify.cc = gfc_convert_constant;
2289 sym->standard = standard;
2290 sym->elemental = 1;
2291 sym->ts = to;
2292 sym->generic_id = GFC_ISYM_CONVERSION;
2293
2294 nconv++;
2295 }
2296
2297
2298 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2299 functions by looping over the kind tables. */
2300
2301 static void
2302 add_conversions (void)
2303 {
2304 int i, j;
2305
2306 /* Integer-Integer conversions. */
2307 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2308 for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2309 {
2310 if (i == j)
2311 continue;
2312
2313 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2314 BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
2315 }
2316
2317 /* Integer-Real/Complex conversions. */
2318 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2319 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2320 {
2321 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2322 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2323
2324 add_conv (BT_REAL, gfc_real_kinds[j].kind,
2325 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2326
2327 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2328 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2329
2330 add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2331 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2332 }
2333
2334 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2335 {
2336 /* Hollerith-Integer conversions. */
2337 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2338 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2339 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2340 /* Hollerith-Real conversions. */
2341 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2342 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2343 BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2344 /* Hollerith-Complex conversions. */
2345 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2346 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2347 BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2348
2349 /* Hollerith-Character conversions. */
2350 add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
2351 gfc_default_character_kind, GFC_STD_LEGACY);
2352
2353 /* Hollerith-Logical conversions. */
2354 for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
2355 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2356 BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
2357 }
2358
2359 /* Real/Complex - Real/Complex conversions. */
2360 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2361 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2362 {
2363 if (i != j)
2364 {
2365 add_conv (BT_REAL, gfc_real_kinds[i].kind,
2366 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2367
2368 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2369 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2370 }
2371
2372 add_conv (BT_REAL, gfc_real_kinds[i].kind,
2373 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2374
2375 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2376 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2377 }
2378
2379 /* Logical/Logical kind conversion. */
2380 for (i = 0; gfc_logical_kinds[i].kind; i++)
2381 for (j = 0; gfc_logical_kinds[j].kind; j++)
2382 {
2383 if (i == j)
2384 continue;
2385
2386 add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2387 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
2388 }
2389
2390 /* Integer-Logical and Logical-Integer conversions. */
2391 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2392 for (i=0; gfc_integer_kinds[i].kind; i++)
2393 for (j=0; gfc_logical_kinds[j].kind; j++)
2394 {
2395 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2396 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
2397 add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
2398 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2399 }
2400 }
2401
2402
2403 /* Initialize the table of intrinsics. */
2404 void
2405 gfc_intrinsic_init_1 (void)
2406 {
2407 int i;
2408
2409 nargs = nfunc = nsub = nconv = 0;
2410
2411 /* Create a namespace to hold the resolved intrinsic symbols. */
2412 gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2413
2414 sizing = SZ_FUNCS;
2415 add_functions ();
2416 sizing = SZ_SUBS;
2417 add_subroutines ();
2418 sizing = SZ_CONVS;
2419 add_conversions ();
2420
2421 functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2422 + sizeof (gfc_intrinsic_arg) * nargs);
2423
2424 next_sym = functions;
2425 subroutines = functions + nfunc;
2426
2427 conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2428
2429 next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2430
2431 sizing = SZ_NOTHING;
2432 nconv = 0;
2433
2434 add_functions ();
2435 add_subroutines ();
2436 add_conversions ();
2437
2438 /* Set the pure flag. All intrinsic functions are pure, and
2439 intrinsic subroutines are pure if they are elemental. */
2440
2441 for (i = 0; i < nfunc; i++)
2442 functions[i].pure = 1;
2443
2444 for (i = 0; i < nsub; i++)
2445 subroutines[i].pure = subroutines[i].elemental;
2446 }
2447
2448
2449 void
2450 gfc_intrinsic_done_1 (void)
2451 {
2452 gfc_free (functions);
2453 gfc_free (conversion);
2454 gfc_free_namespace (gfc_intrinsic_namespace);
2455 }
2456
2457
2458 /******** Subroutines to check intrinsic interfaces ***********/
2459
2460 /* Given a formal argument list, remove any NULL arguments that may
2461 have been left behind by a sort against some formal argument list. */
2462
2463 static void
2464 remove_nullargs (gfc_actual_arglist ** ap)
2465 {
2466 gfc_actual_arglist *head, *tail, *next;
2467
2468 tail = NULL;
2469
2470 for (head = *ap; head; head = next)
2471 {
2472 next = head->next;
2473
2474 if (head->expr == NULL)
2475 {
2476 head->next = NULL;
2477 gfc_free_actual_arglist (head);
2478 }
2479 else
2480 {
2481 if (tail == NULL)
2482 *ap = head;
2483 else
2484 tail->next = head;
2485
2486 tail = head;
2487 tail->next = NULL;
2488 }
2489 }
2490
2491 if (tail == NULL)
2492 *ap = NULL;
2493 }
2494
2495
2496 /* Given an actual arglist and a formal arglist, sort the actual
2497 arglist so that its arguments are in a one-to-one correspondence
2498 with the format arglist. Arguments that are not present are given
2499 a blank gfc_actual_arglist structure. If something is obviously
2500 wrong (say, a missing required argument) we abort sorting and
2501 return FAILURE. */
2502
2503 static try
2504 sort_actual (const char *name, gfc_actual_arglist ** ap,
2505 gfc_intrinsic_arg * formal, locus * where)
2506 {
2507
2508 gfc_actual_arglist *actual, *a;
2509 gfc_intrinsic_arg *f;
2510
2511 remove_nullargs (ap);
2512 actual = *ap;
2513
2514 for (f = formal; f; f = f->next)
2515 f->actual = NULL;
2516
2517 f = formal;
2518 a = actual;
2519
2520 if (f == NULL && a == NULL) /* No arguments */
2521 return SUCCESS;
2522
2523 for (;;)
2524 { /* Put the nonkeyword arguments in a 1:1 correspondence */
2525 if (f == NULL)
2526 break;
2527 if (a == NULL)
2528 goto optional;
2529
2530 if (a->name != NULL)
2531 goto keywords;
2532
2533 f->actual = a;
2534
2535 f = f->next;
2536 a = a->next;
2537 }
2538
2539 if (a == NULL)
2540 goto do_sort;
2541
2542 gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2543 return FAILURE;
2544
2545 keywords:
2546 /* Associate the remaining actual arguments, all of which have
2547 to be keyword arguments. */
2548 for (; a; a = a->next)
2549 {
2550 for (f = formal; f; f = f->next)
2551 if (strcmp (a->name, f->name) == 0)
2552 break;
2553
2554 if (f == NULL)
2555 {
2556 gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2557 a->name, name, where);
2558 return FAILURE;
2559 }
2560
2561 if (f->actual != NULL)
2562 {
2563 gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2564 f->name, name, where);
2565 return FAILURE;
2566 }
2567
2568 f->actual = a;
2569 }
2570
2571 optional:
2572 /* At this point, all unmatched formal args must be optional. */
2573 for (f = formal; f; f = f->next)
2574 {
2575 if (f->actual == NULL && f->optional == 0)
2576 {
2577 gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2578 f->name, name, where);
2579 return FAILURE;
2580 }
2581 }
2582
2583 do_sort:
2584 /* Using the formal argument list, string the actual argument list
2585 together in a way that corresponds with the formal list. */
2586 actual = NULL;
2587
2588 for (f = formal; f; f = f->next)
2589 {
2590 if (f->actual == NULL)
2591 {
2592 a = gfc_get_actual_arglist ();
2593 a->missing_arg_type = f->ts.type;
2594 }
2595 else
2596 a = f->actual;
2597
2598 if (actual == NULL)
2599 *ap = a;
2600 else
2601 actual->next = a;
2602
2603 actual = a;
2604 }
2605 actual->next = NULL; /* End the sorted argument list. */
2606
2607 return SUCCESS;
2608 }
2609
2610
2611 /* Compare an actual argument list with an intrinsic's formal argument
2612 list. The lists are checked for agreement of type. We don't check
2613 for arrayness here. */
2614
2615 static try
2616 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2617 int error_flag)
2618 {
2619 gfc_actual_arglist *actual;
2620 gfc_intrinsic_arg *formal;
2621 int i;
2622
2623 formal = sym->formal;
2624 actual = *ap;
2625
2626 i = 0;
2627 for (; formal; formal = formal->next, actual = actual->next, i++)
2628 {
2629 if (actual->expr == NULL)
2630 continue;
2631
2632 if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2633 {
2634 if (error_flag)
2635 gfc_error
2636 ("Type of argument '%s' in call to '%s' at %L should be "
2637 "%s, not %s", gfc_current_intrinsic_arg[i],
2638 gfc_current_intrinsic, &actual->expr->where,
2639 gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2640 return FAILURE;
2641 }
2642 }
2643
2644 return SUCCESS;
2645 }
2646
2647
2648 /* Given a pointer to an intrinsic symbol and an expression node that
2649 represent the function call to that subroutine, figure out the type
2650 of the result. This may involve calling a resolution subroutine. */
2651
2652 static void
2653 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2654 {
2655 gfc_expr *a1, *a2, *a3, *a4, *a5;
2656 gfc_actual_arglist *arg;
2657
2658 if (specific->resolve.f1 == NULL)
2659 {
2660 if (e->value.function.name == NULL)
2661 e->value.function.name = specific->lib_name;
2662
2663 if (e->ts.type == BT_UNKNOWN)
2664 e->ts = specific->ts;
2665 return;
2666 }
2667
2668 arg = e->value.function.actual;
2669
2670 /* Special case hacks for MIN and MAX. */
2671 if (specific->resolve.f1m == gfc_resolve_max
2672 || specific->resolve.f1m == gfc_resolve_min)
2673 {
2674 (*specific->resolve.f1m) (e, arg);
2675 return;
2676 }
2677
2678 if (arg == NULL)
2679 {
2680 (*specific->resolve.f0) (e);
2681 return;
2682 }
2683
2684 a1 = arg->expr;
2685 arg = arg->next;
2686
2687 if (arg == NULL)
2688 {
2689 (*specific->resolve.f1) (e, a1);
2690 return;
2691 }
2692
2693 a2 = arg->expr;
2694 arg = arg->next;
2695
2696 if (arg == NULL)
2697 {
2698 (*specific->resolve.f2) (e, a1, a2);
2699 return;
2700 }
2701
2702 a3 = arg->expr;
2703 arg = arg->next;
2704
2705 if (arg == NULL)
2706 {
2707 (*specific->resolve.f3) (e, a1, a2, a3);
2708 return;
2709 }
2710
2711 a4 = arg->expr;
2712 arg = arg->next;
2713
2714 if (arg == NULL)
2715 {
2716 (*specific->resolve.f4) (e, a1, a2, a3, a4);
2717 return;
2718 }
2719
2720 a5 = arg->expr;
2721 arg = arg->next;
2722
2723 if (arg == NULL)
2724 {
2725 (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2726 return;
2727 }
2728
2729 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2730 }
2731
2732
2733 /* Given an intrinsic symbol node and an expression node, call the
2734 simplification function (if there is one), perhaps replacing the
2735 expression with something simpler. We return FAILURE on an error
2736 of the simplification, SUCCESS if the simplification worked, even
2737 if nothing has changed in the expression itself. */
2738
2739 static try
2740 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2741 {
2742 gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2743 gfc_actual_arglist *arg;
2744
2745 /* Check the arguments if there are Hollerith constants. We deal with
2746 them at run-time. */
2747 for (arg = e->value.function.actual; arg != NULL; arg = arg->next)
2748 {
2749 if (arg->expr && arg->expr->from_H)
2750 {
2751 result = NULL;
2752 goto finish;
2753 }
2754 }
2755 /* Max and min require special handling due to the variable number
2756 of args. */
2757 if (specific->simplify.f1 == gfc_simplify_min)
2758 {
2759 result = gfc_simplify_min (e);
2760 goto finish;
2761 }
2762
2763 if (specific->simplify.f1 == gfc_simplify_max)
2764 {
2765 result = gfc_simplify_max (e);
2766 goto finish;
2767 }
2768
2769 if (specific->simplify.f1 == NULL)
2770 {
2771 result = NULL;
2772 goto finish;
2773 }
2774
2775 arg = e->value.function.actual;
2776
2777 if (arg == NULL)
2778 {
2779 result = (*specific->simplify.f0) ();
2780 goto finish;
2781 }
2782
2783 a1 = arg->expr;
2784 arg = arg->next;
2785
2786 if (specific->simplify.cc == gfc_convert_constant)
2787 {
2788 result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2789 goto finish;
2790 }
2791
2792 /* TODO: Warn if -pedantic and initialization expression and arg
2793 types not integer or character */
2794
2795 if (arg == NULL)
2796 result = (*specific->simplify.f1) (a1);
2797 else
2798 {
2799 a2 = arg->expr;
2800 arg = arg->next;
2801
2802 if (arg == NULL)
2803 result = (*specific->simplify.f2) (a1, a2);
2804 else
2805 {
2806 a3 = arg->expr;
2807 arg = arg->next;
2808
2809 if (arg == NULL)
2810 result = (*specific->simplify.f3) (a1, a2, a3);
2811 else
2812 {
2813 a4 = arg->expr;
2814 arg = arg->next;
2815
2816 if (arg == NULL)
2817 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2818 else
2819 {
2820 a5 = arg->expr;
2821 arg = arg->next;
2822
2823 if (arg == NULL)
2824 result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
2825 else
2826 gfc_internal_error
2827 ("do_simplify(): Too many args for intrinsic");
2828 }
2829 }
2830 }
2831 }
2832
2833 finish:
2834 if (result == &gfc_bad_expr)
2835 return FAILURE;
2836
2837 if (result == NULL)
2838 resolve_intrinsic (specific, e); /* Must call at run-time */
2839 else
2840 {
2841 result->where = e->where;
2842 gfc_replace_expr (e, result);
2843 }
2844
2845 return SUCCESS;
2846 }
2847
2848
2849 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2850 error messages. This subroutine returns FAILURE if a subroutine
2851 has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2852 list cannot match any intrinsic. */
2853
2854 static void
2855 init_arglist (gfc_intrinsic_sym * isym)
2856 {
2857 gfc_intrinsic_arg *formal;
2858 int i;
2859
2860 gfc_current_intrinsic = isym->name;
2861
2862 i = 0;
2863 for (formal = isym->formal; formal; formal = formal->next)
2864 {
2865 if (i >= MAX_INTRINSIC_ARGS)
2866 gfc_internal_error ("init_arglist(): too many arguments");
2867 gfc_current_intrinsic_arg[i++] = formal->name;
2868 }
2869 }
2870
2871
2872 /* Given a pointer to an intrinsic symbol and an expression consisting
2873 of a function call, see if the function call is consistent with the
2874 intrinsic's formal argument list. Return SUCCESS if the expression
2875 and intrinsic match, FAILURE otherwise. */
2876
2877 static try
2878 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
2879 {
2880 gfc_actual_arglist *arg, **ap;
2881 int r;
2882 try t;
2883
2884 ap = &expr->value.function.actual;
2885
2886 init_arglist (specific);
2887
2888 /* Don't attempt to sort the argument list for min or max. */
2889 if (specific->check.f1m == gfc_check_min_max
2890 || specific->check.f1m == gfc_check_min_max_integer
2891 || specific->check.f1m == gfc_check_min_max_real
2892 || specific->check.f1m == gfc_check_min_max_double)
2893 return (*specific->check.f1m) (*ap);
2894
2895 if (sort_actual (specific->name, ap, specific->formal,
2896 &expr->where) == FAILURE)
2897 return FAILURE;
2898
2899 if (specific->check.f3ml == gfc_check_minloc_maxloc)
2900 /* This is special because we might have to reorder the argument
2901 list. */
2902 t = gfc_check_minloc_maxloc (*ap);
2903 else if (specific->check.f3red == gfc_check_minval_maxval)
2904 /* This is also special because we also might have to reorder the
2905 argument list. */
2906 t = gfc_check_minval_maxval (*ap);
2907 else if (specific->check.f3red == gfc_check_product_sum)
2908 /* Same here. The difference to the previous case is that we allow a
2909 general numeric type. */
2910 t = gfc_check_product_sum (*ap);
2911 else
2912 {
2913 if (specific->check.f1 == NULL)
2914 {
2915 t = check_arglist (ap, specific, error_flag);
2916 if (t == SUCCESS)
2917 expr->ts = specific->ts;
2918 }
2919 else
2920 t = do_check (specific, *ap);
2921 }
2922
2923 /* Check ranks for elemental intrinsics. */
2924 if (t == SUCCESS && specific->elemental)
2925 {
2926 r = 0;
2927 for (arg = expr->value.function.actual; arg; arg = arg->next)
2928 {
2929 if (arg->expr == NULL || arg->expr->rank == 0)
2930 continue;
2931 if (r == 0)
2932 {
2933 r = arg->expr->rank;
2934 continue;
2935 }
2936
2937 if (arg->expr->rank != r)
2938 {
2939 gfc_error
2940 ("Ranks of arguments to elemental intrinsic '%s' differ "
2941 "at %L", specific->name, &arg->expr->where);
2942 return FAILURE;
2943 }
2944 }
2945 }
2946
2947 if (t == FAILURE)
2948 remove_nullargs (ap);
2949
2950 return t;
2951 }
2952
2953
2954 /* See if an intrinsic is one of the intrinsics we evaluate
2955 as an extension. */
2956
2957 static int
2958 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
2959 {
2960 /* FIXME: This should be moved into the intrinsic definitions. */
2961 static const char * const init_expr_extensions[] = {
2962 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2963 "precision", "present", "radix", "range", "selected_real_kind",
2964 "tiny", NULL
2965 };
2966
2967 int i;
2968
2969 for (i = 0; init_expr_extensions[i]; i++)
2970 if (strcmp (init_expr_extensions[i], isym->name) == 0)
2971 return 0;
2972
2973 return 1;
2974 }
2975
2976
2977 /* Check whether an intrinsic belongs to whatever standard the user
2978 has chosen. */
2979
2980 static void
2981 check_intrinsic_standard (const char *name, int standard, locus * where)
2982 {
2983 if (!gfc_option.warn_nonstd_intrinsics)
2984 return;
2985
2986 gfc_notify_std (standard, "Intrinsic '%s' at %L is not included "
2987 "in the selected standard", name, where);
2988 }
2989
2990
2991 /* See if a function call corresponds to an intrinsic function call.
2992 We return:
2993
2994 MATCH_YES if the call corresponds to an intrinsic, simplification
2995 is done if possible.
2996
2997 MATCH_NO if the call does not correspond to an intrinsic
2998
2999 MATCH_ERROR if the call corresponds to an intrinsic but there was an
3000 error during the simplification process.
3001
3002 The error_flag parameter enables an error reporting. */
3003
3004 match
3005 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
3006 {
3007 gfc_intrinsic_sym *isym, *specific;
3008 gfc_actual_arglist *actual;
3009 const char *name;
3010 int flag;
3011
3012 if (expr->value.function.isym != NULL)
3013 return (do_simplify (expr->value.function.isym, expr) == FAILURE)
3014 ? MATCH_ERROR : MATCH_YES;
3015
3016 gfc_suppress_error = !error_flag;
3017 flag = 0;
3018
3019 for (actual = expr->value.function.actual; actual; actual = actual->next)
3020 if (actual->expr != NULL)
3021 flag |= (actual->expr->ts.type != BT_INTEGER
3022 && actual->expr->ts.type != BT_CHARACTER);
3023
3024 name = expr->symtree->n.sym->name;
3025
3026 isym = specific = gfc_find_function (name);
3027 if (isym == NULL)
3028 {
3029 gfc_suppress_error = 0;
3030 return MATCH_NO;
3031 }
3032
3033 gfc_current_intrinsic_where = &expr->where;
3034
3035 /* Bypass the generic list for min and max. */
3036 if (isym->check.f1m == gfc_check_min_max)
3037 {
3038 init_arglist (isym);
3039
3040 if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
3041 goto got_specific;
3042
3043 gfc_suppress_error = 0;
3044 return MATCH_NO;
3045 }
3046
3047 /* If the function is generic, check all of its specific
3048 incarnations. If the generic name is also a specific, we check
3049 that name last, so that any error message will correspond to the
3050 specific. */
3051 gfc_suppress_error = 1;
3052
3053 if (isym->generic)
3054 {
3055 for (specific = isym->specific_head; specific;
3056 specific = specific->next)
3057 {
3058 if (specific == isym)
3059 continue;
3060 if (check_specific (specific, expr, 0) == SUCCESS)
3061 goto got_specific;
3062 }
3063 }
3064
3065 gfc_suppress_error = !error_flag;
3066
3067 if (check_specific (isym, expr, error_flag) == FAILURE)
3068 {
3069 gfc_suppress_error = 0;
3070 return MATCH_NO;
3071 }
3072
3073 specific = isym;
3074
3075 got_specific:
3076 expr->value.function.isym = specific;
3077 gfc_intrinsic_symbol (expr->symtree->n.sym);
3078
3079 gfc_suppress_error = 0;
3080 if (do_simplify (specific, expr) == FAILURE)
3081 return MATCH_ERROR;
3082
3083 /* TODO: We should probably only allow elemental functions here. */
3084 flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
3085
3086 if (pedantic && gfc_init_expr
3087 && flag && gfc_init_expr_extensions (specific))
3088 {
3089 if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
3090 "nonstandard initialization expression at %L", &expr->where)
3091 == FAILURE)
3092 {
3093 return MATCH_ERROR;
3094 }
3095 }
3096
3097 check_intrinsic_standard (name, isym->standard, &expr->where);
3098
3099 return MATCH_YES;
3100 }
3101
3102
3103 /* See if a CALL statement corresponds to an intrinsic subroutine.
3104 Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3105 MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3106 correspond). */
3107
3108 match
3109 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
3110 {
3111 gfc_intrinsic_sym *isym;
3112 const char *name;
3113
3114 name = c->symtree->n.sym->name;
3115
3116 isym = find_subroutine (name);
3117 if (isym == NULL)
3118 return MATCH_NO;
3119
3120 gfc_suppress_error = !error_flag;
3121
3122 init_arglist (isym);
3123
3124 if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3125 goto fail;
3126
3127 if (isym->check.f1 != NULL)
3128 {
3129 if (do_check (isym, c->ext.actual) == FAILURE)
3130 goto fail;
3131 }
3132 else
3133 {
3134 if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3135 goto fail;
3136 }
3137
3138 /* The subroutine corresponds to an intrinsic. Allow errors to be
3139 seen at this point. */
3140 gfc_suppress_error = 0;
3141
3142 if (isym->resolve.s1 != NULL)
3143 isym->resolve.s1 (c);
3144 else
3145 c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3146
3147 if (gfc_pure (NULL) && !isym->elemental)
3148 {
3149 gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3150 &c->loc);
3151 return MATCH_ERROR;
3152 }
3153
3154 check_intrinsic_standard (name, isym->standard, &c->loc);
3155
3156 return MATCH_YES;
3157
3158 fail:
3159 gfc_suppress_error = 0;
3160 return MATCH_NO;
3161 }
3162
3163
3164 /* Call gfc_convert_type() with warning enabled. */
3165
3166 try
3167 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
3168 {
3169 return gfc_convert_type_warn (expr, ts, eflag, 1);
3170 }
3171
3172
3173 /* Try to convert an expression (in place) from one type to another.
3174 'eflag' controls the behavior on error.
3175
3176 The possible values are:
3177
3178 1 Generate a gfc_error()
3179 2 Generate a gfc_internal_error().
3180
3181 'wflag' controls the warning related to conversion. */
3182
3183 try
3184 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
3185 int wflag)
3186 {
3187 gfc_intrinsic_sym *sym;
3188 gfc_typespec from_ts;
3189 locus old_where;
3190 gfc_expr *new;
3191 int rank;
3192 mpz_t *shape;
3193
3194 from_ts = expr->ts; /* expr->ts gets clobbered */
3195
3196 if (ts->type == BT_UNKNOWN)
3197 goto bad;
3198
3199 /* NULL and zero size arrays get their type here. */
3200 if (expr->expr_type == EXPR_NULL
3201 || (expr->expr_type == EXPR_ARRAY
3202 && expr->value.constructor == NULL))
3203 {
3204 /* Sometimes the RHS acquire the type. */
3205 expr->ts = *ts;
3206 return SUCCESS;
3207 }
3208
3209 if (expr->ts.type == BT_UNKNOWN)
3210 goto bad;
3211
3212 if (expr->ts.type == BT_DERIVED
3213 && ts->type == BT_DERIVED
3214 && gfc_compare_types (&expr->ts, ts))
3215 return SUCCESS;
3216
3217 sym = find_conv (&expr->ts, ts);
3218 if (sym == NULL)
3219 goto bad;
3220
3221 /* At this point, a conversion is necessary. A warning may be needed. */
3222 if ((gfc_option.warn_std & sym->standard) != 0)
3223 gfc_warning_now ("Extension: Conversion from %s to %s at %L",
3224 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3225 else if (wflag && gfc_option.warn_conversion)
3226 gfc_warning_now ("Conversion from %s to %s at %L",
3227 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3228
3229 /* Insert a pre-resolved function call to the right function. */
3230 old_where = expr->where;
3231 rank = expr->rank;
3232 shape = expr->shape;
3233
3234 new = gfc_get_expr ();
3235 *new = *expr;
3236
3237 new = gfc_build_conversion (new);
3238 new->value.function.name = sym->lib_name;
3239 new->value.function.isym = sym;
3240 new->where = old_where;
3241 new->rank = rank;
3242 new->shape = gfc_copy_shape (shape, rank);
3243
3244 *expr = *new;
3245
3246 gfc_free (new);
3247 expr->ts = *ts;
3248
3249 if (gfc_is_constant_expr (expr->value.function.actual->expr)
3250 && do_simplify (sym, expr) == FAILURE)
3251 {
3252
3253 if (eflag == 2)
3254 goto bad;
3255 return FAILURE; /* Error already generated in do_simplify() */
3256 }
3257
3258 return SUCCESS;
3259
3260 bad:
3261 if (eflag == 1)
3262 {
3263 gfc_error ("Can't convert %s to %s at %L",
3264 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3265 return FAILURE;
3266 }
3267
3268 gfc_internal_error ("Can't convert %s to %s at %L",
3269 gfc_typename (&from_ts), gfc_typename (ts),
3270 &expr->where);
3271 /* Not reached */
3272 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org