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