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