projects / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
history | raw | HEAD
re PR fortran/36319 (Segfault with wide characters in DATA)
[gcc.git] / gcc / fortran / intrinsic.c
1 /* Build up a list of intrinsic subroutines and functions for the
2 name-resolution stage.
3 Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 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 i, BT_UNKNOWN, 0, REQUIRED);
2261
2262 make_generic ("sizeof", GFC_ISYM_SIZEOF, GFC_STD_GNU);
2263
2264 add_sym_1 ("spacing", GFC_ISYM_SPACING, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2265 gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
2266 x, BT_REAL, dr, REQUIRED);
2267
2268 make_generic ("spacing", GFC_ISYM_SPACING, GFC_STD_F95);
2269
2270 add_sym_3 ("spread", GFC_ISYM_SPREAD, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2271 gfc_check_spread, NULL, gfc_resolve_spread,
2272 src, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, REQUIRED,
2273 ncopies, BT_INTEGER, di, REQUIRED);
2274
2275 make_generic ("spread", GFC_ISYM_SPREAD, GFC_STD_F95);
2276
2277 add_sym_1 ("sqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2278 gfc_check_fn_rc, gfc_simplify_sqrt, gfc_resolve_sqrt,
2279 x, BT_REAL, dr, REQUIRED);
2280
2281 add_sym_1 ("dsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2282 gfc_check_fn_d, gfc_simplify_sqrt, gfc_resolve_sqrt,
2283 x, BT_REAL, dd, REQUIRED);
2284
2285 add_sym_1 ("csqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dz, GFC_STD_F77,
2286 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2287 x, BT_COMPLEX, dz, REQUIRED);
2288
2289 add_sym_1 ("zsqrt", GFC_ISYM_SQRT, CLASS_ELEMENTAL, ACTUAL_YES, BT_COMPLEX, dd, GFC_STD_GNU,
2290 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
2291 x, BT_COMPLEX, dd, REQUIRED);
2292
2293 make_alias ("cdsqrt", GFC_STD_GNU);
2294
2295 make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
2296
2297 add_sym_2 ("stat", GFC_ISYM_STAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2298 gfc_check_stat, NULL, gfc_resolve_stat,
2299 a, BT_CHARACTER, dc, REQUIRED, b, BT_INTEGER, di, REQUIRED);
2300
2301 make_generic ("stat", GFC_ISYM_STAT, GFC_STD_GNU);
2302
2303 add_sym_3red ("sum", GFC_ISYM_SUM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2304 gfc_check_product_sum, NULL, gfc_resolve_sum,
2305 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2306 msk, BT_LOGICAL, dl, OPTIONAL);
2307
2308 make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
2309
2310 add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2311 gfc_check_symlnk, NULL, gfc_resolve_symlnk,
2312 a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
2313
2314 make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
2315
2316 add_sym_1 ("system", GFC_ISYM_SYSTEM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2317 NULL, NULL, NULL,
2318 c, BT_CHARACTER, dc, REQUIRED);
2319
2320 make_generic ("system", GFC_ISYM_SYSTEM, GFC_STD_GNU);
2321
2322 add_sym_1 ("tan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2323 gfc_check_fn_r, gfc_simplify_tan, gfc_resolve_tan,
2324 x, BT_REAL, dr, REQUIRED);
2325
2326 add_sym_1 ("dtan", GFC_ISYM_TAN, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2327 gfc_check_fn_d, gfc_simplify_tan, gfc_resolve_tan,
2328 x, BT_REAL, dd, REQUIRED);
2329
2330 make_generic ("tan", GFC_ISYM_TAN, GFC_STD_F77);
2331
2332 add_sym_1 ("tanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dr, GFC_STD_F77,
2333 gfc_check_fn_r, gfc_simplify_tanh, gfc_resolve_tanh,
2334 x, BT_REAL, dr, REQUIRED);
2335
2336 add_sym_1 ("dtanh", GFC_ISYM_TANH, CLASS_ELEMENTAL, ACTUAL_YES, BT_REAL, dd, GFC_STD_F77,
2337 gfc_check_fn_d, gfc_simplify_tanh, gfc_resolve_tanh,
2338 x, BT_REAL, dd, REQUIRED);
2339
2340 make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
2341
2342 add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2343 NULL, NULL, gfc_resolve_time);
2344
2345 make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
2346
2347 add_sym_0 ("time8", GFC_ISYM_TIME8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2348 NULL, NULL, gfc_resolve_time8);
2349
2350 make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
2351
2352 add_sym_1 ("tiny", GFC_ISYM_TINY, CLASS_INQUIRY, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2353 gfc_check_x, gfc_simplify_tiny, NULL,
2354 x, BT_REAL, dr, REQUIRED);
2355
2356 make_generic ("tiny", GFC_ISYM_TINY, GFC_STD_F95);
2357
2358 add_sym_3 ("transfer", GFC_ISYM_TRANSFER, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2359 gfc_check_transfer, gfc_simplify_transfer, gfc_resolve_transfer,
2360 src, BT_REAL, dr, REQUIRED, mo, BT_REAL, dr, REQUIRED,
2361 sz, BT_INTEGER, di, OPTIONAL);
2362
2363 make_generic ("transfer", GFC_ISYM_TRANSFER, GFC_STD_F95);
2364
2365 add_sym_1 ("transpose", GFC_ISYM_TRANSPOSE, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2366 gfc_check_transpose, NULL, gfc_resolve_transpose,
2367 m, BT_REAL, dr, REQUIRED);
2368
2369 make_generic ("transpose", GFC_ISYM_TRANSPOSE, GFC_STD_F95);
2370
2371 add_sym_1 ("trim", GFC_ISYM_TRIM, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_F95,
2372 gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
2373 stg, BT_CHARACTER, dc, REQUIRED);
2374
2375 make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
2376
2377 add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
2378 gfc_check_ttynam, NULL, gfc_resolve_ttynam,
2379 ut, BT_INTEGER, di, REQUIRED);
2380
2381 make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
2382
2383 add_sym_3 ("ubound", GFC_ISYM_UBOUND, CLASS_INQUIRY, ACTUAL_NO,
2384 BT_INTEGER, di, GFC_STD_F95,
2385 gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
2386 ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
2387 kind, BT_INTEGER, di, OPTIONAL);
2388
2389 make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
2390
2391 /* g77 compatibility for UMASK. */
2392 add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2393 gfc_check_umask, NULL, gfc_resolve_umask,
2394 a, BT_INTEGER, di, REQUIRED);
2395
2396 make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
2397
2398 /* g77 compatibility for UNLINK. */
2399 add_sym_1 ("unlink", GFC_ISYM_UNLINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
2400 gfc_check_unlink, NULL, gfc_resolve_unlink,
2401 a, BT_CHARACTER, dc, REQUIRED);
2402
2403 make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
2404
2405 add_sym_3 ("unpack", GFC_ISYM_UNPACK, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95,
2406 gfc_check_unpack, NULL, gfc_resolve_unpack,
2407 v, BT_REAL, dr, REQUIRED, msk, BT_LOGICAL, dl, REQUIRED,
2408 f, BT_REAL, dr, REQUIRED);
2409
2410 make_generic ("unpack", GFC_ISYM_UNPACK, GFC_STD_F95);
2411
2412 add_sym_4 ("verify", GFC_ISYM_VERIFY, CLASS_ELEMENTAL, ACTUAL_NO,
2413 BT_INTEGER, di, GFC_STD_F95,
2414 gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
2415 stg, BT_CHARACTER, dc, REQUIRED, set, BT_CHARACTER, dc, REQUIRED,
2416 bck, BT_LOGICAL, dl, OPTIONAL, kind, BT_INTEGER, di, OPTIONAL);
2417
2418 make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
2419
2420 add_sym_1 ("loc", GFC_ISYM_LOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
2421 gfc_check_loc, NULL, gfc_resolve_loc,
2422 ar, BT_UNKNOWN, 0, REQUIRED);
2423
2424 make_generic ("loc", GFC_ISYM_LOC, GFC_STD_GNU);
2425 }
2426
2427
2428 /* Add intrinsic subroutines. */
2429
2430 static void
2431 add_subroutines (void)
2432 {
2433 /* Argument names as in the standard (to be used as argument keywords). */
2434 const char
2435 *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
2436 *c = "count", *tm = "time", *tp = "topos", *gt = "get",
2437 *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
2438 *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
2439 *com = "command", *length = "length", *st = "status",
2440 *val = "value", *num = "number", *name = "name",
2441 *trim_name = "trim_name", *ut = "unit", *han = "handler",
2442 *sec = "seconds", *res = "result", *of = "offset", *md = "mode",
2443 *whence = "whence", *pos = "pos";
2444
2445 int di, dr, dc, dl, ii;
2446
2447 di = gfc_default_integer_kind;
2448 dr = gfc_default_real_kind;
2449 dc = gfc_default_character_kind;
2450 dl = gfc_default_logical_kind;
2451 ii = gfc_index_integer_kind;
2452
2453 add_sym_0s ("abort", GFC_ISYM_ABORT, GFC_STD_GNU, NULL);
2454
2455 make_noreturn();
2456
2457 add_sym_1s ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2458 gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
2459 tm, BT_REAL, dr, REQUIRED);
2460
2461 /* More G77 compatibility garbage. */
2462 add_sym_2s ("ctime", GFC_ISYM_CTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2463 gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
2464 tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED);
2465
2466 add_sym_1s ("idate", GFC_ISYM_IDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2467 gfc_check_itime_idate, NULL, gfc_resolve_idate,
2468 vl, BT_INTEGER, 4, REQUIRED);
2469
2470 add_sym_1s ("itime", GFC_ISYM_ITIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2471 gfc_check_itime_idate, NULL, gfc_resolve_itime,
2472 vl, BT_INTEGER, 4, REQUIRED);
2473
2474 add_sym_2s ("ltime", GFC_ISYM_LTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2475 gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime,
2476 tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
2477
2478 add_sym_2s ("gmtime", GFC_ISYM_GMTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2479 gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime,
2480 tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
2481
2482 add_sym_1s ("second", GFC_ISYM_SECOND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2483 gfc_check_second_sub, NULL, gfc_resolve_second_sub,
2484 tm, BT_REAL, dr, REQUIRED);
2485
2486 add_sym_2s ("chdir", GFC_ISYM_CHDIR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2487 gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
2488 name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2489
2490 add_sym_3s ("chmod", GFC_ISYM_CHMOD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2491 gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
2492 name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED,
2493 st, BT_INTEGER, di, OPTIONAL);
2494
2495 add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2496 gfc_check_date_and_time, NULL, NULL,
2497 dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
2498 zn, BT_CHARACTER, dc, OPTIONAL, vl, BT_INTEGER, di, OPTIONAL);
2499
2500 /* More G77 compatibility garbage. */
2501 add_sym_2s ("etime", GFC_ISYM_ETIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2502 gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub,
2503 vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2504
2505 add_sym_2s ("dtime", GFC_ISYM_DTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2506 gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub,
2507 vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
2508
2509 add_sym_1s ("fdate", GFC_ISYM_FDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2510 gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
2511 dt, BT_CHARACTER, dc, REQUIRED);
2512
2513 add_sym_1s ("gerror", GFC_ISYM_GERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2514 gfc_check_gerror, NULL, gfc_resolve_gerror, res, BT_CHARACTER,
2515 dc, REQUIRED);
2516
2517 add_sym_2s ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2518 gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
2519 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2520
2521 add_sym_2s ("getenv", GFC_ISYM_GETENV, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2522 NULL, NULL, NULL,
2523 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc,
2524 REQUIRED);
2525
2526 add_sym_2s ("getarg", GFC_ISYM_GETARG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2527 gfc_check_getarg, NULL, gfc_resolve_getarg,
2528 pos, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
2529
2530 add_sym_1s ("getlog", GFC_ISYM_GETLOG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2531 gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
2532 dc, REQUIRED);
2533
2534 /* F2003 commandline routines. */
2535
2536 add_sym_3s ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2537 NULL, NULL, gfc_resolve_get_command,
2538 com, BT_CHARACTER, dc, OPTIONAL,
2539 length, BT_INTEGER, di, OPTIONAL,
2540 st, BT_INTEGER, di, OPTIONAL);
2541
2542 add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2543 NULL, NULL, gfc_resolve_get_command_argument,
2544 num, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, OPTIONAL,
2545 length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL);
2546
2547 /* F2003 subroutine to get environment variables. */
2548
2549 add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2550 NULL, NULL, gfc_resolve_get_environment_variable,
2551 name, BT_CHARACTER, dc, REQUIRED,
2552 val, BT_CHARACTER, dc, OPTIONAL,
2553 length, BT_INTEGER, di, OPTIONAL, st, BT_INTEGER, di, OPTIONAL,
2554 trim_name, BT_LOGICAL, dl, OPTIONAL);
2555
2556 add_sym_2s ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
2557 gfc_check_move_alloc, NULL, NULL,
2558 f, BT_UNKNOWN, 0, REQUIRED,
2559 t, BT_UNKNOWN, 0, REQUIRED);
2560
2561 add_sym_5s ("mvbits", GFC_ISYM_MVBITS, CLASS_ELEMENTAL, BT_UNKNOWN, 0, GFC_STD_F95,
2562 gfc_check_mvbits, gfc_simplify_mvbits, gfc_resolve_mvbits,
2563 f, BT_INTEGER, di, REQUIRED, fp, BT_INTEGER, di, REQUIRED,
2564 ln, BT_INTEGER, di, REQUIRED, t, BT_INTEGER, di, REQUIRED,
2565 tp, BT_INTEGER, di, REQUIRED);
2566
2567 add_sym_1s ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2568 gfc_check_random_number, NULL, gfc_resolve_random_number,
2569 h, BT_REAL, dr, REQUIRED);
2570
2571 add_sym_3s ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS,
2572 BT_UNKNOWN, 0, GFC_STD_F95,
2573 gfc_check_random_seed, NULL, gfc_resolve_random_seed,
2574 sz, BT_INTEGER, di, OPTIONAL, pt, BT_INTEGER, di, OPTIONAL,
2575 gt, BT_INTEGER, di, OPTIONAL);
2576
2577 /* More G77 compatibility garbage. */
2578 add_sym_3s ("alarm", GFC_ISYM_ALARM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2579 gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
2580 sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2581 st, BT_INTEGER, di, OPTIONAL);
2582
2583 add_sym_1s ("srand", GFC_ISYM_SRAND, NO_CLASS, BT_UNKNOWN, di, GFC_STD_GNU,
2584 gfc_check_srand, NULL, gfc_resolve_srand,
2585 c, BT_INTEGER, 4, REQUIRED);
2586
2587 add_sym_1s ("exit", GFC_ISYM_EXIT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2588 gfc_check_exit, NULL, gfc_resolve_exit,
2589 st, BT_INTEGER, di, OPTIONAL);
2590
2591 make_noreturn();
2592
2593 add_sym_3s ("fgetc", GFC_ISYM_FGETC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2594 gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
2595 ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2596 st, BT_INTEGER, di, OPTIONAL);
2597
2598 add_sym_2s ("fget", GFC_ISYM_FGET, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2599 gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
2600 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2601
2602 add_sym_1s ("flush", GFC_ISYM_FLUSH, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2603 gfc_check_flush, NULL, gfc_resolve_flush,
2604 ut, BT_INTEGER, di, OPTIONAL);
2605
2606 add_sym_3s ("fputc", GFC_ISYM_FPUTC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2607 gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
2608 ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
2609 st, BT_INTEGER, di, OPTIONAL);
2610
2611 add_sym_2s ("fput", GFC_ISYM_FPUT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2612 gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
2613 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2614
2615 add_sym_1s ("free", GFC_ISYM_FREE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
2616 NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
2617
2618 add_sym_4s ("fseek", GFC_ISYM_FSEEK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2619 gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
2620 ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, di, REQUIRED,
2621 whence, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2622
2623 add_sym_2s ("ftell", GFC_ISYM_FTELL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2624 gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
2625 ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
2626
2627 add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2628 gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
2629 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2630
2631 add_sym_3s ("kill", GFC_ISYM_KILL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
2632 NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
2633 val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2634
2635 add_sym_3s ("link", GFC_ISYM_LINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2636 gfc_check_link_sub, NULL, gfc_resolve_link_sub,
2637 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2638 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2639
2640 add_sym_1s ("perror", GFC_ISYM_PERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2641 gfc_check_perror, NULL, gfc_resolve_perror,
2642 c, BT_CHARACTER, dc, REQUIRED);
2643
2644 add_sym_3s ("rename", GFC_ISYM_RENAME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2645 gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
2646 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2647 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2648
2649 add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2650 gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
2651 val, BT_INTEGER, di, REQUIRED);
2652
2653 add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2654 gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
2655 ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2656 st, BT_INTEGER, di, OPTIONAL);
2657
2658 add_sym_3s ("lstat", GFC_ISYM_LSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2659 gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub,
2660 name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2661 st, BT_INTEGER, di, OPTIONAL);
2662
2663 add_sym_3s ("stat", GFC_ISYM_STAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2664 gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
2665 name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
2666 st, BT_INTEGER, di, OPTIONAL);
2667
2668 add_sym_3s ("signal", GFC_ISYM_SIGNAL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2669 gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
2670 num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
2671 st, BT_INTEGER, di, OPTIONAL);
2672
2673 add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2674 gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
2675 name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
2676 dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2677
2678 add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2679 NULL, NULL, gfc_resolve_system_sub,
2680 com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2681
2682 add_sym_3s ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F95,
2683 gfc_check_system_clock, NULL, gfc_resolve_system_clock,
2684 c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
2685 cm, BT_INTEGER, di, OPTIONAL);
2686
2687 add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2688 gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
2689 ut, BT_INTEGER, di, REQUIRED, name, BT_CHARACTER, dc, REQUIRED);
2690
2691 add_sym_2s ("umask", GFC_ISYM_UMASK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2692 gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
2693 val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
2694
2695 add_sym_2s ("unlink", GFC_ISYM_UNLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
2696 gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
2697 c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
2698 }
2699
2700
2701 /* Add a function to the list of conversion symbols. */
2702
2703 static void
2704 add_conv (bt from_type, int from_kind, bt to_type, int to_kind, int standard)
2705 {
2706 gfc_typespec from, to;
2707 gfc_intrinsic_sym *sym;
2708
2709 if (sizing == SZ_CONVS)
2710 {
2711 nconv++;
2712 return;
2713 }
2714
2715 gfc_clear_ts (&from);
2716 from.type = from_type;
2717 from.kind = from_kind;
2718
2719 gfc_clear_ts (&to);
2720 to.type = to_type;
2721 to.kind = to_kind;
2722
2723 sym = conversion + nconv;
2724
2725 sym->name = conv_name (&from, &to);
2726 sym->lib_name = sym->name;
2727 sym->simplify.cc = gfc_convert_constant;
2728 sym->standard = standard;
2729 sym->elemental = 1;
2730 sym->conversion = 1;
2731 sym->ts = to;
2732 sym->id = GFC_ISYM_CONVERSION;
2733
2734 nconv++;
2735 }
2736
2737
2738 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
2739 functions by looping over the kind tables. */
2740
2741 static void
2742 add_conversions (void)
2743 {
2744 int i, j;
2745
2746 /* Integer-Integer conversions. */
2747 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2748 for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
2749 {
2750 if (i == j)
2751 continue;
2752
2753 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2754 BT_INTEGER, gfc_integer_kinds[j].kind, GFC_STD_F77);
2755 }
2756
2757 /* Integer-Real/Complex conversions. */
2758 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2759 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2760 {
2761 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2762 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2763
2764 add_conv (BT_REAL, gfc_real_kinds[j].kind,
2765 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2766
2767 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2768 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2769
2770 add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
2771 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_F77);
2772 }
2773
2774 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2775 {
2776 /* Hollerith-Integer conversions. */
2777 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
2778 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2779 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2780 /* Hollerith-Real conversions. */
2781 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2782 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2783 BT_REAL, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2784 /* Hollerith-Complex conversions. */
2785 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2786 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2787 BT_COMPLEX, gfc_real_kinds[i].kind, GFC_STD_LEGACY);
2788
2789 /* Hollerith-Character conversions. */
2790 add_conv (BT_HOLLERITH, gfc_default_character_kind, BT_CHARACTER,
2791 gfc_default_character_kind, GFC_STD_LEGACY);
2792
2793 /* Hollerith-Logical conversions. */
2794 for (i = 0; gfc_logical_kinds[i].kind != 0; i++)
2795 add_conv (BT_HOLLERITH, gfc_default_character_kind,
2796 BT_LOGICAL, gfc_logical_kinds[i].kind, GFC_STD_LEGACY);
2797 }
2798
2799 /* Real/Complex - Real/Complex conversions. */
2800 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
2801 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
2802 {
2803 if (i != j)
2804 {
2805 add_conv (BT_REAL, gfc_real_kinds[i].kind,
2806 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2807
2808 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2809 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2810 }
2811
2812 add_conv (BT_REAL, gfc_real_kinds[i].kind,
2813 BT_COMPLEX, gfc_real_kinds[j].kind, GFC_STD_F77);
2814
2815 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
2816 BT_REAL, gfc_real_kinds[j].kind, GFC_STD_F77);
2817 }
2818
2819 /* Logical/Logical kind conversion. */
2820 for (i = 0; gfc_logical_kinds[i].kind; i++)
2821 for (j = 0; gfc_logical_kinds[j].kind; j++)
2822 {
2823 if (i == j)
2824 continue;
2825
2826 add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
2827 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_F77);
2828 }
2829
2830 /* Integer-Logical and Logical-Integer conversions. */
2831 if ((gfc_option.allow_std & GFC_STD_LEGACY) != 0)
2832 for (i=0; gfc_integer_kinds[i].kind; i++)
2833 for (j=0; gfc_logical_kinds[j].kind; j++)
2834 {
2835 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
2836 BT_LOGICAL, gfc_logical_kinds[j].kind, GFC_STD_LEGACY);
2837 add_conv (BT_LOGICAL, gfc_logical_kinds[j].kind,
2838 BT_INTEGER, gfc_integer_kinds[i].kind, GFC_STD_LEGACY);
2839 }
2840 }
2841
2842
2843 static void
2844 add_char_conversions (void)
2845 {
2846 int n, i, j;
2847
2848 /* Count possible conversions. */
2849 for (i = 0; gfc_character_kinds[i].kind != 0; i++)
2850 for (j = 0; gfc_character_kinds[j].kind != 0; j++)
2851 if (i != j)
2852 ncharconv++;
2853
2854 /* Allocate memory. */
2855 char_conversions = gfc_getmem (sizeof (gfc_intrinsic_sym) * ncharconv);
2856
2857 /* Add the conversions themselves. */
2858 n = 0;
2859 for (i = 0; gfc_character_kinds[i].kind != 0; i++)
2860 for (j = 0; gfc_character_kinds[j].kind != 0; j++)
2861 {
2862 gfc_typespec from, to;
2863
2864 if (i == j)
2865 continue;
2866
2867 gfc_clear_ts (&from);
2868 from.type = BT_CHARACTER;
2869 from.kind = gfc_character_kinds[i].kind;
2870
2871 gfc_clear_ts (&to);
2872 to.type = BT_CHARACTER;
2873 to.kind = gfc_character_kinds[j].kind;
2874
2875 char_conversions[n].name = conv_name (&from, &to);
2876 char_conversions[n].lib_name = char_conversions[n].name;
2877 char_conversions[n].simplify.cc = gfc_convert_char_constant;
2878 char_conversions[n].standard = GFC_STD_F2003;
2879 char_conversions[n].elemental = 1;
2880 char_conversions[n].conversion = 0;
2881 char_conversions[n].ts = to;
2882 char_conversions[n].id = GFC_ISYM_CONVERSION;
2883
2884 n++;
2885 }
2886 }
2887
2888
2889 /* Initialize the table of intrinsics. */
2890 void
2891 gfc_intrinsic_init_1 (void)
2892 {
2893 int i;
2894
2895 nargs = nfunc = nsub = nconv = 0;
2896
2897 /* Create a namespace to hold the resolved intrinsic symbols. */
2898 gfc_intrinsic_namespace = gfc_get_namespace (NULL, 0);
2899
2900 sizing = SZ_FUNCS;
2901 add_functions ();
2902 sizing = SZ_SUBS;
2903 add_subroutines ();
2904 sizing = SZ_CONVS;
2905 add_conversions ();
2906
2907 functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2908 + sizeof (gfc_intrinsic_arg) * nargs);
2909
2910 next_sym = functions;
2911 subroutines = functions + nfunc;
2912
2913 conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2914
2915 next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2916
2917 sizing = SZ_NOTHING;
2918 nconv = 0;
2919
2920 add_functions ();
2921 add_subroutines ();
2922 add_conversions ();
2923
2924 /* Character conversion intrinsics need to be treated separately. */
2925 add_char_conversions ();
2926
2927 /* Set the pure flag. All intrinsic functions are pure, and
2928 intrinsic subroutines are pure if they are elemental. */
2929
2930 for (i = 0; i < nfunc; i++)
2931 functions[i].pure = 1;
2932
2933 for (i = 0; i < nsub; i++)
2934 subroutines[i].pure = subroutines[i].elemental;
2935 }
2936
2937
2938 void
2939 gfc_intrinsic_done_1 (void)
2940 {
2941 gfc_free (functions);
2942 gfc_free (conversion);
2943 gfc_free (char_conversions);
2944 gfc_free_namespace (gfc_intrinsic_namespace);
2945 }
2946
2947
2948 /******** Subroutines to check intrinsic interfaces ***********/
2949
2950 /* Given a formal argument list, remove any NULL arguments that may
2951 have been left behind by a sort against some formal argument list. */
2952
2953 static void
2954 remove_nullargs (gfc_actual_arglist **ap)
2955 {
2956 gfc_actual_arglist *head, *tail, *next;
2957
2958 tail = NULL;
2959
2960 for (head = *ap; head; head = next)
2961 {
2962 next = head->next;
2963
2964 if (head->expr == NULL && !head->label)
2965 {
2966 head->next = NULL;
2967 gfc_free_actual_arglist (head);
2968 }
2969 else
2970 {
2971 if (tail == NULL)
2972 *ap = head;
2973 else
2974 tail->next = head;
2975
2976 tail = head;
2977 tail->next = NULL;
2978 }
2979 }
2980
2981 if (tail == NULL)
2982 *ap = NULL;
2983 }
2984
2985
2986 /* Given an actual arglist and a formal arglist, sort the actual
2987 arglist so that its arguments are in a one-to-one correspondence
2988 with the format arglist. Arguments that are not present are given
2989 a blank gfc_actual_arglist structure. If something is obviously
2990 wrong (say, a missing required argument) we abort sorting and
2991 return FAILURE. */
2992
2993 static try
2994 sort_actual (const char *name, gfc_actual_arglist **ap,
2995 gfc_intrinsic_arg *formal, locus *where)
2996 {
2997 gfc_actual_arglist *actual, *a;
2998 gfc_intrinsic_arg *f;
2999
3000 remove_nullargs (ap);
3001 actual = *ap;
3002
3003 for (f = formal; f; f = f->next)
3004 f->actual = NULL;
3005
3006 f = formal;
3007 a = actual;
3008
3009 if (f == NULL && a == NULL) /* No arguments */
3010 return SUCCESS;
3011
3012 for (;;)
3013 { /* Put the nonkeyword arguments in a 1:1 correspondence */
3014 if (f == NULL)
3015 break;
3016 if (a == NULL)
3017 goto optional;
3018
3019 if (a->name != NULL)
3020 goto keywords;
3021
3022 f->actual = a;
3023
3024 f = f->next;
3025 a = a->next;
3026 }
3027
3028 if (a == NULL)
3029 goto do_sort;
3030
3031 gfc_error ("Too many arguments in call to '%s' at %L", name, where);
3032 return FAILURE;
3033
3034 keywords:
3035 /* Associate the remaining actual arguments, all of which have
3036 to be keyword arguments. */
3037 for (; a; a = a->next)
3038 {
3039 for (f = formal; f; f = f->next)
3040 if (strcmp (a->name, f->name) == 0)
3041 break;
3042
3043 if (f == NULL)
3044 {
3045 if (a->name[0] == '%')
3046 gfc_error ("The argument list functions %%VAL, %%LOC or %%REF "
3047 "are not allowed in this context at %L", where);
3048 else
3049 gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
3050 a->name, name, where);
3051 return FAILURE;
3052 }
3053
3054 if (f->actual != NULL)
3055 {
3056 gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
3057 f->name, name, where);
3058 return FAILURE;
3059 }
3060
3061 f->actual = a;
3062 }
3063
3064 optional:
3065 /* At this point, all unmatched formal args must be optional. */
3066 for (f = formal; f; f = f->next)
3067 {
3068 if (f->actual == NULL && f->optional == 0)
3069 {
3070 gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
3071 f->name, name, where);
3072 return FAILURE;
3073 }
3074 }
3075
3076 do_sort:
3077 /* Using the formal argument list, string the actual argument list
3078 together in a way that corresponds with the formal list. */
3079 actual = NULL;
3080
3081 for (f = formal; f; f = f->next)
3082 {
3083 if (f->actual && f->actual->label != NULL && f->ts.type)
3084 {
3085 gfc_error ("ALTERNATE RETURN not permitted at %L", where);
3086 return FAILURE;
3087 }
3088
3089 if (f->actual == NULL)
3090 {
3091 a = gfc_get_actual_arglist ();
3092 a->missing_arg_type = f->ts.type;
3093 }
3094 else
3095 a = f->actual;
3096
3097 if (actual == NULL)
3098 *ap = a;
3099 else
3100 actual->next = a;
3101
3102 actual = a;
3103 }
3104 actual->next = NULL; /* End the sorted argument list. */
3105
3106 return SUCCESS;
3107 }
3108
3109
3110 /* Compare an actual argument list with an intrinsic's formal argument
3111 list. The lists are checked for agreement of type. We don't check
3112 for arrayness here. */
3113
3114 static try
3115 check_arglist (gfc_actual_arglist **ap, gfc_intrinsic_sym *sym,
3116 int error_flag)
3117 {
3118 gfc_actual_arglist *actual;
3119 gfc_intrinsic_arg *formal;
3120 int i;
3121
3122 formal = sym->formal;
3123 actual = *ap;
3124
3125 i = 0;
3126 for (; formal; formal = formal->next, actual = actual->next, i++)
3127 {
3128 gfc_typespec ts;
3129
3130 if (actual->expr == NULL)
3131 continue;
3132
3133 ts = formal->ts;
3134
3135 /* A kind of 0 means we don't check for kind. */
3136 if (ts.kind == 0)
3137 ts.kind = actual->expr->ts.kind;
3138
3139 if (!gfc_compare_types (&ts, &actual->expr->ts))
3140 {
3141 if (error_flag)
3142 gfc_error ("Type of argument '%s' in call to '%s' at %L should "
3143 "be %s, not %s", gfc_current_intrinsic_arg[i],
3144 gfc_current_intrinsic, &actual->expr->where,
3145 gfc_typename (&formal->ts),
3146 gfc_typename (&actual->expr->ts));
3147 return FAILURE;
3148 }
3149 }
3150
3151 return SUCCESS;
3152 }
3153
3154
3155 /* Given a pointer to an intrinsic symbol and an expression node that
3156 represent the function call to that subroutine, figure out the type
3157 of the result. This may involve calling a resolution subroutine. */
3158
3159 static void
3160 resolve_intrinsic (gfc_intrinsic_sym *specific, gfc_expr *e)
3161 {
3162 gfc_expr *a1, *a2, *a3, *a4, *a5;
3163 gfc_actual_arglist *arg;
3164
3165 if (specific->resolve.f1 == NULL)
3166 {
3167 if (e->value.function.name == NULL)
3168 e->value.function.name = specific->lib_name;
3169
3170 if (e->ts.type == BT_UNKNOWN)
3171 e->ts = specific->ts;
3172 return;
3173 }
3174
3175 arg = e->value.function.actual;
3176
3177 /* Special case hacks for MIN and MAX. */
3178 if (specific->resolve.f1m == gfc_resolve_max
3179 || specific->resolve.f1m == gfc_resolve_min)
3180 {
3181 (*specific->resolve.f1m) (e, arg);
3182 return;
3183 }
3184
3185 if (arg == NULL)
3186 {
3187 (*specific->resolve.f0) (e);
3188 return;
3189 }
3190
3191 a1 = arg->expr;
3192 arg = arg->next;
3193
3194 if (arg == NULL)
3195 {
3196 (*specific->resolve.f1) (e, a1);
3197 return;
3198 }
3199
3200 a2 = arg->expr;
3201 arg = arg->next;
3202
3203 if (arg == NULL)
3204 {
3205 (*specific->resolve.f2) (e, a1, a2);
3206 return;
3207 }
3208
3209 a3 = arg->expr;
3210 arg = arg->next;
3211
3212 if (arg == NULL)
3213 {
3214 (*specific->resolve.f3) (e, a1, a2, a3);
3215 return;
3216 }
3217
3218 a4 = arg->expr;
3219 arg = arg->next;
3220
3221 if (arg == NULL)
3222 {
3223 (*specific->resolve.f4) (e, a1, a2, a3, a4);
3224 return;
3225 }
3226
3227 a5 = arg->expr;
3228 arg = arg->next;
3229
3230 if (arg == NULL)
3231 {
3232 (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
3233 return;
3234 }
3235
3236 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
3237 }
3238
3239
3240 /* Given an intrinsic symbol node and an expression node, call the
3241 simplification function (if there is one), perhaps replacing the
3242 expression with something simpler. We return FAILURE on an error
3243 of the simplification, SUCCESS if the simplification worked, even
3244 if nothing has changed in the expression itself. */
3245
3246 static try
3247 do_simplify (gfc_intrinsic_sym *specific, gfc_expr *e)
3248 {
3249 gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
3250 gfc_actual_arglist *arg;
3251
3252 /* Max and min require special handling due to the variable number
3253 of args. */
3254 if (specific->simplify.f1 == gfc_simplify_min)
3255 {
3256 result = gfc_simplify_min (e);
3257 goto finish;
3258 }
3259
3260 if (specific->simplify.f1 == gfc_simplify_max)
3261 {
3262 result = gfc_simplify_max (e);
3263 goto finish;
3264 }
3265
3266 if (specific->simplify.f1 == NULL)
3267 {
3268 result = NULL;
3269 goto finish;
3270 }
3271
3272 arg = e->value.function.actual;
3273
3274 if (arg == NULL)
3275 {
3276 result = (*specific->simplify.f0) ();
3277 goto finish;
3278 }
3279
3280 a1 = arg->expr;
3281 arg = arg->next;
3282
3283 if (specific->simplify.cc == gfc_convert_constant
3284 || specific->simplify.cc == gfc_convert_char_constant)
3285 {
3286 result = specific->simplify.cc (a1, specific->ts.type, specific->ts.kind);
3287 goto finish;
3288 }
3289
3290 /* TODO: Warn if -pedantic and initialization expression and arg
3291 types not integer or character */
3292
3293 if (arg == NULL)
3294 result = (*specific->simplify.f1) (a1);
3295 else
3296 {
3297 a2 = arg->expr;
3298 arg = arg->next;
3299
3300 if (arg == NULL)
3301 result = (*specific->simplify.f2) (a1, a2);
3302 else
3303 {
3304 a3 = arg->expr;
3305 arg = arg->next;
3306
3307 if (arg == NULL)
3308 result = (*specific->simplify.f3) (a1, a2, a3);
3309 else
3310 {
3311 a4 = arg->expr;
3312 arg = arg->next;
3313
3314 if (arg == NULL)
3315 result = (*specific->simplify.f4) (a1, a2, a3, a4);
3316 else
3317 {
3318 a5 = arg->expr;
3319 arg = arg->next;
3320
3321 if (arg == NULL)
3322 result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
3323 else
3324 gfc_internal_error
3325 ("do_simplify(): Too many args for intrinsic");
3326 }
3327 }
3328 }
3329 }
3330
3331 finish:
3332 if (result == &gfc_bad_expr)
3333 return FAILURE;
3334
3335 if (result == NULL)
3336 resolve_intrinsic (specific, e); /* Must call at run-time */
3337 else
3338 {
3339 result->where = e->where;
3340 gfc_replace_expr (e, result);
3341 }
3342
3343 return SUCCESS;
3344 }
3345
3346
3347 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
3348 error messages. This subroutine returns FAILURE if a subroutine
3349 has more than MAX_INTRINSIC_ARGS, in which case the actual argument
3350 list cannot match any intrinsic. */
3351
3352 static void
3353 init_arglist (gfc_intrinsic_sym *isym)
3354 {
3355 gfc_intrinsic_arg *formal;
3356 int i;
3357
3358 gfc_current_intrinsic = isym->name;
3359
3360 i = 0;
3361 for (formal = isym->formal; formal; formal = formal->next)
3362 {
3363 if (i >= MAX_INTRINSIC_ARGS)
3364 gfc_internal_error ("init_arglist(): too many arguments");
3365 gfc_current_intrinsic_arg[i++] = formal->name;
3366 }
3367 }
3368
3369
3370 /* Given a pointer to an intrinsic symbol and an expression consisting
3371 of a function call, see if the function call is consistent with the
3372 intrinsic's formal argument list. Return SUCCESS if the expression
3373 and intrinsic match, FAILURE otherwise. */
3374
3375 static try
3376 check_specific (gfc_intrinsic_sym *specific, gfc_expr *expr, int error_flag)
3377 {
3378 gfc_actual_arglist *arg, **ap;
3379 try t;
3380
3381 ap = &expr->value.function.actual;
3382
3383 init_arglist (specific);
3384
3385 /* Don't attempt to sort the argument list for min or max. */
3386 if (specific->check.f1m == gfc_check_min_max
3387 || specific->check.f1m == gfc_check_min_max_integer
3388 || specific->check.f1m == gfc_check_min_max_real
3389 || specific->check.f1m == gfc_check_min_max_double)
3390 return (*specific->check.f1m) (*ap);
3391
3392 if (sort_actual (specific->name, ap, specific->formal,
3393 &expr->where) == FAILURE)
3394 return FAILURE;
3395
3396 if (specific->check.f3ml == gfc_check_minloc_maxloc)
3397 /* This is special because we might have to reorder the argument list. */
3398 t = gfc_check_minloc_maxloc (*ap);
3399 else if (specific->check.f3red == gfc_check_minval_maxval)
3400 /* This is also special because we also might have to reorder the
3401 argument list. */
3402 t = gfc_check_minval_maxval (*ap);
3403 else if (specific->check.f3red == gfc_check_product_sum)
3404 /* Same here. The difference to the previous case is that we allow a
3405 general numeric type. */
3406 t = gfc_check_product_sum (*ap);
3407 else
3408 {
3409 if (specific->check.f1 == NULL)
3410 {
3411 t = check_arglist (ap, specific, error_flag);
3412 if (t == SUCCESS)
3413 expr->ts = specific->ts;
3414 }
3415 else
3416 t = do_check (specific, *ap);
3417 }
3418
3419 /* Check conformance of elemental intrinsics. */
3420 if (t == SUCCESS && specific->elemental)
3421 {
3422 int n = 0;
3423 gfc_expr *first_expr;
3424 arg = expr->value.function.actual;
3425
3426 /* There is no elemental intrinsic without arguments. */
3427 gcc_assert(arg != NULL);
3428 first_expr = arg->expr;
3429
3430 for ( ; arg && arg->expr; arg = arg->next, n++)
3431 {
3432 char buffer[80];
3433 snprintf (buffer, 80, "arguments '%s' and '%s' for intrinsic '%s'",
3434 gfc_current_intrinsic_arg[0], gfc_current_intrinsic_arg[n],
3435 gfc_current_intrinsic);
3436 if (gfc_check_conformance (buffer, first_expr, arg->expr) == FAILURE)
3437 return FAILURE;
3438 }
3439 }
3440
3441 if (t == FAILURE)
3442 remove_nullargs (ap);
3443
3444 return t;
3445 }
3446
3447
3448 /* Check whether an intrinsic belongs to whatever standard the user
3449 has chosen. */
3450
3451 static try
3452 check_intrinsic_standard (const char *name, int standard, locus *where)
3453 {
3454 /* Do not warn about GNU-extensions if -std=gnu. */
3455 if (!gfc_option.warn_nonstd_intrinsics
3456 || (standard == GFC_STD_GNU && gfc_option.warn_std & GFC_STD_GNU))
3457 return SUCCESS;
3458
3459 if (gfc_notify_std (standard, "Intrinsic '%s' at %L is not included "
3460 "in the selected standard", name, where) == FAILURE)
3461 return FAILURE;
3462
3463 return SUCCESS;
3464 }
3465
3466
3467 /* See if a function call corresponds to an intrinsic function call.
3468 We return:
3469
3470 MATCH_YES if the call corresponds to an intrinsic, simplification
3471 is done if possible.
3472
3473 MATCH_NO if the call does not correspond to an intrinsic
3474
3475 MATCH_ERROR if the call corresponds to an intrinsic but there was an
3476 error during the simplification process.
3477
3478 The error_flag parameter enables an error reporting. */
3479
3480 match
3481 gfc_intrinsic_func_interface (gfc_expr *expr, int error_flag)
3482 {
3483 gfc_intrinsic_sym *isym, *specific;
3484 gfc_actual_arglist *actual;
3485 const char *name;
3486 int flag;
3487
3488 if (expr->value.function.isym != NULL)
3489 return (do_simplify (expr->value.function.isym, expr) == FAILURE)
3490 ? MATCH_ERROR : MATCH_YES;
3491
3492 gfc_suppress_error = !error_flag;
3493 flag = 0;
3494
3495 for (actual = expr->value.function.actual; actual; actual = actual->next)
3496 if (actual->expr != NULL)
3497 flag |= (actual->expr->ts.type != BT_INTEGER
3498 && actual->expr->ts.type != BT_CHARACTER);
3499
3500 name = expr->symtree->n.sym->name;
3501
3502 isym = specific = gfc_find_function (name);
3503 if (isym == NULL)
3504 {
3505 gfc_suppress_error = 0;
3506 return MATCH_NO;
3507 }
3508
3509 if (check_intrinsic_standard (name, isym->standard, &expr->where) == FAILURE)
3510 return MATCH_ERROR;
3511
3512 if ((isym->id == GFC_ISYM_REAL || isym->id == GFC_ISYM_DBLE
3513 || isym->id == GFC_ISYM_CMPLX)
3514 && gfc_init_expr
3515 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Function '%s' "
3516 "as initialization expression at %L", name,
3517 &expr->where) == FAILURE)
3518 return MATCH_ERROR;
3519
3520 gfc_current_intrinsic_where = &expr->where;
3521
3522 /* Bypass the generic list for min and max. */
3523 if (isym->check.f1m == gfc_check_min_max)
3524 {
3525 init_arglist (isym);
3526
3527 if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
3528 goto got_specific;
3529
3530 gfc_suppress_error = 0;
3531 return MATCH_NO;
3532 }
3533
3534 /* If the function is generic, check all of its specific
3535 incarnations. If the generic name is also a specific, we check
3536 that name last, so that any error message will correspond to the
3537 specific. */
3538 gfc_suppress_error = 1;
3539
3540 if (isym->generic)
3541 {
3542 for (specific = isym->specific_head; specific;
3543 specific = specific->next)
3544 {
3545 if (specific == isym)
3546 continue;
3547 if (check_specific (specific, expr, 0) == SUCCESS)
3548 goto got_specific;
3549 }
3550 }
3551
3552 gfc_suppress_error = !error_flag;
3553
3554 if (check_specific (isym, expr, error_flag) == FAILURE)
3555 {
3556 gfc_suppress_error = 0;
3557 return MATCH_NO;
3558 }
3559
3560 specific = isym;
3561
3562 got_specific:
3563 expr->value.function.isym = specific;
3564 gfc_intrinsic_symbol (expr->symtree->n.sym);
3565
3566 gfc_suppress_error = 0;
3567 if (do_simplify (specific, expr) == FAILURE)
3568 return MATCH_ERROR;
3569
3570 /* F95, 7.1.6.1, Initialization expressions
3571 (4) An elemental intrinsic function reference of type integer or
3572 character where each argument is an initialization expression
3573 of type integer or character
3574
3575 F2003, 7.1.7 Initialization expression
3576 (4) A reference to an elemental standard intrinsic function,
3577 where each argument is an initialization expression */
3578
3579 if (gfc_init_expr && isym->elemental && flag
3580 && gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Elemental function "
3581 "as initialization expression with non-integer/non-"
3582 "character arguments at %L", &expr->where) == FAILURE)
3583 return MATCH_ERROR;
3584
3585 return MATCH_YES;
3586 }
3587
3588
3589 /* See if a CALL statement corresponds to an intrinsic subroutine.
3590 Returns MATCH_YES if the subroutine corresponds to an intrinsic,
3591 MATCH_NO if not, and MATCH_ERROR if there was an error (but did
3592 correspond). */
3593
3594 match
3595 gfc_intrinsic_sub_interface (gfc_code *c, int error_flag)
3596 {
3597 gfc_intrinsic_sym *isym;
3598 const char *name;
3599
3600 name = c->symtree->n.sym->name;
3601
3602 isym = gfc_find_subroutine (name);
3603 if (isym == NULL)
3604 return MATCH_NO;
3605
3606 if (check_intrinsic_standard (name, isym->standard, &c->loc) == FAILURE)
3607 return MATCH_ERROR;
3608
3609 gfc_suppress_error = !error_flag;
3610
3611 init_arglist (isym);
3612
3613 if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
3614 goto fail;
3615
3616 if (isym->check.f1 != NULL)
3617 {
3618 if (do_check (isym, c->ext.actual) == FAILURE)
3619 goto fail;
3620 }
3621 else
3622 {
3623 if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
3624 goto fail;
3625 }
3626
3627 /* The subroutine corresponds to an intrinsic. Allow errors to be
3628 seen at this point. */
3629 gfc_suppress_error = 0;
3630
3631 if (isym->resolve.s1 != NULL)
3632 isym->resolve.s1 (c);
3633 else
3634 {
3635 c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
3636 c->resolved_sym->attr.elemental = isym->elemental;
3637 }
3638
3639 if (gfc_pure (NULL) && !isym->elemental)
3640 {
3641 gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
3642 &c->loc);
3643 return MATCH_ERROR;
3644 }
3645
3646 c->resolved_sym->attr.noreturn = isym->noreturn;
3647
3648 return MATCH_YES;
3649
3650 fail:
3651 gfc_suppress_error = 0;
3652 return MATCH_NO;
3653 }
3654
3655
3656 /* Call gfc_convert_type() with warning enabled. */
3657
3658 try
3659 gfc_convert_type (gfc_expr *expr, gfc_typespec *ts, int eflag)
3660 {
3661 return gfc_convert_type_warn (expr, ts, eflag, 1);
3662 }
3663
3664
3665 /* Try to convert an expression (in place) from one type to another.
3666 'eflag' controls the behavior on error.
3667
3668 The possible values are:
3669
3670 1 Generate a gfc_error()
3671 2 Generate a gfc_internal_error().
3672
3673 'wflag' controls the warning related to conversion. */
3674
3675 try
3676 gfc_convert_type_warn (gfc_expr *expr, gfc_typespec *ts, int eflag, int wflag)
3677 {
3678 gfc_intrinsic_sym *sym;
3679 gfc_typespec from_ts;
3680 locus old_where;
3681 gfc_expr *new;
3682 int rank;
3683 mpz_t *shape;
3684
3685 from_ts = expr->ts; /* expr->ts gets clobbered */
3686
3687 if (ts->type == BT_UNKNOWN)
3688 goto bad;
3689
3690 /* NULL and zero size arrays get their type here. */
3691 if (expr->expr_type == EXPR_NULL
3692 || (expr->expr_type == EXPR_ARRAY && expr->value.constructor == NULL))
3693 {
3694 /* Sometimes the RHS acquire the type. */
3695 expr->ts = *ts;
3696 return SUCCESS;
3697 }
3698
3699 if (expr->ts.type == BT_UNKNOWN)
3700 goto bad;
3701
3702 if (expr->ts.type == BT_DERIVED && ts->type == BT_DERIVED
3703 && gfc_compare_types (&expr->ts, ts))
3704 return SUCCESS;
3705
3706 sym = find_conv (&expr->ts, ts);
3707 if (sym == NULL)
3708 goto bad;
3709
3710 /* At this point, a conversion is necessary. A warning may be needed. */
3711 if ((gfc_option.warn_std & sym->standard) != 0)
3712 gfc_warning_now ("Extension: Conversion from %s to %s at %L",
3713 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3714 else if (wflag && gfc_option.warn_conversion)
3715 gfc_warning_now ("Conversion from %s to %s at %L",
3716 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3717
3718 /* Insert a pre-resolved function call to the right function. */
3719 old_where = expr->where;
3720 rank = expr->rank;
3721 shape = expr->shape;
3722
3723 new = gfc_get_expr ();
3724 *new = *expr;
3725
3726 new = gfc_build_conversion (new);
3727 new->value.function.name = sym->lib_name;
3728 new->value.function.isym = sym;
3729 new->where = old_where;
3730 new->rank = rank;
3731 new->shape = gfc_copy_shape (shape, rank);
3732
3733 gfc_get_ha_sym_tree (sym->name, &new->symtree);
3734 new->symtree->n.sym->ts = *ts;
3735 new->symtree->n.sym->attr.flavor = FL_PROCEDURE;
3736 new->symtree->n.sym->attr.function = 1;
3737 new->symtree->n.sym->attr.elemental = 1;
3738 new->symtree->n.sym->attr.pure = 1;
3739 new->symtree->n.sym->attr.referenced = 1;
3740 gfc_intrinsic_symbol(new->symtree->n.sym);
3741 gfc_commit_symbol (new->symtree->n.sym);
3742
3743 *expr = *new;
3744
3745 gfc_free (new);
3746 expr->ts = *ts;
3747
3748 if (gfc_is_constant_expr (expr->value.function.actual->expr)
3749 && do_simplify (sym, expr) == FAILURE)
3750 {
3751
3752 if (eflag == 2)
3753 goto bad;
3754 return FAILURE; /* Error already generated in do_simplify() */
3755 }
3756
3757 return SUCCESS;
3758
3759 bad:
3760 if (eflag == 1)
3761 {
3762 gfc_error ("Can't convert %s to %s at %L",
3763 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
3764 return FAILURE;
3765 }
3766
3767 gfc_internal_error ("Can't convert %s to %s at %L",
3768 gfc_typename (&from_ts), gfc_typename (ts),
3769 &expr->where);
3770 /* Not reached */
3771 }
3772
3773
3774 try
3775 gfc_convert_chartype (gfc_expr *expr, gfc_typespec *ts)
3776 {
3777 gfc_intrinsic_sym *sym;
3778 gfc_typespec from_ts;
3779 locus old_where;
3780 gfc_expr *new;
3781 int rank;
3782 mpz_t *shape;
3783
3784 gcc_assert (expr->ts.type == BT_CHARACTER && ts->type == BT_CHARACTER);
3785 from_ts = expr->ts; /* expr->ts gets clobbered */
3786
3787 sym = find_char_conv (&expr->ts, ts);
3788 gcc_assert (sym);
3789
3790 /* Insert a pre-resolved function call to the right function. */
3791 old_where = expr->where;
3792 rank = expr->rank;
3793 shape = expr->shape;
3794
3795 new = gfc_get_expr ();
3796 *new = *expr;
3797
3798 new = gfc_build_conversion (new);
3799 new->value.function.name = sym->lib_name;
3800 new->value.function.isym = sym;
3801 new->where = old_where;
3802 new->rank = rank;
3803 new->shape = gfc_copy_shape (shape, rank);
3804
3805 gfc_get_ha_sym_tree (sym->name, &new->symtree);
3806 new->symtree->n.sym->ts = *ts;
3807 new->symtree->n.sym->attr.flavor = FL_PROCEDURE;
3808 new->symtree->n.sym->attr.function = 1;
3809 new->symtree->n.sym->attr.elemental = 1;
3810 new->symtree->n.sym->attr.referenced = 1;
3811 gfc_intrinsic_symbol(new->symtree->n.sym);
3812 gfc_commit_symbol (new->symtree->n.sym);
3813
3814 *expr = *new;
3815
3816 gfc_free (new);
3817 expr->ts = *ts;
3818
3819 if (gfc_is_constant_expr (expr->value.function.actual->expr)
3820 && do_simplify (sym, expr) == FAILURE)
3821 {
3822 /* Error already generated in do_simplify() */
3823 return FAILURE;
3824 }
3825
3826 return SUCCESS;
3827 }