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