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