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