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