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