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