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