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