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