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