?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2005-05-19 Paul Brook <paul@codesourcery.com>
[official-gcc.git] / gcc / fortran / intrinsic.c
blob0b50cdcaa11151be389fd0eaea66dac98bf3e66e
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,
2231 gfc_expr * (*simplify) (gfc_expr *, bt, int))
2232 {
2233
2234 gfc_typespec from, to;
2235 gfc_intrinsic_sym *sym;
2236
2237 if (sizing == SZ_CONVS)
2238 {
2239 nconv++;
2240 return;
2241 }
2242
2243 gfc_clear_ts (&from);
2244 from.type = from_type;
2245 from.kind = from_kind;
2246
2247 gfc_clear_ts (&to);
2248 to.type = to_type;
2249 to.kind = to_kind;
2250
2251 sym = conversion + nconv;
2252
2253 sym->name = conv_name (&from, &to);
2254 sym->lib_name = sym->name;
2255 sym->simplify.cc = simplify;
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_convert_constant);
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_convert_constant);
2289
2290 add_conv (BT_REAL, gfc_real_kinds[j].kind,
2291 BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
2292
2293 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2294 BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2295
2296 add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2297 BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
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_convert_constant);
2308
2309 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2310 BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2311 }
2312
2313 add_conv (BT_REAL, gfc_real_kinds[i].kind,
2314 BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
2315
2316 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2317 BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
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_convert_constant);
2329 }
2330 }
2331
2332
2333 /* Initialize the table of intrinsics. */
2334 void
2335 gfc_intrinsic_init_1 (void)
2336 {
2337 int i;
2338
2339 nargs = nfunc = nsub = nconv = 0;
2340
2341 /* Create a namespace to hold the resolved intrinsic symbols. */
2342 gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2343
2344 sizing = SZ_FUNCS;
2345 add_functions ();
2346 sizing = SZ_SUBS;
2347 add_subroutines ();
2348 sizing = SZ_CONVS;
2349 add_conversions ();
2350
2351 functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2352 + sizeof (gfc_intrinsic_arg) * nargs);
2353
2354 next_sym = functions;
2355 subroutines = functions + nfunc;
2356
2357 conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2358
2359 next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2360
2361 sizing = SZ_NOTHING;
2362 nconv = 0;
2363
2364 add_functions ();
2365 add_subroutines ();
2366 add_conversions ();
2367
2368 /* Set the pure flag. All intrinsic functions are pure, and
2369 intrinsic subroutines are pure if they are elemental. */
2370
2371 for (i = 0; i < nfunc; i++)
2372 functions[i].pure = 1;
2373
2374 for (i = 0; i < nsub; i++)
2375 subroutines[i].pure = subroutines[i].elemental;
2376 }
2377
2378
2379 void
2380 gfc_intrinsic_done_1 (void)
2381 {
2382 gfc_free (functions);
2383 gfc_free (conversion);
2384 gfc_free_namespace (gfc_intrinsic_namespace);
2385 }
2386
2387
2388 /******** Subroutines to check intrinsic interfaces ***********/
2389
2390 /* Given a formal argument list, remove any NULL arguments that may
2391 have been left behind by a sort against some formal argument list. */
2392
2393 static void
2394 remove_nullargs (gfc_actual_arglist ** ap)
2395 {
2396 gfc_actual_arglist *head, *tail, *next;
2397
2398 tail = NULL;
2399
2400 for (head = *ap; head; head = next)
2401 {
2402 next = head->next;
2403
2404 if (head->expr == NULL)
2405 {
2406 head->next = NULL;
2407 gfc_free_actual_arglist (head);
2408 }
2409 else
2410 {
2411 if (tail == NULL)
2412 *ap = head;
2413 else
2414 tail->next = head;
2415
2416 tail = head;
2417 tail->next = NULL;
2418 }
2419 }
2420
2421 if (tail == NULL)
2422 *ap = NULL;
2423 }
2424
2425
2426 /* Given an actual arglist and a formal arglist, sort the actual
2427 arglist so that its arguments are in a one-to-one correspondence
2428 with the format arglist. Arguments that are not present are given
2429 a blank gfc_actual_arglist structure. If something is obviously
2430 wrong (say, a missing required argument) we abort sorting and
2431 return FAILURE. */
2432
2433 static try
2434 sort_actual (const char *name, gfc_actual_arglist ** ap,
2435 gfc_intrinsic_arg * formal, locus * where)
2436 {
2437
2438 gfc_actual_arglist *actual, *a;
2439 gfc_intrinsic_arg *f;
2440
2441 remove_nullargs (ap);
2442 actual = *ap;
2443
2444 for (f = formal; f; f = f->next)
2445 f->actual = NULL;
2446
2447 f = formal;
2448 a = actual;
2449
2450 if (f == NULL && a == NULL) /* No arguments */
2451 return SUCCESS;
2452
2453 for (;;)
2454 { /* Put the nonkeyword arguments in a 1:1 correspondence */
2455 if (f == NULL)
2456 break;
2457 if (a == NULL)
2458 goto optional;
2459
2460 if (a->name != NULL)
2461 goto keywords;
2462
2463 f->actual = a;
2464
2465 f = f->next;
2466 a = a->next;
2467 }
2468
2469 if (a == NULL)
2470 goto do_sort;
2471
2472 gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2473 return FAILURE;
2474
2475 keywords:
2476 /* Associate the remaining actual arguments, all of which have
2477 to be keyword arguments. */
2478 for (; a; a = a->next)
2479 {
2480 for (f = formal; f; f = f->next)
2481 if (strcmp (a->name, f->name) == 0)
2482 break;
2483
2484 if (f == NULL)
2485 {
2486 gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2487 a->name, name, where);
2488 return FAILURE;
2489 }
2490
2491 if (f->actual != NULL)
2492 {
2493 gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2494 f->name, name, where);
2495 return FAILURE;
2496 }
2497
2498 f->actual = a;
2499 }
2500
2501 optional:
2502 /* At this point, all unmatched formal args must be optional. */
2503 for (f = formal; f; f = f->next)
2504 {
2505 if (f->actual == NULL && f->optional == 0)
2506 {
2507 gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2508 f->name, name, where);
2509 return FAILURE;
2510 }
2511 }
2512
2513 do_sort:
2514 /* Using the formal argument list, string the actual argument list
2515 together in a way that corresponds with the formal list. */
2516 actual = NULL;
2517
2518 for (f = formal; f; f = f->next)
2519 {
2520 if (f->actual == NULL)
2521 {
2522 a = gfc_get_actual_arglist ();
2523 a->missing_arg_type = f->ts.type;
2524 }
2525 else
2526 a = f->actual;
2527
2528 if (actual == NULL)
2529 *ap = a;
2530 else
2531 actual->next = a;
2532
2533 actual = a;
2534 }
2535 actual->next = NULL; /* End the sorted argument list. */
2536
2537 return SUCCESS;
2538 }
2539
2540
2541 /* Compare an actual argument list with an intrinsic's formal argument
2542 list. The lists are checked for agreement of type. We don't check
2543 for arrayness here. */
2544
2545 static try
2546 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2547 int error_flag)
2548 {
2549 gfc_actual_arglist *actual;
2550 gfc_intrinsic_arg *formal;
2551 int i;
2552
2553 formal = sym->formal;
2554 actual = *ap;
2555
2556 i = 0;
2557 for (; formal; formal = formal->next, actual = actual->next, i++)
2558 {
2559 if (actual->expr == NULL)
2560 continue;
2561
2562 if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2563 {
2564 if (error_flag)
2565 gfc_error
2566 ("Type of argument '%s' in call to '%s' at %L should be "
2567 "%s, not %s", gfc_current_intrinsic_arg[i],
2568 gfc_current_intrinsic, &actual->expr->where,
2569 gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2570 return FAILURE;
2571 }
2572 }
2573
2574 return SUCCESS;
2575 }
2576
2577
2578 /* Given a pointer to an intrinsic symbol and an expression node that
2579 represent the function call to that subroutine, figure out the type
2580 of the result. This may involve calling a resolution subroutine. */
2581
2582 static void
2583 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2584 {
2585 gfc_expr *a1, *a2, *a3, *a4, *a5;
2586 gfc_actual_arglist *arg;
2587
2588 if (specific->resolve.f1 == NULL)
2589 {
2590 if (e->value.function.name == NULL)
2591 e->value.function.name = specific->lib_name;
2592
2593 if (e->ts.type == BT_UNKNOWN)
2594 e->ts = specific->ts;
2595 return;
2596 }
2597
2598 arg = e->value.function.actual;
2599
2600 /* Special case hacks for MIN and MAX. */
2601 if (specific->resolve.f1m == gfc_resolve_max
2602 || specific->resolve.f1m == gfc_resolve_min)
2603 {
2604 (*specific->resolve.f1m) (e, arg);
2605 return;
2606 }
2607
2608 if (arg == NULL)
2609 {
2610 (*specific->resolve.f0) (e);
2611 return;
2612 }
2613
2614 a1 = arg->expr;
2615 arg = arg->next;
2616
2617 if (arg == NULL)
2618 {
2619 (*specific->resolve.f1) (e, a1);
2620 return;
2621 }
2622
2623 a2 = arg->expr;
2624 arg = arg->next;
2625
2626 if (arg == NULL)
2627 {
2628 (*specific->resolve.f2) (e, a1, a2);
2629 return;
2630 }
2631
2632 a3 = arg->expr;
2633 arg = arg->next;
2634
2635 if (arg == NULL)
2636 {
2637 (*specific->resolve.f3) (e, a1, a2, a3);
2638 return;
2639 }
2640
2641 a4 = arg->expr;
2642 arg = arg->next;
2643
2644 if (arg == NULL)
2645 {
2646 (*specific->resolve.f4) (e, a1, a2, a3, a4);
2647 return;
2648 }
2649
2650 a5 = arg->expr;
2651 arg = arg->next;
2652
2653 if (arg == NULL)
2654 {
2655 (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2656 return;
2657 }
2658
2659 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2660 }
2661
2662
2663 /* Given an intrinsic symbol node and an expression node, call the
2664 simplification function (if there is one), perhaps replacing the
2665 expression with something simpler. We return FAILURE on an error
2666 of the simplification, SUCCESS if the simplification worked, even
2667 if nothing has changed in the expression itself. */
2668
2669 static try
2670 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2671 {
2672 gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2673 gfc_actual_arglist *arg;
2674
2675 /* Max and min require special handling due to the variable number
2676 of args. */
2677 if (specific->simplify.f1 == gfc_simplify_min)
2678 {
2679 result = gfc_simplify_min (e);
2680 goto finish;
2681 }
2682
2683 if (specific->simplify.f1 == gfc_simplify_max)
2684 {
2685 result = gfc_simplify_max (e);
2686 goto finish;
2687 }
2688
2689 if (specific->simplify.f1 == NULL)
2690 {
2691 result = NULL;
2692 goto finish;
2693 }
2694
2695 arg = e->value.function.actual;
2696
2697 if (arg == NULL)
2698 {
2699 result = (*specific->simplify.f0) ();
2700 goto finish;
2701 }
2702
2703 a1 = arg->expr;
2704 arg = arg->next;
2705
2706 if (specific->simplify.cc == gfc_convert_constant)
2707 {
2708 result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2709 goto finish;
2710 }
2711
2712 /* TODO: Warn if -pedantic and initialization expression and arg
2713 types not integer or character */
2714
2715 if (arg == NULL)
2716 result = (*specific->simplify.f1) (a1);
2717 else
2718 {
2719 a2 = arg->expr;
2720 arg = arg->next;
2721
2722 if (arg == NULL)
2723 result = (*specific->simplify.f2) (a1, a2);
2724 else
2725 {
2726 a3 = arg->expr;
2727 arg = arg->next;
2728
2729 if (arg == NULL)
2730 result = (*specific->simplify.f3) (a1, a2, a3);
2731 else
2732 {
2733 a4 = arg->expr;
2734 arg = arg->next;
2735
2736 if (arg == NULL)
2737 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2738 else
2739 {
2740 a5 = arg->expr;
2741 arg = arg->next;
2742
2743 if (arg == NULL)
2744 result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
2745 else
2746 gfc_internal_error
2747 ("do_simplify(): Too many args for intrinsic");
2748 }
2749 }
2750 }
2751 }
2752
2753 finish:
2754 if (result == &gfc_bad_expr)
2755 return FAILURE;
2756
2757 if (result == NULL)
2758 resolve_intrinsic (specific, e); /* Must call at run-time */
2759 else
2760 {
2761 result->where = e->where;
2762 gfc_replace_expr (e, result);
2763 }
2764
2765 return SUCCESS;
2766 }
2767
2768
2769 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2770 error messages. This subroutine returns FAILURE if a subroutine
2771 has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2772 list cannot match any intrinsic. */
2773
2774 static void
2775 init_arglist (gfc_intrinsic_sym * isym)
2776 {
2777 gfc_intrinsic_arg *formal;
2778 int i;
2779
2780 gfc_current_intrinsic = isym->name;
2781
2782 i = 0;
2783 for (formal = isym->formal; formal; formal = formal->next)
2784 {
2785 if (i >= MAX_INTRINSIC_ARGS)
2786 gfc_internal_error ("init_arglist(): too many arguments");
2787 gfc_current_intrinsic_arg[i++] = formal->name;
2788 }
2789 }
2790
2791
2792 /* Given a pointer to an intrinsic symbol and an expression consisting
2793 of a function call, see if the function call is consistent with the
2794 intrinsic's formal argument list. Return SUCCESS if the expression
2795 and intrinsic match, FAILURE otherwise. */
2796
2797 static try
2798 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
2799 {
2800 gfc_actual_arglist *arg, **ap;
2801 int r;
2802 try t;
2803
2804 ap = &expr->value.function.actual;
2805
2806 init_arglist (specific);
2807
2808 /* Don't attempt to sort the argument list for min or max. */
2809 if (specific->check.f1m == gfc_check_min_max
2810 || specific->check.f1m == gfc_check_min_max_integer
2811 || specific->check.f1m == gfc_check_min_max_real
2812 || specific->check.f1m == gfc_check_min_max_double)
2813 return (*specific->check.f1m) (*ap);
2814
2815 if (sort_actual (specific->name, ap, specific->formal,
2816 &expr->where) == FAILURE)
2817 return FAILURE;
2818
2819 if (specific->check.f3ml == gfc_check_minloc_maxloc)
2820 /* This is special because we might have to reorder the argument
2821 list. */
2822 t = gfc_check_minloc_maxloc (*ap);
2823 else if (specific->check.f3red == gfc_check_minval_maxval)
2824 /* This is also special because we also might have to reorder the
2825 argument list. */
2826 t = gfc_check_minval_maxval (*ap);
2827 else if (specific->check.f3red == gfc_check_product_sum)
2828 /* Same here. The difference to the previous case is that we allow a
2829 general numeric type. */
2830 t = gfc_check_product_sum (*ap);
2831 else
2832 {
2833 if (specific->check.f1 == NULL)
2834 {
2835 t = check_arglist (ap, specific, error_flag);
2836 if (t == SUCCESS)
2837 expr->ts = specific->ts;
2838 }
2839 else
2840 t = do_check (specific, *ap);
2841 }
2842
2843 /* Check ranks for elemental intrinsics. */
2844 if (t == SUCCESS && specific->elemental)
2845 {
2846 r = 0;
2847 for (arg = expr->value.function.actual; arg; arg = arg->next)
2848 {
2849 if (arg->expr == NULL || arg->expr->rank == 0)
2850 continue;
2851 if (r == 0)
2852 {
2853 r = arg->expr->rank;
2854 continue;
2855 }
2856
2857 if (arg->expr->rank != r)
2858 {
2859 gfc_error
2860 ("Ranks of arguments to elemental intrinsic '%s' differ "
2861 "at %L", specific->name, &arg->expr->where);
2862 return FAILURE;
2863 }
2864 }
2865 }
2866
2867 if (t == FAILURE)
2868 remove_nullargs (ap);
2869
2870 return t;
2871 }
2872
2873
2874 /* See if an intrinsic is one of the intrinsics we evaluate
2875 as an extension. */
2876
2877 static int
2878 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
2879 {
2880 /* FIXME: This should be moved into the intrinsic definitions. */
2881 static const char * const init_expr_extensions[] = {
2882 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2883 "precision", "present", "radix", "range", "selected_real_kind",
2884 "tiny", NULL
2885 };
2886
2887 int i;
2888
2889 for (i = 0; init_expr_extensions[i]; i++)
2890 if (strcmp (init_expr_extensions[i], isym->name) == 0)
2891 return 0;
2892
2893 return 1;
2894 }
2895
2896
2897 /* Check whether an intrinsic belongs to whatever standard the user
2898 has chosen. */
2899
2900 static void
2901 check_intrinsic_standard (const char *name, int standard, locus * where)
2902 {
2903 if (!gfc_option.warn_nonstd_intrinsics)
2904 return;
2905
2906 gfc_notify_std (standard, "Intrinsic '%s' at %L is not included"
2907 "in the selected standard", name, where);
2908 }
2909
2910
2911 /* See if a function call corresponds to an intrinsic function call.
2912 We return:
2913
2914 MATCH_YES if the call corresponds to an intrinsic, simplification
2915 is done if possible.
2916
2917 MATCH_NO if the call does not correspond to an intrinsic
2918
2919 MATCH_ERROR if the call corresponds to an intrinsic but there was an
2920 error during the simplification process.
2921
2922 The error_flag parameter enables an error reporting. */
2923
2924 match
2925 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
2926 {
2927 gfc_intrinsic_sym *isym, *specific;
2928 gfc_actual_arglist *actual;
2929 const char *name;
2930 int flag;
2931
2932 if (expr->value.function.isym != NULL)
2933 return (do_simplify (expr->value.function.isym, expr) == FAILURE)
2934 ? MATCH_ERROR : MATCH_YES;
2935
2936 gfc_suppress_error = !error_flag;
2937 flag = 0;
2938
2939 for (actual = expr->value.function.actual; actual; actual = actual->next)
2940 if (actual->expr != NULL)
2941 flag |= (actual->expr->ts.type != BT_INTEGER
2942 && actual->expr->ts.type != BT_CHARACTER);
2943
2944 name = expr->symtree->n.sym->name;
2945
2946 isym = specific = gfc_find_function (name);
2947 if (isym == NULL)
2948 {
2949 gfc_suppress_error = 0;
2950 return MATCH_NO;
2951 }
2952
2953 gfc_current_intrinsic_where = &expr->where;
2954
2955 /* Bypass the generic list for min and max. */
2956 if (isym->check.f1m == gfc_check_min_max)
2957 {
2958 init_arglist (isym);
2959
2960 if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
2961 goto got_specific;
2962
2963 gfc_suppress_error = 0;
2964 return MATCH_NO;
2965 }
2966
2967 /* If the function is generic, check all of its specific
2968 incarnations. If the generic name is also a specific, we check
2969 that name last, so that any error message will correspond to the
2970 specific. */
2971 gfc_suppress_error = 1;
2972
2973 if (isym->generic)
2974 {
2975 for (specific = isym->specific_head; specific;
2976 specific = specific->next)
2977 {
2978 if (specific == isym)
2979 continue;
2980 if (check_specific (specific, expr, 0) == SUCCESS)
2981 goto got_specific;
2982 }
2983 }
2984
2985 gfc_suppress_error = !error_flag;
2986
2987 if (check_specific (isym, expr, error_flag) == FAILURE)
2988 {
2989 gfc_suppress_error = 0;
2990 return MATCH_NO;
2991 }
2992
2993 specific = isym;
2994
2995 got_specific:
2996 expr->value.function.isym = specific;
2997 gfc_intrinsic_symbol (expr->symtree->n.sym);
2998
2999 if (do_simplify (specific, expr) == FAILURE)
3000 {
3001 gfc_suppress_error = 0;
3002 return MATCH_ERROR;
3003 }
3004
3005 /* TODO: We should probably only allow elemental functions here. */
3006 flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
3007
3008 gfc_suppress_error = 0;
3009 if (pedantic && gfc_init_expr
3010 && flag && gfc_init_expr_extensions (specific))
3011 {
3012 if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
3013 "nonstandard initialization expression at %L", &expr->where)
3014 == FAILURE)
3015 {
3016 return MATCH_ERROR;
3017 }
3018 }
3019
3020 check_intrinsic_standard (name, isym->standard, &expr->where);
3021
3022 return MATCH_YES;
3023 }
3024
3025
3026 /* See if a CALL statement corresponds to an intrinsic subroutine.
3027 Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3028 MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3029 correspond). */
3030
3031 match
3032 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
3033 {
3034 gfc_intrinsic_sym *isym;
3035 const char *name;
3036
3037 name = c->symtree->n.sym->name;
3038
3039 isym = find_subroutine (name);
3040 if (isym == NULL)
3041 return MATCH_NO;
3042
3043 gfc_suppress_error = !error_flag;
3044
3045 init_arglist (isym);
3046
3047 if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3048 goto fail;
3049
3050 if (isym->check.f1 != NULL)
3051 {
3052 if (do_check (isym, c->ext.actual) == FAILURE)
3053 goto fail;
3054 }
3055 else
3056 {
3057 if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3058 goto fail;
3059 }
3060
3061 /* The subroutine corresponds to an intrinsic. Allow errors to be
3062 seen at this point. */
3063 gfc_suppress_error = 0;
3064
3065 if (isym->resolve.s1 != NULL)
3066 isym->resolve.s1 (c);
3067 else
3068 c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3069
3070 if (gfc_pure (NULL) && !isym->elemental)
3071 {
3072 gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3073 &c->loc);
3074 return MATCH_ERROR;
3075 }
3076
3077 check_intrinsic_standard (name, isym->standard, &c->loc);
3078
3079 return MATCH_YES;
3080
3081 fail:
3082 gfc_suppress_error = 0;
3083 return MATCH_NO;
3084 }
3085
3086
3087 /* Call gfc_convert_type() with warning enabled. */
3088
3089 try
3090 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
3091 {
3092 return gfc_convert_type_warn (expr, ts, eflag, 1);
3093 }
3094
3095
3096 /* Try to convert an expression (in place) from one type to another.
3097 'eflag' controls the behavior on error.
3098
3099 The possible values are:
3100
3101 1 Generate a gfc_error()
3102 2 Generate a gfc_internal_error().
3103
3104 'wflag' controls the warning related to conversion. */
3105
3106 try
3107 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
3108 int wflag)
3109 {
3110 gfc_intrinsic_sym *sym;
3111 gfc_typespec from_ts;
3112 locus old_where;
3113 gfc_expr *new;
3114 int rank;
3115 mpz_t *shape;
3116
3117 from_ts = expr->ts; /* expr->ts gets clobbered */
3118
3119 if (ts->type == BT_UNKNOWN)
3120 goto bad;
3121
3122 /* NULL and zero size arrays get their type here. */
3123 if (expr->expr_type == EXPR_NULL
3124 || (expr->expr_type == EXPR_ARRAY
3125 && expr->value.constructor == NULL))
3126 {
3127 /* Sometimes the RHS acquire the type. */
3128 expr->ts = *ts;
3129 return SUCCESS;
3130 }
3131
3132 if (expr->ts.type == BT_UNKNOWN)
3133 goto bad;
3134
3135 if (expr->ts.type == BT_DERIVED
3136 && ts->type == BT_DERIVED
3137 && gfc_compare_types (&expr->ts, ts))
3138 return SUCCESS;
3139
3140 sym = find_conv (&expr->ts, ts);
3141 if (sym == NULL)
3142 goto bad;
3143
3144 /* At this point, a conversion is necessary. A warning may be needed. */
3145 if (wflag && gfc_option.warn_conversion)
3146 gfc_warning_now ("Conversion from %s to %s at %L",
3147 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3148
3149 /* Insert a pre-resolved function call to the right function. */
3150 old_where = expr->where;
3151 rank = expr->rank;
3152 shape = expr->shape;
3153
3154 new = gfc_get_expr ();
3155 *new = *expr;
3156
3157 new = gfc_build_conversion (new);
3158 new->value.function.name = sym->lib_name;
3159 new->value.function.isym = sym;
3160 new->where = old_where;
3161 new->rank = rank;
3162 new->shape = gfc_copy_shape (shape, rank);
3163
3164 *expr = *new;
3165
3166 gfc_free (new);
3167 expr->ts = *ts;
3168
3169 if (gfc_is_constant_expr (expr->value.function.actual->expr)
3170 && do_simplify (sym, expr) == FAILURE)
3171 {
3172
3173 if (eflag == 2)
3174 goto bad;
3175 return FAILURE; /* Error already generated in do_simplify() */
3176 }
3177
3178 return SUCCESS;
3179
3180 bad:
3181 if (eflag == 1)
3182 {
3183 gfc_error ("Can't convert %s to %s at %L",
3184 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3185 return FAILURE;
3186 }
3187
3188 gfc_internal_error ("Can't convert %s to %s at %L",
3189 gfc_typename (&from_ts), gfc_typename (ts),
3190 &expr->where);
3191 /* Not reached */
3192 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org