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