1 /* Build up a list of intrinsic subroutines and functions for the
3 Copyright (C) 2000, 2001, 2002, 2003, 2004 Free Software Foundation,
5 Contributed by Andy Vaught & Katherine Holcomb
7 This file is part of GCC.
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
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
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, 59 Temple Place - Suite 330, Boston, MA
35 #include "intrinsic.h"
38 /* Nanespace to hold the resolved symbols for intrinsic subroutines. */
39 static gfc_namespace *gfc_intrinsic_namespace;
41 int gfc_init_expr = 0;
43 /* Pointers to a intrinsic function and its argument names being
46 char *gfc_current_intrinsic, *gfc_current_intrinsic_arg[MAX_INTRINSIC_ARGS];
47 locus *gfc_current_intrinsic_where;
49 static gfc_intrinsic_sym *functions, *subroutines, *conversion, *next_sym;
50 static gfc_intrinsic_arg *next_arg;
52 static int nfunc, nsub, nargs, nconv;
55 { SZ_NOTHING = 0, SZ_SUBS, SZ_FUNCS, SZ_CONVS }
59 /* Return a letter based on the passed type. Used to construct the
60 name of a type-dependent subroutine. */
63 gfc_type_letter (bt type)
94 /* Get a symbol for a resolved name. */
97 gfc_get_intrinsic_sub_symbol (const char * name)
101 gfc_get_symbol (name, gfc_intrinsic_namespace, &sym);
102 sym->attr.always_explicit = 1;
103 sym->attr.subroutine = 1;
104 sym->attr.flavor = FL_PROCEDURE;
105 sym->attr.proc = PROC_INTRINSIC;
111 /* Return a pointer to the name of a conversion function given two
115 conv_name (gfc_typespec * from, gfc_typespec * to)
117 static char name[30];
119 sprintf (name, "__convert_%c%d_%c%d", gfc_type_letter (from->type),
120 from->kind, gfc_type_letter (to->type), to->kind);
126 /* Given a pair of typespecs, find the gfc_intrinsic_sym node that
127 corresponds to the conversion. Returns NULL if the conversion
130 static gfc_intrinsic_sym *
131 find_conv (gfc_typespec * from, gfc_typespec * to)
133 gfc_intrinsic_sym *sym;
137 target = conv_name (from, to);
140 for (i = 0; i < nconv; i++, sym++)
141 if (strcmp (target, sym->name) == 0)
148 /* Interface to the check functions. We break apart an argument list
149 and call the proper check function rather than forcing each
150 function to manipulate the argument list. */
153 do_check (gfc_intrinsic_sym * specific, gfc_actual_arglist * arg)
155 gfc_expr *a1, *a2, *a3, *a4, *a5;
162 t = (*specific->check.f1) (a1);
169 t = (*specific->check.f2) (a1, a2);
176 t = (*specific->check.f3) (a1, a2, a3);
183 t = (*specific->check.f4) (a1, a2, a3, a4);
190 t = (*specific->check.f5) (a1, a2, a3, a4, a5);
193 gfc_internal_error ("do_check(): too many args");
204 /*********** Subroutines to build the intrinsic list ****************/
206 /* Add a single intrinsic symbol to the current list.
209 char * name of function
210 int whether function is elemental
211 int If the function can be used as an actual argument
212 bt return type of function
213 int kind of return type of function
214 check pointer to check function
215 simplify pointer to simplification function
216 resolve pointer to resolution function
218 Optional arguments come in multiples of four:
219 char * name of argument
222 int arg optional flag (1=optional, 0=required)
224 The sequence is terminated by a NULL name.
226 TODO: Are checks on actual_ok implemented elsewhere, or is that just
230 add_sym (const char *name, int elemental, int actual_ok ATTRIBUTE_UNUSED,
231 bt type, int kind, gfc_check_f check, gfc_simplify_f simplify,
232 gfc_resolve_f resolve, ...)
235 int optional, first_flag;
249 strcpy (next_sym->name, name);
251 strcpy (next_sym->lib_name, "_gfortran_");
252 strcat (next_sym->lib_name, name);
254 next_sym->elemental = elemental;
255 next_sym->ts.type = type;
256 next_sym->ts.kind = kind;
257 next_sym->simplify = simplify;
258 next_sym->check = check;
259 next_sym->resolve = resolve;
260 next_sym->specific = 0;
261 next_sym->generic = 0;
265 gfc_internal_error ("add_sym(): Bad sizing mode");
268 va_start (argp, resolve);
274 name = va_arg (argp, char *);
278 type = (bt) va_arg (argp, int);
279 kind = va_arg (argp, int);
280 optional = va_arg (argp, int);
282 if (sizing != SZ_NOTHING)
289 next_sym->formal = next_arg;
291 (next_arg - 1)->next = next_arg;
295 strcpy (next_arg->name, name);
296 next_arg->ts.type = type;
297 next_arg->ts.kind = kind;
298 next_arg->optional = optional;
308 static void add_sym_0 (const char *name, int elemental, int actual_ok, bt type,
310 try (*check)(gfc_expr *),
311 gfc_expr *(*simplify)(gfc_expr *),
312 void (*resolve)(gfc_expr *,gfc_expr *)
322 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
327 static void add_sym_1 (const char *name, int elemental, int actual_ok, bt type,
329 try (*check)(gfc_expr *),
330 gfc_expr *(*simplify)(gfc_expr *),
331 void (*resolve)(gfc_expr *,gfc_expr *),
332 const char* a1, bt type1, int kind1, int optional1
342 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
343 a1, type1, kind1, optional1,
349 add_sym_0s (const char * name, int actual_ok,
350 void (*resolve)(gfc_code *))
360 add_sym (name, 1, actual_ok, BT_UNKNOWN, 0, cf, sf, rf,
365 static void add_sym_1s (const char *name, int elemental, int actual_ok, bt type,
367 try (*check)(gfc_expr *),
368 gfc_expr *(*simplify)(gfc_expr *),
369 void (*resolve)(gfc_code *),
370 const char* a1, bt type1, int kind1, int optional1
380 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
381 a1, type1, kind1, optional1,
386 static void add_sym_1m (const char *name, int elemental, int actual_ok, bt type,
388 try (*check)(gfc_actual_arglist *),
389 gfc_expr *(*simplify)(gfc_expr *),
390 void (*resolve)(gfc_expr *,gfc_actual_arglist *),
391 const char* a1, bt type1, int kind1, int optional1,
392 const char* a2, bt type2, int kind2, int optional2
402 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
403 a1, type1, kind1, optional1,
404 a2, type2, kind2, optional2,
409 static void add_sym_2 (const char *name, int elemental, int actual_ok, bt type,
411 try (*check)(gfc_expr *,gfc_expr *),
412 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
413 void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *),
414 const char* a1, bt type1, int kind1, int optional1,
415 const char* a2, bt type2, int kind2, int optional2
425 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
426 a1, type1, kind1, optional1,
427 a2, type2, kind2, optional2,
432 /* Add the name of an intrinsic subroutine with two arguments to the list
433 of intrinsic names. */
435 static void add_sym_2s (const char *name, int elemental, int actual_ok, bt type,
437 try (*check)(gfc_expr *,gfc_expr *),
438 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *),
439 void (*resolve)(gfc_code *),
440 const char* a1, bt type1, int kind1, int optional1,
441 const char* a2, bt type2, int kind2, int optional2
451 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
452 a1, type1, kind1, optional1,
453 a2, type2, kind2, optional2,
458 static void add_sym_3 (const char *name, int elemental, int actual_ok, bt type,
460 try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
461 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
462 void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
463 const char* a1, bt type1, int kind1, int optional1,
464 const char* a2, bt type2, int kind2, int optional2,
465 const char* a3, bt type3, int kind3, int optional3
475 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
476 a1, type1, kind1, optional1,
477 a2, type2, kind2, optional2,
478 a3, type3, kind3, optional3,
482 /* MINLOC and MAXLOC get special treatment because their argument
483 might have to be reordered. */
485 static void add_sym_3ml (const char *name, int elemental,
486 int actual_ok, bt type, int kind,
487 try (*check)(gfc_actual_arglist *),
488 gfc_expr*(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
489 void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
490 const char* a1, bt type1, int kind1, int optional1,
491 const char* a2, bt type2, int kind2, int optional2,
492 const char* a3, bt type3, int kind3, int optional3
502 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
503 a1, type1, kind1, optional1,
504 a2, type2, kind2, optional2,
505 a3, type3, kind3, optional3,
509 /* Add the name of an intrinsic subroutine with three arguments to the list
510 of intrinsic names. */
512 static void add_sym_3s (const char *name, int elemental, int actual_ok, bt type,
514 try (*check)(gfc_expr *,gfc_expr *,gfc_expr *),
515 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *),
516 void (*resolve)(gfc_code *),
517 const char* a1, bt type1, int kind1, int optional1,
518 const char* a2, bt type2, int kind2, int optional2,
519 const char* a3, bt type3, int kind3, int optional3
529 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
530 a1, type1, kind1, optional1,
531 a2, type2, kind2, optional2,
532 a3, type3, kind3, optional3,
537 static void add_sym_4 (const char *name, int elemental, int actual_ok, bt type,
539 try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
540 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
541 void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
542 const char* a1, bt type1, int kind1, int optional1,
543 const char* a2, bt type2, int kind2, int optional2,
544 const char* a3, bt type3, int kind3, int optional3,
545 const char* a4, bt type4, int kind4, int optional4
555 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
556 a1, type1, kind1, optional1,
557 a2, type2, kind2, optional2,
558 a3, type3, kind3, optional3,
559 a4, type4, kind4, optional4,
564 static void add_sym_4s (const char *name, int elemental, int actual_ok,
566 try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
567 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
568 void (*resolve)(gfc_code *),
569 const char* a1, bt type1, int kind1, int optional1,
570 const char* a2, bt type2, int kind2, int optional2,
571 const char* a3, bt type3, int kind3, int optional3,
572 const char* a4, bt type4, int kind4, int optional4)
582 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
583 a1, type1, kind1, optional1,
584 a2, type2, kind2, optional2,
585 a3, type3, kind3, optional3,
586 a4, type4, kind4, optional4,
591 static void add_sym_5 (const char *name, int elemental, int actual_ok, bt type,
593 try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
594 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
595 void (*resolve)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
596 const char* a1, bt type1, int kind1, int optional1,
597 const char* a2, bt type2, int kind2, int optional2,
598 const char* a3, bt type3, int kind3, int optional3,
599 const char* a4, bt type4, int kind4, int optional4,
600 const char* a5, bt type5, int kind5, int optional5
610 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
611 a1, type1, kind1, optional1,
612 a2, type2, kind2, optional2,
613 a3, type3, kind3, optional3,
614 a4, type4, kind4, optional4,
615 a5, type5, kind5, optional5,
620 static void add_sym_5s
622 const char *name, int elemental, int actual_ok, bt type, int kind,
623 try (*check)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
624 gfc_expr *(*simplify)(gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *,gfc_expr *),
625 void (*resolve)(gfc_code *),
626 const char* a1, bt type1, int kind1, int optional1,
627 const char* a2, bt type2, int kind2, int optional2,
628 const char* a3, bt type3, int kind3, int optional3,
629 const char* a4, bt type4, int kind4, int optional4,
630 const char* a5, bt type5, int kind5, int optional5)
640 add_sym (name, elemental, actual_ok, type, kind, cf, sf, rf,
641 a1, type1, kind1, optional1,
642 a2, type2, kind2, optional2,
643 a3, type3, kind3, optional3,
644 a4, type4, kind4, optional4,
645 a5, type5, kind5, optional5,
650 /* Locate an intrinsic symbol given a base pointer, number of elements
651 in the table and a pointer to a name. Returns the NULL pointer if
652 a name is not found. */
654 static gfc_intrinsic_sym *
655 find_sym (gfc_intrinsic_sym * start, int n, const char *name)
660 if (strcmp (name, start->name) == 0)
671 /* Given a name, find a function in the intrinsic function table.
672 Returns NULL if not found. */
675 gfc_find_function (const char *name)
678 return find_sym (functions, nfunc, name);
682 /* Given a name, find a function in the intrinsic subroutine table.
683 Returns NULL if not found. */
685 static gfc_intrinsic_sym *
686 find_subroutine (const char *name)
689 return find_sym (subroutines, nsub, name);
693 /* Given a string, figure out if it is the name of a generic intrinsic
697 gfc_generic_intrinsic (const char *name)
699 gfc_intrinsic_sym *sym;
701 sym = gfc_find_function (name);
702 return (sym == NULL) ? 0 : sym->generic;
706 /* Given a string, figure out if it is the name of a specific
707 intrinsic function or not. */
710 gfc_specific_intrinsic (const char *name)
712 gfc_intrinsic_sym *sym;
714 sym = gfc_find_function (name);
715 return (sym == NULL) ? 0 : sym->specific;
719 /* Given a string, figure out if it is the name of an intrinsic
720 subroutine or function. There are no generic intrinsic
721 subroutines, they are all specific. */
724 gfc_intrinsic_name (const char *name, int subroutine_flag)
727 return subroutine_flag ?
728 find_subroutine (name) != NULL : gfc_find_function (name) != NULL;
732 /* Collect a set of intrinsic functions into a generic collection.
733 The first argument is the name of the generic function, which is
734 also the name of a specific function. The rest of the specifics
735 currently in the table are placed into the list of specific
736 functions associated with that generic. */
739 make_generic (const char *name, gfc_generic_isym_id generic_id)
741 gfc_intrinsic_sym *g;
743 if (sizing != SZ_NOTHING)
746 g = gfc_find_function (name);
748 gfc_internal_error ("make_generic(): Can't find generic symbol '%s'",
753 g->generic_id = generic_id;
754 if ((g + 1)->name[0] != '\0')
755 g->specific_head = g + 1;
758 while (g->name[0] != '\0')
762 g->generic_id = generic_id;
771 /* Create a duplicate intrinsic function entry for the current
772 function, the only difference being the alternate name. Note that
773 we use argument lists more than once, but all argument lists are
774 freed as a single block. */
777 make_alias (const char *name)
791 next_sym[0] = next_sym[-1];
792 strcpy (next_sym->name, name);
802 /* Add intrinsic functions. */
808 /* Argument names as in the standard (to be used as argument keywords). */
810 *a = "a", *f = "field", *pt = "pointer", *tg = "target",
811 *b = "b", *m = "matrix", *ma = "matrix_a", *mb = "matrix_b",
812 *c = "c", *n = "ncopies", *pos = "pos", *bck = "back",
813 *i = "i", *v = "vector", *va = "vector_a", *vb = "vector_b",
814 *j = "j", *a1 = "a1", *fs = "fsource", *ts = "tsource",
815 *l = "l", *a2 = "a2", *mo = "mold", *ord = "order",
816 *p = "p", *ar = "array", *shp = "shape", *src = "source",
817 *r = "r", *bd = "boundary", *pad = "pad", *set = "set",
818 *s = "s", *dm = "dim", *kind = "kind", *msk = "mask",
819 *x = "x", *sh = "shift", *stg = "string", *ssg = "substring",
820 *y = "y", *sz = "size", *sta = "string_a", *stb = "string_b",
821 *z = "z", *ln = "len";
823 int di, dr, dd, dl, dc, dz, ii;
825 di = gfc_default_integer_kind ();
826 dr = gfc_default_real_kind ();
827 dd = gfc_default_double_kind ();
828 dl = gfc_default_logical_kind ();
829 dc = gfc_default_character_kind ();
830 dz = gfc_default_complex_kind ();
831 ii = gfc_index_integer_kind;
833 add_sym_1 ("abs", 1, 1, BT_REAL, dr,
834 gfc_check_abs, gfc_simplify_abs, gfc_resolve_abs,
837 add_sym_1 ("iabs", 1, 1, BT_INTEGER, di,
838 NULL, gfc_simplify_abs, gfc_resolve_abs,
839 a, BT_INTEGER, di, 0);
841 add_sym_1 ("dabs", 1, 1, BT_REAL, dd,
842 NULL, gfc_simplify_abs, gfc_resolve_abs, a, BT_REAL, dd, 0);
844 add_sym_1 ("cabs", 1, 1, BT_REAL, dr,
845 NULL, gfc_simplify_abs, gfc_resolve_abs,
846 a, BT_COMPLEX, dz, 0);
848 add_sym_1 ("zabs", 1, 1, BT_REAL, dd, NULL, gfc_simplify_abs, gfc_resolve_abs, a, BT_COMPLEX, dd, 0); /* Extension */
850 make_alias ("cdabs");
852 make_generic ("abs", GFC_ISYM_ABS);
854 add_sym_1 ("achar", 1, 1, BT_CHARACTER, dc,
855 NULL, gfc_simplify_achar, NULL, i, BT_INTEGER, di, 0);
857 make_generic ("achar", GFC_ISYM_ACHAR);
859 add_sym_1 ("acos", 1, 1, BT_REAL, dr,
860 NULL, gfc_simplify_acos, gfc_resolve_acos,
863 add_sym_1 ("dacos", 1, 1, BT_REAL, dd,
864 NULL, gfc_simplify_acos, gfc_resolve_acos,
867 make_generic ("acos", GFC_ISYM_ACOS);
869 add_sym_1 ("adjustl", 1, 1, BT_CHARACTER, dc,
870 NULL, gfc_simplify_adjustl, NULL, stg, BT_CHARACTER, dc, 0);
872 make_generic ("adjustl", GFC_ISYM_ADJUSTL);
874 add_sym_1 ("adjustr", 1, 1, BT_CHARACTER, dc,
875 NULL, gfc_simplify_adjustr, NULL, stg, BT_CHARACTER, dc, 0);
877 make_generic ("adjustr", GFC_ISYM_ADJUSTR);
879 add_sym_1 ("aimag", 1, 1, BT_REAL, dr,
880 NULL, gfc_simplify_aimag, gfc_resolve_aimag,
881 z, BT_COMPLEX, dz, 0);
883 add_sym_1 ("dimag", 1, 1, BT_REAL, dd, NULL, gfc_simplify_aimag, gfc_resolve_aimag, z, BT_COMPLEX, dd, 0); /* Extension */
885 make_generic ("aimag", GFC_ISYM_AIMAG);
887 add_sym_2 ("aint", 1, 1, BT_REAL, dr,
888 gfc_check_a_xkind, gfc_simplify_aint, gfc_resolve_aint,
889 a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1);
891 add_sym_1 ("dint", 1, 1, BT_REAL, dd,
892 NULL, gfc_simplify_dint, gfc_resolve_dint,
895 make_generic ("aint", GFC_ISYM_AINT);
897 add_sym_2 ("all", 0, 1, BT_UNKNOWN, 0,
898 gfc_check_all_any, NULL, gfc_resolve_all,
899 msk, BT_LOGICAL, dl, 0, dm, BT_INTEGER, ii, 1);
901 make_generic ("all", GFC_ISYM_ALL);
903 add_sym_1 ("allocated", 0, 1, BT_LOGICAL, dl,
904 gfc_check_allocated, NULL, NULL, ar, BT_UNKNOWN, 0, 0);
906 make_generic ("allocated", GFC_ISYM_ALLOCATED);
908 add_sym_2 ("anint", 1, 1, BT_REAL, dr,
909 gfc_check_a_xkind, gfc_simplify_anint, gfc_resolve_anint,
910 a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1);
912 add_sym_1 ("dnint", 1, 1, BT_REAL, dd,
913 NULL, gfc_simplify_dnint, gfc_resolve_dnint,
916 make_generic ("anint", GFC_ISYM_ANINT);
918 add_sym_2 ("any", 0, 1, BT_UNKNOWN, 0,
919 gfc_check_all_any, NULL, gfc_resolve_any,
920 msk, BT_LOGICAL, dl, 0, dm, BT_INTEGER, ii, 1);
922 make_generic ("any", GFC_ISYM_ANY);
924 add_sym_1 ("asin", 1, 1, BT_REAL, dr,
925 NULL, gfc_simplify_asin, gfc_resolve_asin,
928 add_sym_1 ("dasin", 1, 1, BT_REAL, dd,
929 NULL, gfc_simplify_asin, gfc_resolve_asin,
932 make_generic ("asin", GFC_ISYM_ASIN);
934 add_sym_2 ("associated", 0, 1, BT_LOGICAL, dl,
935 gfc_check_associated, NULL, NULL,
936 pt, BT_UNKNOWN, 0, 0, tg, BT_UNKNOWN, 0, 1);
938 make_generic ("associated", GFC_ISYM_ASSOCIATED);
940 add_sym_1 ("atan", 1, 1, BT_REAL, dr,
941 NULL, gfc_simplify_atan, gfc_resolve_atan,
944 add_sym_1 ("datan", 1, 1, BT_REAL, dd,
945 NULL, gfc_simplify_atan, gfc_resolve_atan,
948 make_generic ("atan", GFC_ISYM_ATAN);
950 add_sym_2 ("atan2", 1, 1, BT_REAL, dr,
951 NULL, gfc_simplify_atan2, gfc_resolve_atan2,
952 y, BT_REAL, dr, 0, x, BT_REAL, dr, 0);
954 add_sym_2 ("datan2", 1, 1, BT_REAL, dd,
955 NULL, gfc_simplify_atan2, gfc_resolve_atan2,
956 y, BT_REAL, dd, 0, x, BT_REAL, dd, 0);
958 make_generic ("atan2", GFC_ISYM_ATAN2);
960 add_sym_1 ("bit_size", 0, 1, BT_INTEGER, di,
961 gfc_check_i, gfc_simplify_bit_size, NULL,
962 i, BT_INTEGER, di, 0);
964 make_generic ("bit_size", GFC_ISYM_NONE);
966 add_sym_2 ("btest", 1, 1, BT_LOGICAL, dl,
967 gfc_check_btest, gfc_simplify_btest, gfc_resolve_btest,
968 i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0);
970 make_generic ("btest", GFC_ISYM_BTEST);
972 add_sym_2 ("ceiling", 1, 1, BT_INTEGER, di,
973 gfc_check_a_ikind, gfc_simplify_ceiling, gfc_resolve_ceiling,
974 a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1);
976 make_generic ("ceiling", GFC_ISYM_CEILING);
978 add_sym_2 ("char", 1, 0, BT_CHARACTER, dc,
979 gfc_check_char, gfc_simplify_char, gfc_resolve_char,
980 i, BT_INTEGER, di, 0, kind, BT_INTEGER, di, 1);
982 make_generic ("char", GFC_ISYM_CHAR);
984 add_sym_3 ("cmplx", 1, 1, BT_COMPLEX, dz,
985 gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
986 x, BT_UNKNOWN, dr, 0, y, BT_UNKNOWN, dr, 1,
987 kind, BT_INTEGER, di, 1);
989 make_generic ("cmplx", GFC_ISYM_CMPLX);
991 /* Making dcmplx a specific of cmplx causes cmplx to return a double
992 complex instead of the default complex. */
994 add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX, dd,
995 gfc_check_dcmplx, gfc_simplify_dcmplx, gfc_resolve_dcmplx,
996 x, BT_REAL, dd, 0, y, BT_REAL, dd, 1); /* Extension */
998 make_generic ("dcmplx", GFC_ISYM_CMPLX);
1000 add_sym_1 ("conjg", 1, 1, BT_COMPLEX, dz,
1001 NULL, gfc_simplify_conjg, gfc_resolve_conjg,
1002 z, BT_COMPLEX, dz, 0);
1004 add_sym_1 ("dconjg", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_conjg, gfc_resolve_conjg, z, BT_COMPLEX, dd, 0); /* Extension */
1006 make_generic ("conjg", GFC_ISYM_CONJG);
1008 add_sym_1 ("cos", 1, 1, BT_REAL, dr,
1009 NULL, gfc_simplify_cos, gfc_resolve_cos, x, BT_REAL, dr, 0);
1011 add_sym_1 ("dcos", 1, 1, BT_REAL, dd,
1012 NULL, gfc_simplify_cos, gfc_resolve_cos, x, BT_REAL, dd, 0);
1014 add_sym_1 ("ccos", 1, 1, BT_COMPLEX, dz,
1015 NULL, gfc_simplify_cos, gfc_resolve_cos,
1016 x, BT_COMPLEX, dz, 0);
1018 add_sym_1 ("zcos", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_cos, gfc_resolve_cos, x, BT_COMPLEX, dd, 0); /* Extension */
1020 make_alias ("cdcos");
1022 make_generic ("cos", GFC_ISYM_COS);
1024 add_sym_1 ("cosh", 1, 1, BT_REAL, dr,
1025 NULL, gfc_simplify_cosh, gfc_resolve_cosh,
1028 add_sym_1 ("dcosh", 1, 1, BT_REAL, dd,
1029 NULL, gfc_simplify_cosh, gfc_resolve_cosh,
1032 make_generic ("cosh", GFC_ISYM_COSH);
1034 add_sym_2 ("count", 0, 1, BT_INTEGER, di,
1035 gfc_check_count, NULL, gfc_resolve_count,
1036 msk, BT_LOGICAL, dl, 0, dm, BT_INTEGER, ii, 1);
1038 make_generic ("count", GFC_ISYM_COUNT);
1040 add_sym_3 ("cshift", 0, 1, BT_REAL, dr,
1041 gfc_check_cshift, NULL, gfc_resolve_cshift,
1042 ar, BT_REAL, dr, 0, sh, BT_INTEGER, di, 0,
1043 dm, BT_INTEGER, ii, 1);
1045 make_generic ("cshift", GFC_ISYM_CSHIFT);
1047 add_sym_1 ("dble", 1, 1, BT_REAL, dd,
1048 gfc_check_dble, gfc_simplify_dble, gfc_resolve_dble,
1051 make_alias ("dfloat");
1053 make_generic ("dble", GFC_ISYM_DBLE);
1055 add_sym_1 ("digits", 0, 1, BT_INTEGER, di,
1056 gfc_check_digits, gfc_simplify_digits, NULL,
1057 x, BT_UNKNOWN, dr, 0);
1059 make_generic ("digits", GFC_ISYM_NONE);
1061 add_sym_2 ("dim", 1, 1, BT_REAL, dr,
1062 gfc_check_a_p, gfc_simplify_dim, gfc_resolve_dim,
1063 x, BT_UNKNOWN, dr, 0, y, BT_UNKNOWN, dr, 0);
1065 add_sym_2 ("idim", 1, 1, BT_INTEGER, di,
1066 NULL, gfc_simplify_dim, gfc_resolve_dim,
1067 x, BT_INTEGER, di, 0, y, BT_INTEGER, di, 0);
1069 add_sym_2 ("ddim", 1, 1, BT_REAL, dd,
1070 NULL, gfc_simplify_dim, gfc_resolve_dim,
1071 x, BT_REAL, dd, 0, y, BT_REAL, dd, 0);
1073 make_generic ("dim", GFC_ISYM_DIM);
1075 add_sym_2 ("dot_product", 0, 1, BT_UNKNOWN, 0,
1076 gfc_check_dot_product, NULL, gfc_resolve_dot_product,
1077 va, BT_REAL, dr, 0, vb, BT_REAL, dr, 0);
1079 make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT);
1081 add_sym_2 ("dprod", 1, 1, BT_REAL, dd,
1082 NULL, gfc_simplify_dprod, gfc_resolve_dprod,
1083 x, BT_REAL, dr, 0, y, BT_REAL, dr, 0);
1085 make_generic ("dprod", GFC_ISYM_DPROD);
1087 add_sym_1 ("dreal", 1, 0, BT_REAL, dd, NULL, NULL, NULL, a, BT_COMPLEX, dd, 0); /* Extension */
1089 make_generic ("dreal", GFC_ISYM_REAL);
1091 add_sym_4 ("eoshift", 0, 1, BT_REAL, dr,
1092 gfc_check_eoshift, NULL, gfc_resolve_eoshift,
1093 ar, BT_REAL, dr, 0, sh, BT_INTEGER, ii, 0,
1094 bd, BT_REAL, dr, 1, dm, BT_INTEGER, ii, 1);
1096 make_generic ("eoshift", GFC_ISYM_EOSHIFT);
1098 add_sym_1 ("epsilon", 0, 1, BT_REAL, dr,
1099 gfc_check_x, gfc_simplify_epsilon, NULL,
1102 make_generic ("epsilon", GFC_ISYM_NONE);
1104 /* G77 compatibility */
1105 add_sym_1 ("etime", 0, 1, BT_REAL, 4,
1106 gfc_check_etime, NULL, NULL,
1109 make_alias ("dtime");
1111 make_generic ("etime", GFC_ISYM_ETIME);
1114 add_sym_1 ("exp", 1, 1, BT_REAL, dr,
1115 NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_REAL, dr, 0);
1117 add_sym_1 ("dexp", 1, 1, BT_REAL, dd,
1118 NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_REAL, dd, 0);
1120 add_sym_1 ("cexp", 1, 1, BT_COMPLEX, dz,
1121 NULL, gfc_simplify_exp, gfc_resolve_exp,
1122 x, BT_COMPLEX, dz, 0);
1124 add_sym_1 ("zexp", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_exp, gfc_resolve_exp, x, BT_COMPLEX, dd, 0); /* Extension */
1126 make_alias ("cdexp");
1128 make_generic ("exp", GFC_ISYM_EXP);
1130 add_sym_1 ("exponent", 1, 1, BT_INTEGER, di,
1131 gfc_check_x, gfc_simplify_exponent, gfc_resolve_exponent,
1134 make_generic ("exponent", GFC_ISYM_EXPONENT);
1136 add_sym_2 ("floor", 1, 1, BT_INTEGER, di,
1137 gfc_check_a_ikind, gfc_simplify_floor, gfc_resolve_floor,
1138 a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1);
1140 make_generic ("floor", GFC_ISYM_FLOOR);
1142 add_sym_1 ("fraction", 1, 1, BT_REAL, dr,
1143 gfc_check_x, gfc_simplify_fraction, gfc_resolve_fraction,
1146 make_generic ("fraction", GFC_ISYM_FRACTION);
1148 add_sym_1 ("huge", 0, 1, BT_REAL, dr,
1149 gfc_check_huge, gfc_simplify_huge, NULL,
1150 x, BT_UNKNOWN, dr, 0);
1152 make_generic ("huge", GFC_ISYM_NONE);
1154 add_sym_1 ("iachar", 1, 1, BT_INTEGER, di,
1155 NULL, gfc_simplify_iachar, NULL, c, BT_CHARACTER, dc, 0);
1157 make_generic ("iachar", GFC_ISYM_IACHAR);
1159 add_sym_2 ("iand", 1, 1, BT_INTEGER, di,
1160 gfc_check_iand, gfc_simplify_iand, gfc_resolve_iand,
1161 i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0);
1163 make_generic ("iand", GFC_ISYM_IAND);
1165 add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, NULL, NULL, NULL); /* Extension, takes no arguments */
1166 make_generic ("iargc", GFC_ISYM_IARGC);
1168 add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER, di, NULL, NULL, NULL);
1169 make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT);
1171 add_sym_2 ("ibclr", 1, 1, BT_INTEGER, di,
1172 gfc_check_ibclr, gfc_simplify_ibclr, gfc_resolve_ibclr,
1173 i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0);
1175 make_generic ("ibclr", GFC_ISYM_IBCLR);
1177 add_sym_3 ("ibits", 1, 1, BT_INTEGER, di,
1178 gfc_check_ibits, gfc_simplify_ibits, gfc_resolve_ibits,
1179 i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0,
1180 ln, BT_INTEGER, di, 0);
1182 make_generic ("ibits", GFC_ISYM_IBITS);
1184 add_sym_2 ("ibset", 1, 1, BT_INTEGER, di,
1185 gfc_check_ibset, gfc_simplify_ibset, gfc_resolve_ibset,
1186 i, BT_INTEGER, di, 0, pos, BT_INTEGER, di, 0);
1188 make_generic ("ibset", GFC_ISYM_IBSET);
1190 add_sym_1 ("ichar", 1, 0, BT_INTEGER, di,
1191 NULL, gfc_simplify_ichar, gfc_resolve_ichar,
1192 c, BT_CHARACTER, dc, 0);
1194 make_generic ("ichar", GFC_ISYM_ICHAR);
1196 add_sym_2 ("ieor", 1, 1, BT_INTEGER, di,
1197 gfc_check_ieor, gfc_simplify_ieor, gfc_resolve_ieor,
1198 i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0);
1200 make_generic ("ieor", GFC_ISYM_IEOR);
1202 add_sym_3 ("index", 1, 1, BT_INTEGER, di,
1203 gfc_check_index, gfc_simplify_index, NULL,
1204 stg, BT_CHARACTER, dc, 0, ssg, BT_CHARACTER, dc, 0,
1205 bck, BT_LOGICAL, dl, 1);
1207 make_generic ("index", GFC_ISYM_INDEX);
1209 add_sym_2 ("int", 1, 1, BT_INTEGER, di,
1210 gfc_check_int, gfc_simplify_int, gfc_resolve_int,
1211 a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1);
1213 add_sym_1 ("ifix", 1, 0, BT_INTEGER, di,
1214 NULL, gfc_simplify_ifix, NULL, a, BT_REAL, dr, 0);
1216 add_sym_1 ("idint", 1, 0, BT_INTEGER, di,
1217 NULL, gfc_simplify_idint, NULL, a, BT_REAL, dd, 0);
1219 make_generic ("int", GFC_ISYM_INT);
1221 add_sym_2 ("ior", 1, 1, BT_INTEGER, di,
1222 gfc_check_ior, gfc_simplify_ior, gfc_resolve_ior,
1223 i, BT_INTEGER, di, 0, j, BT_INTEGER, di, 0);
1225 make_generic ("ior", GFC_ISYM_IOR);
1227 /* The following function is for G77 compatibility. */
1228 add_sym_1 ("irand", 0, 1, BT_INTEGER, 4,
1229 gfc_check_irand, NULL, NULL,
1230 i, BT_INTEGER, 4, 0);
1232 make_generic ("irand", GFC_ISYM_IRAND);
1234 add_sym_2 ("ishft", 1, 1, BT_INTEGER, di,
1235 gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
1236 i, BT_INTEGER, di, 0, sh, BT_INTEGER, di, 0);
1238 make_generic ("ishft", GFC_ISYM_ISHFT);
1240 add_sym_3 ("ishftc", 1, 1, BT_INTEGER, di,
1241 gfc_check_ishftc, gfc_simplify_ishftc, gfc_resolve_ishftc,
1242 i, BT_INTEGER, di, 0, sh, BT_INTEGER, di, 0,
1243 sz, BT_INTEGER, di, 1);
1245 make_generic ("ishftc", GFC_ISYM_ISHFTC);
1247 add_sym_1 ("kind", 0, 1, BT_INTEGER, di,
1248 gfc_check_kind, gfc_simplify_kind, NULL, x, BT_REAL, dr, 0);
1250 make_generic ("kind", GFC_ISYM_NONE);
1252 add_sym_2 ("lbound", 0, 1, BT_INTEGER, di,
1253 gfc_check_lbound, gfc_simplify_lbound, gfc_resolve_lbound,
1254 ar, BT_REAL, dr, 0, dm, BT_INTEGER, di, 1);
1256 make_generic ("lbound", GFC_ISYM_LBOUND);
1258 add_sym_1 ("len", 0, 1, BT_INTEGER, di,
1259 NULL, gfc_simplify_len, gfc_resolve_len,
1260 stg, BT_CHARACTER, dc, 0);
1262 make_generic ("len", GFC_ISYM_LEN);
1264 add_sym_1 ("len_trim", 1, 1, BT_INTEGER, di,
1265 NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
1266 stg, BT_CHARACTER, dc, 0);
1268 make_generic ("len_trim", GFC_ISYM_LEN_TRIM);
1270 add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl,
1271 NULL, gfc_simplify_lge, NULL,
1272 sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0);
1274 make_generic ("lge", GFC_ISYM_LGE);
1276 add_sym_2 ("lgt", 1, 0, BT_LOGICAL, dl,
1277 NULL, gfc_simplify_lgt, NULL,
1278 sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0);
1280 make_generic ("lgt", GFC_ISYM_LGT);
1282 add_sym_2 ("lle", 1, 0, BT_LOGICAL, dl,
1283 NULL, gfc_simplify_lle, NULL,
1284 sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0);
1286 make_generic ("lle", GFC_ISYM_LLE);
1288 add_sym_2 ("llt", 1, 0, BT_LOGICAL, dl,
1289 NULL, gfc_simplify_llt, NULL,
1290 sta, BT_CHARACTER, dc, 0, stb, BT_CHARACTER, dc, 0);
1292 make_generic ("llt", GFC_ISYM_LLT);
1294 add_sym_1 ("log", 1, 1, BT_REAL, dr,
1295 NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dr, 0);
1297 add_sym_1 ("alog", 1, 1, BT_REAL, dr,
1298 NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dr, 0);
1300 add_sym_1 ("dlog", 1, 1, BT_REAL, dd,
1301 NULL, gfc_simplify_log, gfc_resolve_log, x, BT_REAL, dd, 0);
1303 add_sym_1 ("clog", 1, 1, BT_COMPLEX, dz,
1304 NULL, gfc_simplify_log, gfc_resolve_log,
1305 x, BT_COMPLEX, dz, 0);
1307 add_sym_1 ("zlog", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_log, gfc_resolve_log, x, BT_COMPLEX, dd, 0); /* Extension */
1309 make_alias ("cdlog");
1311 make_generic ("log", GFC_ISYM_LOG);
1313 add_sym_1 ("log10", 1, 1, BT_REAL, dr,
1314 NULL, gfc_simplify_log10, gfc_resolve_log10,
1317 add_sym_1 ("alog10", 1, 1, BT_REAL, dr,
1318 NULL, gfc_simplify_log10, gfc_resolve_log10,
1321 add_sym_1 ("dlog10", 1, 1, BT_REAL, dd,
1322 NULL, gfc_simplify_log10, gfc_resolve_log10,
1325 make_generic ("log10", GFC_ISYM_LOG10);
1327 add_sym_2 ("logical", 0, 1, BT_LOGICAL, dl,
1328 gfc_check_logical, gfc_simplify_logical, gfc_resolve_logical,
1329 l, BT_LOGICAL, dl, 0, kind, BT_INTEGER, di, 1);
1331 make_generic ("logical", GFC_ISYM_LOGICAL);
1333 add_sym_2 ("matmul", 0, 1, BT_REAL, dr,
1334 gfc_check_matmul, NULL, gfc_resolve_matmul,
1335 ma, BT_REAL, dr, 0, mb, BT_REAL, dr, 0);
1337 make_generic ("matmul", GFC_ISYM_MATMUL);
1339 /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1340 int(max). The max function must take at least two arguments. */
1342 add_sym_1m ("max", 1, 0, BT_UNKNOWN, 0,
1343 gfc_check_min_max, gfc_simplify_max, gfc_resolve_max,
1344 a1, BT_UNKNOWN, dr, 0, a2, BT_UNKNOWN, dr, 0);
1346 add_sym_1m ("max0", 1, 0, BT_INTEGER, di,
1347 gfc_check_min_max_integer, gfc_simplify_max, NULL,
1348 a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0);
1350 add_sym_1m ("amax0", 1, 0, BT_REAL, dr,
1351 gfc_check_min_max_integer, gfc_simplify_max, NULL,
1352 a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0);
1354 add_sym_1m ("amax1", 1, 0, BT_REAL, dr,
1355 gfc_check_min_max_real, gfc_simplify_max, NULL,
1356 a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0);
1358 add_sym_1m ("max1", 1, 0, BT_INTEGER, di,
1359 gfc_check_min_max_real, gfc_simplify_max, NULL,
1360 a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0);
1362 add_sym_1m ("dmax1", 1, 0, BT_REAL, dd,
1363 gfc_check_min_max_double, gfc_simplify_max, NULL,
1364 a1, BT_REAL, dd, 0, a2, BT_REAL, dd, 0);
1366 make_generic ("max", GFC_ISYM_MAX);
1368 add_sym_1 ("maxexponent", 0, 1, BT_INTEGER, di,
1369 gfc_check_x, gfc_simplify_maxexponent, NULL,
1370 x, BT_UNKNOWN, dr, 0);
1372 make_generic ("maxexponent", GFC_ISYM_NONE);
1374 add_sym_3ml ("maxloc", 0, 1, BT_INTEGER, di,
1375 gfc_check_minloc_maxloc, NULL, gfc_resolve_maxloc,
1376 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1377 msk, BT_LOGICAL, dl, 1);
1379 make_generic ("maxloc", GFC_ISYM_MAXLOC);
1381 add_sym_3 ("maxval", 0, 1, BT_REAL, dr,
1382 gfc_check_minval_maxval, NULL, gfc_resolve_maxval,
1383 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1384 msk, BT_LOGICAL, dl, 1);
1386 make_generic ("maxval", GFC_ISYM_MAXVAL);
1388 add_sym_3 ("merge", 1, 1, BT_REAL, dr,
1389 gfc_check_merge, NULL, gfc_resolve_merge,
1390 ts, BT_REAL, dr, 0, fs, BT_REAL, dr, 0,
1391 msk, BT_LOGICAL, dl, 0);
1393 make_generic ("merge", GFC_ISYM_MERGE);
1395 /* Note: amin0 is equivalent to real(min), min1 is equivalent to int(min). */
1397 add_sym_1m ("min", 1, 0, BT_UNKNOWN, 0,
1398 gfc_check_min_max, gfc_simplify_min, gfc_resolve_min,
1399 a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0);
1401 add_sym_1m ("min0", 1, 0, BT_INTEGER, di,
1402 gfc_check_min_max_integer, gfc_simplify_min, NULL,
1403 a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0);
1405 add_sym_1m ("amin0", 1, 0, BT_REAL, dr,
1406 gfc_check_min_max_integer, gfc_simplify_min, NULL,
1407 a1, BT_INTEGER, di, 0, a2, BT_INTEGER, di, 0);
1409 add_sym_1m ("amin1", 1, 0, BT_REAL, dr,
1410 gfc_check_min_max_real, gfc_simplify_min, NULL,
1411 a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0);
1413 add_sym_1m ("min1", 1, 0, BT_INTEGER, di,
1414 gfc_check_min_max_real, gfc_simplify_min, NULL,
1415 a1, BT_REAL, dr, 0, a2, BT_REAL, dr, 0);
1417 add_sym_1m ("dmin1", 1, 0, BT_REAL, dd,
1418 gfc_check_min_max_double, gfc_simplify_min, NULL,
1419 a1, BT_REAL, dd, 0, a2, BT_REAL, dd, 0);
1421 make_generic ("min", GFC_ISYM_MIN);
1423 add_sym_1 ("minexponent", 0, 1, BT_INTEGER, di,
1424 gfc_check_x, gfc_simplify_minexponent, NULL,
1425 x, BT_UNKNOWN, dr, 0);
1427 make_generic ("minexponent", GFC_ISYM_NONE);
1429 add_sym_3ml ("minloc", 0, 1, BT_INTEGER, di,
1430 gfc_check_minloc_maxloc, NULL, gfc_resolve_minloc,
1431 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1432 msk, BT_LOGICAL, dl, 1);
1434 make_generic ("minloc", GFC_ISYM_MINLOC);
1436 add_sym_3 ("minval", 0, 1, BT_REAL, dr,
1437 gfc_check_minval_maxval, NULL, gfc_resolve_minval,
1438 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1439 msk, BT_LOGICAL, dl, 1);
1441 make_generic ("minval", GFC_ISYM_MINVAL);
1443 add_sym_2 ("mod", 1, 1, BT_INTEGER, di,
1444 gfc_check_a_p, gfc_simplify_mod, gfc_resolve_mod,
1445 a, BT_INTEGER, di, 0, p, BT_INTEGER, di, 0);
1447 add_sym_2 ("amod", 1, 1, BT_REAL, dr,
1448 NULL, gfc_simplify_mod, gfc_resolve_mod,
1449 a, BT_REAL, dr, 0, p, BT_REAL, dr, 0);
1451 add_sym_2 ("dmod", 1, 1, BT_REAL, dd,
1452 NULL, gfc_simplify_mod, gfc_resolve_mod,
1453 a, BT_REAL, dd, 0, p, BT_REAL, dd, 0);
1455 make_generic ("mod", GFC_ISYM_MOD);
1457 add_sym_2 ("modulo", 1, 1, BT_REAL, di,
1458 gfc_check_a_p, gfc_simplify_modulo, gfc_resolve_modulo,
1459 a, BT_REAL, di, 0, p, BT_REAL, di, 0);
1461 make_generic ("modulo", GFC_ISYM_MODULO);
1463 add_sym_2 ("nearest", 1, 1, BT_REAL, dr,
1464 gfc_check_nearest, gfc_simplify_nearest, gfc_resolve_nearest,
1465 x, BT_REAL, dr, 0, s, BT_REAL, dr, 0);
1467 make_generic ("nearest", GFC_ISYM_NEAREST);
1469 add_sym_2 ("nint", 1, 1, BT_INTEGER, di,
1470 gfc_check_a_ikind, gfc_simplify_nint, gfc_resolve_nint,
1471 a, BT_REAL, dr, 0, kind, BT_INTEGER, di, 1);
1473 add_sym_1 ("idnint", 1, 1, BT_INTEGER, di,
1474 gfc_check_idnint, gfc_simplify_idnint, gfc_resolve_idnint,
1477 make_generic ("nint", GFC_ISYM_NINT);
1479 add_sym_1 ("not", 1, 1, BT_INTEGER, di,
1480 gfc_check_i, gfc_simplify_not, gfc_resolve_not,
1481 i, BT_INTEGER, di, 0);
1483 make_generic ("not", GFC_ISYM_NOT);
1485 add_sym_1 ("null", 0, 1, BT_INTEGER, di,
1486 gfc_check_null, gfc_simplify_null, NULL,
1487 mo, BT_INTEGER, di, 1);
1489 make_generic ("null", GFC_ISYM_NONE);
1491 add_sym_3 ("pack", 0, 1, BT_REAL, dr,
1492 gfc_check_pack, NULL, gfc_resolve_pack,
1493 ar, BT_REAL, dr, 0, msk, BT_LOGICAL, dl, 0,
1496 make_generic ("pack", GFC_ISYM_PACK);
1498 add_sym_1 ("precision", 0, 1, BT_INTEGER, di,
1499 gfc_check_precision, gfc_simplify_precision, NULL,
1500 x, BT_UNKNOWN, 0, 0);
1502 make_generic ("precision", GFC_ISYM_NONE);
1504 add_sym_1 ("present", 0, 1, BT_LOGICAL, dl,
1505 gfc_check_present, NULL, NULL, a, BT_REAL, dr, 0);
1507 make_generic ("present", GFC_ISYM_PRESENT);
1509 add_sym_3 ("product", 0, 1, BT_REAL, dr,
1510 gfc_check_product, NULL, gfc_resolve_product,
1511 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1512 msk, BT_LOGICAL, dl, 1);
1514 make_generic ("product", GFC_ISYM_PRODUCT);
1516 add_sym_1 ("radix", 0, 1, BT_INTEGER, di,
1517 gfc_check_radix, gfc_simplify_radix, NULL,
1518 x, BT_UNKNOWN, 0, 0);
1520 make_generic ("radix", GFC_ISYM_NONE);
1522 /* The following function is for G77 compatibility. */
1523 add_sym_1 ("rand", 0, 1, BT_REAL, 4,
1524 gfc_check_rand, NULL, NULL,
1525 i, BT_INTEGER, 4, 0);
1527 /* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and
1528 ran() use slightly different shoddy multiplicative congruential
1532 make_generic ("rand", GFC_ISYM_RAND);
1534 add_sym_1 ("range", 0, 1, BT_INTEGER, di,
1535 gfc_check_range, gfc_simplify_range, NULL,
1538 make_generic ("range", GFC_ISYM_NONE);
1540 add_sym_2 ("real", 1, 0, BT_REAL, dr,
1541 gfc_check_real, gfc_simplify_real, gfc_resolve_real,
1542 a, BT_UNKNOWN, dr, 0, kind, BT_INTEGER, di, 1);
1544 add_sym_1 ("float", 1, 0, BT_REAL, dr,
1545 NULL, gfc_simplify_float, NULL, a, BT_INTEGER, di, 0);
1547 add_sym_1 ("sngl", 1, 0, BT_REAL, dr,
1548 NULL, gfc_simplify_sngl, NULL, a, BT_REAL, dd, 0);
1550 make_generic ("real", GFC_ISYM_REAL);
1552 add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc,
1553 gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
1554 stg, BT_CHARACTER, dc, 0, n, BT_INTEGER, di, 0);
1556 make_generic ("repeat", GFC_ISYM_REPEAT);
1558 add_sym_4 ("reshape", 0, 1, BT_REAL, dr,
1559 gfc_check_reshape, gfc_simplify_reshape, gfc_resolve_reshape,
1560 src, BT_REAL, dr, 0, shp, BT_INTEGER, ii, 0,
1561 pad, BT_REAL, dr, 1, ord, BT_INTEGER, ii, 1);
1563 make_generic ("reshape", GFC_ISYM_RESHAPE);
1565 add_sym_1 ("rrspacing", 1, 1, BT_REAL, dr,
1566 gfc_check_x, gfc_simplify_rrspacing, gfc_resolve_rrspacing,
1569 make_generic ("rrspacing", GFC_ISYM_RRSPACING);
1571 add_sym_2 ("scale", 1, 1, BT_REAL, dr,
1572 gfc_check_scale, gfc_simplify_scale, gfc_resolve_scale,
1573 x, BT_REAL, dr, 0, i, BT_INTEGER, di, 0);
1575 make_generic ("scale", GFC_ISYM_SCALE);
1577 add_sym_3 ("scan", 1, 1, BT_INTEGER, di,
1578 gfc_check_scan, gfc_simplify_scan, gfc_resolve_scan,
1579 stg, BT_CHARACTER, dc, 0, set, BT_CHARACTER, dc, 0,
1580 bck, BT_LOGICAL, dl, 1);
1582 make_generic ("scan", GFC_ISYM_SCAN);
1584 /* Added for G77 compatibility garbage. */
1585 add_sym_0 ("second", 0, 1, BT_REAL, 4, NULL, NULL, NULL);
1587 make_generic ("second", GFC_ISYM_SECOND);
1589 add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER, di,
1590 NULL, gfc_simplify_selected_int_kind, NULL,
1591 r, BT_INTEGER, di, 0);
1593 make_generic ("selected_int_kind", GFC_ISYM_SI_KIND);
1595 add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER, di,
1596 gfc_check_selected_real_kind, gfc_simplify_selected_real_kind,
1597 NULL, p, BT_INTEGER, di, 1, r, BT_INTEGER, di, 1);
1599 make_generic ("selected_real_kind", GFC_ISYM_SR_KIND);
1601 add_sym_2 ("set_exponent", 1, 1, BT_REAL, dr,
1602 gfc_check_set_exponent, gfc_simplify_set_exponent,
1603 gfc_resolve_set_exponent,
1604 x, BT_REAL, dr, 0, i, BT_INTEGER, di, 0);
1606 make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT);
1608 add_sym_1 ("shape", 0, 1, BT_INTEGER, di,
1609 gfc_check_shape, gfc_simplify_shape, gfc_resolve_shape,
1610 src, BT_REAL, dr, 0);
1612 make_generic ("shape", GFC_ISYM_SHAPE);
1614 add_sym_2 ("sign", 1, 1, BT_REAL, dr,
1615 gfc_check_sign, gfc_simplify_sign, gfc_resolve_sign,
1616 a, BT_REAL, dr, 0, b, BT_REAL, dr, 0);
1618 add_sym_2 ("isign", 1, 1, BT_INTEGER, di,
1619 NULL, gfc_simplify_sign, gfc_resolve_sign,
1620 a, BT_INTEGER, di, 0, b, BT_INTEGER, di, 0);
1622 add_sym_2 ("dsign", 1, 1, BT_REAL, dd,
1623 NULL, gfc_simplify_sign, gfc_resolve_sign,
1624 a, BT_REAL, dd, 0, b, BT_REAL, dd, 0);
1626 make_generic ("sign", GFC_ISYM_SIGN);
1628 add_sym_1 ("sin", 1, 1, BT_REAL, dr,
1629 NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_REAL, dr, 0);
1631 add_sym_1 ("dsin", 1, 1, BT_REAL, dd,
1632 NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_REAL, dd, 0);
1634 add_sym_1 ("csin", 1, 1, BT_COMPLEX, dz,
1635 NULL, gfc_simplify_sin, gfc_resolve_sin,
1636 x, BT_COMPLEX, dz, 0);
1638 add_sym_1 ("zsin", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_sin, gfc_resolve_sin, x, BT_COMPLEX, dd, 0); /* Extension */
1640 make_alias ("cdsin");
1642 make_generic ("sin", GFC_ISYM_SIN);
1644 add_sym_1 ("sinh", 1, 1, BT_REAL, dr,
1645 NULL, gfc_simplify_sinh, gfc_resolve_sinh,
1648 add_sym_1 ("dsinh", 1, 1, BT_REAL, dd,
1649 NULL, gfc_simplify_sinh, gfc_resolve_sinh,
1652 make_generic ("sinh", GFC_ISYM_SINH);
1654 add_sym_2 ("size", 0, 1, BT_INTEGER, di,
1655 gfc_check_size, gfc_simplify_size, NULL,
1656 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1);
1658 make_generic ("size", GFC_ISYM_SIZE);
1660 add_sym_1 ("spacing", 1, 1, BT_REAL, dr,
1661 gfc_check_x, gfc_simplify_spacing, gfc_resolve_spacing,
1664 make_generic ("spacing", GFC_ISYM_SPACING);
1666 add_sym_3 ("spread", 0, 1, BT_REAL, dr,
1667 gfc_check_spread, NULL, gfc_resolve_spread,
1668 src, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 0,
1669 n, BT_INTEGER, di, 0);
1671 make_generic ("spread", GFC_ISYM_SPREAD);
1673 add_sym_1 ("sqrt", 1, 1, BT_REAL, dr,
1674 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1677 add_sym_1 ("dsqrt", 1, 1, BT_REAL, dd,
1678 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1681 add_sym_1 ("csqrt", 1, 1, BT_COMPLEX, dz,
1682 NULL, gfc_simplify_sqrt, gfc_resolve_sqrt,
1683 x, BT_COMPLEX, dz, 0);
1685 add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX, dd, NULL, gfc_simplify_sqrt, gfc_resolve_sqrt, x, BT_COMPLEX, dd, 0); /* Extension */
1687 make_alias ("cdsqrt");
1689 make_generic ("sqrt", GFC_ISYM_SQRT);
1691 add_sym_3 ("sum", 0, 1, BT_UNKNOWN, 0,
1692 gfc_check_sum, NULL, gfc_resolve_sum,
1693 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1,
1694 msk, BT_LOGICAL, dl, 1);
1696 make_generic ("sum", GFC_ISYM_SUM);
1698 add_sym_1 ("tan", 1, 1, BT_REAL, dr,
1699 NULL, gfc_simplify_tan, gfc_resolve_tan, x, BT_REAL, dr, 0);
1701 add_sym_1 ("dtan", 1, 1, BT_REAL, dd,
1702 NULL, gfc_simplify_tan, gfc_resolve_tan, x, BT_REAL, dd, 0);
1704 make_generic ("tan", GFC_ISYM_TAN);
1706 add_sym_1 ("tanh", 1, 1, BT_REAL, dr,
1707 NULL, gfc_simplify_tanh, gfc_resolve_tanh,
1710 add_sym_1 ("dtanh", 1, 1, BT_REAL, dd,
1711 NULL, gfc_simplify_tanh, gfc_resolve_tanh,
1714 make_generic ("tanh", GFC_ISYM_TANH);
1716 add_sym_1 ("tiny", 0, 1, BT_REAL, dr,
1717 gfc_check_x, gfc_simplify_tiny, NULL, x, BT_REAL, dr, 0);
1719 make_generic ("tiny", GFC_ISYM_NONE);
1721 add_sym_3 ("transfer", 0, 1, BT_REAL, dr,
1722 gfc_check_transfer, NULL, gfc_resolve_transfer,
1723 src, BT_REAL, dr, 0, mo, BT_REAL, dr, 0,
1724 sz, BT_INTEGER, di, 1);
1726 make_generic ("transfer", GFC_ISYM_TRANSFER);
1728 add_sym_1 ("transpose", 0, 1, BT_REAL, dr,
1729 gfc_check_transpose, NULL, gfc_resolve_transpose,
1732 make_generic ("transpose", GFC_ISYM_TRANSPOSE);
1734 add_sym_1 ("trim", 0, 1, BT_CHARACTER, dc,
1735 gfc_check_trim, gfc_simplify_trim, gfc_resolve_trim,
1736 stg, BT_CHARACTER, dc, 0);
1738 make_generic ("trim", GFC_ISYM_TRIM);
1740 add_sym_2 ("ubound", 0, 1, BT_INTEGER, di,
1741 gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
1742 ar, BT_REAL, dr, 0, dm, BT_INTEGER, ii, 1);
1744 make_generic ("ubound", GFC_ISYM_UBOUND);
1746 add_sym_3 ("unpack", 0, 1, BT_REAL, dr,
1747 gfc_check_unpack, NULL, gfc_resolve_unpack,
1748 v, BT_REAL, dr, 0, msk, BT_LOGICAL, dl, 0,
1751 make_generic ("unpack", GFC_ISYM_UNPACK);
1753 add_sym_3 ("verify", 1, 1, BT_INTEGER, di,
1754 gfc_check_verify, gfc_simplify_verify, gfc_resolve_verify,
1755 stg, BT_CHARACTER, dc, 0, set, BT_CHARACTER, dc, 0,
1756 bck, BT_LOGICAL, dl, 1);
1758 make_generic ("verify", GFC_ISYM_VERIFY);
1765 /* Add intrinsic subroutines. */
1768 add_subroutines (void)
1770 /* Argument names as in the standard (to be used as argument keywords). */
1772 *h = "harvest", *dt = "date", *vl = "values", *pt = "put",
1773 *c = "count", *tm = "time", *tp = "topos", *gt = "get",
1774 *t = "to", *zn = "zone", *fp = "frompos", *cm = "count_max",
1775 *f = "from", *sz = "size", *ln = "len", *cr = "count_rate",
1776 *com = "command", *length = "length", *st = "status",
1777 *val = "value", *num = "number", *name = "name",
1778 *trim_name = "trim_name";
1782 di = gfc_default_integer_kind ();
1783 dr = gfc_default_real_kind ();
1784 dc = gfc_default_character_kind ();
1785 dl = gfc_default_logical_kind ();
1787 add_sym_0s ("abort", 1, NULL);
1789 add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN, 0,
1790 gfc_check_cpu_time, NULL, gfc_resolve_cpu_time,
1791 tm, BT_REAL, dr, 0);
1793 /* More G77 compatibility garbage. */
1794 add_sym_1s ("second", 0, 1, BT_UNKNOWN, 0,
1795 gfc_check_second_sub, NULL, gfc_resolve_second_sub,
1796 tm, BT_REAL, dr, 0);
1798 add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0,
1799 gfc_check_date_and_time, NULL, NULL,
1800 dt, BT_CHARACTER, dc, 1, tm, BT_CHARACTER, dc, 1,
1801 zn, BT_CHARACTER, dc, 1, vl, BT_INTEGER, di, 1);
1803 /* More G77 compatibility garbage. */
1804 add_sym_2s ("etime", 0, 1, BT_UNKNOWN, 0,
1805 gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
1806 vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0);
1808 add_sym_2s ("dtime", 0, 1, BT_UNKNOWN, 0,
1809 gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
1810 vl, BT_REAL, 4, 0, tm, BT_REAL, 4, 0);
1812 add_sym_2s ("getenv", 0, 1, BT_UNKNOWN, 0,
1814 name, BT_CHARACTER, dc, 0,
1815 val, BT_CHARACTER, dc, 0);
1817 add_sym_2s ("getarg", 0, 1, BT_UNKNOWN, 0,
1818 NULL, NULL, gfc_resolve_getarg,
1819 c, BT_INTEGER, di, 0, vl, BT_CHARACTER, dc, 0);
1821 /* F2003 commandline routines. */
1823 add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0,
1824 NULL, NULL, gfc_resolve_get_command,
1825 com, BT_CHARACTER, dc, 1,
1826 length, BT_INTEGER, di, 1,
1827 st, BT_INTEGER, di, 1);
1829 add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN, 0,
1830 NULL, NULL, gfc_resolve_get_command_argument,
1831 num, BT_INTEGER, di, 0,
1832 val, BT_CHARACTER, dc, 1,
1833 length, BT_INTEGER, di, 1,
1834 st, BT_INTEGER, di, 1);
1837 /* F2003 subroutine to get environment variables. */
1839 add_sym_5s ("get_environment_variable", 0, 1, BT_UNKNOWN, 0,
1840 NULL, NULL, gfc_resolve_get_environment_variable,
1841 name, BT_CHARACTER, dc, 0,
1842 val, BT_CHARACTER, dc, 1,
1843 length, BT_INTEGER, di, 1,
1844 st, BT_INTEGER, di, 1,
1845 trim_name, BT_LOGICAL, dl, 1);
1848 /* This needs changing to add_sym_5s if it gets a resolution function. */
1849 add_sym_5 ("mvbits", 1, 1, BT_UNKNOWN, 0,
1850 gfc_check_mvbits, gfc_simplify_mvbits, NULL,
1851 f, BT_INTEGER, di, 0, fp, BT_INTEGER, di, 0,
1852 ln, BT_INTEGER, di, 0, t, BT_INTEGER, di, 0,
1853 tp, BT_INTEGER, di, 0);
1855 add_sym_1s ("random_number", 0, 1, BT_UNKNOWN, 0,
1856 gfc_check_random_number, NULL, gfc_resolve_random_number,
1859 add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN, 0,
1860 gfc_check_random_seed, NULL, NULL,
1861 sz, BT_INTEGER, di, 1, pt, BT_INTEGER, di, 1,
1862 gt, BT_INTEGER, di, 1);
1864 /* More G77 compatibility garbage. */
1865 add_sym_1s ("srand", 0, 1, BT_UNKNOWN, di,
1866 gfc_check_srand, NULL, gfc_resolve_srand,
1867 c, BT_INTEGER, 4, 0);
1869 add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN, 0,
1870 gfc_check_system_clock, NULL, gfc_resolve_system_clock,
1871 c, BT_INTEGER, di, 1, cr, BT_INTEGER, di, 1,
1872 cm, BT_INTEGER, di, 1);
1876 /* Add a function to the list of conversion symbols. */
1879 add_conv (bt from_type, int from_kind, bt to_type, int to_kind,
1880 gfc_expr * (*simplify) (gfc_expr *, bt, int))
1883 gfc_typespec from, to;
1884 gfc_intrinsic_sym *sym;
1886 if (sizing == SZ_CONVS)
1892 gfc_clear_ts (&from);
1893 from.type = from_type;
1894 from.kind = from_kind;
1900 sym = conversion + nconv;
1902 strcpy (sym->name, conv_name (&from, &to));
1903 strcpy (sym->lib_name, sym->name);
1904 sym->simplify.cc = simplify;
1907 sym->generic_id = GFC_ISYM_CONVERSION;
1913 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
1914 functions by looping over the kind tables. */
1917 add_conversions (void)
1921 /* Integer-Integer conversions. */
1922 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
1923 for (j = 0; gfc_integer_kinds[j].kind != 0; j++)
1928 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
1929 BT_INTEGER, gfc_integer_kinds[j].kind, gfc_convert_constant);
1932 /* Integer-Real/Complex conversions. */
1933 for (i = 0; gfc_integer_kinds[i].kind != 0; i++)
1934 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
1936 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
1937 BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
1939 add_conv (BT_REAL, gfc_real_kinds[j].kind,
1940 BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
1942 add_conv (BT_INTEGER, gfc_integer_kinds[i].kind,
1943 BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
1945 add_conv (BT_COMPLEX, gfc_real_kinds[j].kind,
1946 BT_INTEGER, gfc_integer_kinds[i].kind, gfc_convert_constant);
1949 /* Real/Complex - Real/Complex conversions. */
1950 for (i = 0; gfc_real_kinds[i].kind != 0; i++)
1951 for (j = 0; gfc_real_kinds[j].kind != 0; j++)
1955 add_conv (BT_REAL, gfc_real_kinds[i].kind,
1956 BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
1958 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
1959 BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
1962 add_conv (BT_REAL, gfc_real_kinds[i].kind,
1963 BT_COMPLEX, gfc_real_kinds[j].kind, gfc_convert_constant);
1965 add_conv (BT_COMPLEX, gfc_real_kinds[i].kind,
1966 BT_REAL, gfc_real_kinds[j].kind, gfc_convert_constant);
1969 /* Logical/Logical kind conversion. */
1970 for (i = 0; gfc_logical_kinds[i].kind; i++)
1971 for (j = 0; gfc_logical_kinds[j].kind; j++)
1976 add_conv (BT_LOGICAL, gfc_logical_kinds[i].kind,
1977 BT_LOGICAL, gfc_logical_kinds[j].kind, gfc_convert_constant);
1982 /* Initialize the table of intrinsics. */
1984 gfc_intrinsic_init_1 (void)
1988 nargs = nfunc = nsub = nconv = 0;
1990 /* Create a namespace to hold the resolved intrinsic symbols. */
1991 gfc_intrinsic_namespace = gfc_get_namespace (NULL);
2000 functions = gfc_getmem (sizeof (gfc_intrinsic_sym) * (nfunc + nsub)
2001 + sizeof (gfc_intrinsic_arg) * nargs);
2003 next_sym = functions;
2004 subroutines = functions + nfunc;
2006 conversion = gfc_getmem (sizeof (gfc_intrinsic_sym) * nconv);
2008 next_arg = ((gfc_intrinsic_arg *) (subroutines + nsub)) - 1;
2010 sizing = SZ_NOTHING;
2017 /* Set the pure flag. All intrinsic functions are pure, and
2018 intrinsic subroutines are pure if they are elemental. */
2020 for (i = 0; i < nfunc; i++)
2021 functions[i].pure = 1;
2023 for (i = 0; i < nsub; i++)
2024 subroutines[i].pure = subroutines[i].elemental;
2029 gfc_intrinsic_done_1 (void)
2031 gfc_free (functions);
2032 gfc_free (conversion);
2033 gfc_free_namespace (gfc_intrinsic_namespace);
2037 /******** Subroutines to check intrinsic interfaces ***********/
2039 /* Given a formal argument list, remove any NULL arguments that may
2040 have been left behind by a sort against some formal argument list. */
2043 remove_nullargs (gfc_actual_arglist ** ap)
2045 gfc_actual_arglist *head, *tail, *next;
2049 for (head = *ap; head; head = next)
2053 if (head->expr == NULL)
2056 gfc_free_actual_arglist (head);
2075 /* Given an actual arglist and a formal arglist, sort the actual
2076 arglist so that its arguments are in a one-to-one correspondence
2077 with the format arglist. Arguments that are not present are given
2078 a blank gfc_actual_arglist structure. If something is obviously
2079 wrong (say, a missing required argument) we abort sorting and
2083 sort_actual (const char *name, gfc_actual_arglist ** ap,
2084 gfc_intrinsic_arg * formal, locus * where)
2087 gfc_actual_arglist *actual, *a;
2088 gfc_intrinsic_arg *f;
2090 remove_nullargs (ap);
2093 for (f = formal; f; f = f->next)
2099 if (f == NULL && a == NULL) /* No arguments */
2103 { /* Put the nonkeyword arguments in a 1:1 correspondence */
2109 if (a->name[0] != '\0')
2121 gfc_error ("Too many arguments in call to '%s' at %L", name, where);
2125 /* Associate the remaining actual arguments, all of which have
2126 to be keyword arguments. */
2127 for (; a; a = a->next)
2129 for (f = formal; f; f = f->next)
2130 if (strcmp (a->name, f->name) == 0)
2135 gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2136 a->name, name, where);
2140 if (f->actual != NULL)
2142 gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2143 f->name, name, where);
2151 /* At this point, all unmatched formal args must be optional. */
2152 for (f = formal; f; f = f->next)
2154 if (f->actual == NULL && f->optional == 0)
2156 gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2157 f->name, name, where);
2163 /* Using the formal argument list, string the actual argument list
2164 together in a way that corresponds with the formal list. */
2167 for (f = formal; f; f = f->next)
2169 if (f->actual == NULL)
2171 a = gfc_get_actual_arglist ();
2172 a->missing_arg_type = f->ts.type;
2184 actual->next = NULL; /* End the sorted argument list. */
2190 /* Compare an actual argument list with an intrinsic's formal argument
2191 list. The lists are checked for agreement of type. We don't check
2192 for arrayness here. */
2195 check_arglist (gfc_actual_arglist ** ap, gfc_intrinsic_sym * sym,
2198 gfc_actual_arglist *actual;
2199 gfc_intrinsic_arg *formal;
2202 formal = sym->formal;
2206 for (; formal; formal = formal->next, actual = actual->next, i++)
2208 if (actual->expr == NULL)
2211 if (!gfc_compare_types (&formal->ts, &actual->expr->ts))
2215 ("Type of argument '%s' in call to '%s' at %L should be "
2216 "%s, not %s", gfc_current_intrinsic_arg[i],
2217 gfc_current_intrinsic, &actual->expr->where,
2218 gfc_typename (&formal->ts), gfc_typename (&actual->expr->ts));
2227 /* Given a pointer to an intrinsic symbol and an expression node that
2228 represent the function call to that subroutine, figure out the type
2229 of the result. This may involve calling a resolution subroutine. */
2232 resolve_intrinsic (gfc_intrinsic_sym * specific, gfc_expr * e)
2234 gfc_expr *a1, *a2, *a3, *a4, *a5;
2235 gfc_actual_arglist *arg;
2237 if (specific->resolve.f1 == NULL)
2239 if (e->value.function.name == NULL)
2240 e->value.function.name = specific->lib_name;
2242 if (e->ts.type == BT_UNKNOWN)
2243 e->ts = specific->ts;
2247 arg = e->value.function.actual;
2249 /* At present only the iargc extension intrinsic takes no arguments,
2250 and it doesn't need a resolution function, but this is here for
2254 (*specific->resolve.f0) (e);
2258 /* Special case hacks for MIN and MAX. */
2259 if (specific->resolve.f1m == gfc_resolve_max
2260 || specific->resolve.f1m == gfc_resolve_min)
2262 (*specific->resolve.f1m) (e, arg);
2271 (*specific->resolve.f1) (e, a1);
2280 (*specific->resolve.f2) (e, a1, a2);
2289 (*specific->resolve.f3) (e, a1, a2, a3);
2298 (*specific->resolve.f4) (e, a1, a2, a3, a4);
2307 (*specific->resolve.f5) (e, a1, a2, a3, a4, a5);
2311 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2315 /* Given an intrinsic symbol node and an expression node, call the
2316 simplification function (if there is one), perhaps replacing the
2317 expression with something simpler. We return FAILURE on an error
2318 of the simplification, SUCCESS if the simplification worked, even
2319 if nothing has changed in the expression itself. */
2322 do_simplify (gfc_intrinsic_sym * specific, gfc_expr * e)
2324 gfc_expr *result, *a1, *a2, *a3, *a4, *a5;
2325 gfc_actual_arglist *arg;
2327 /* Max and min require special handling due to the variable number
2329 if (specific->simplify.f1 == gfc_simplify_min)
2331 result = gfc_simplify_min (e);
2335 if (specific->simplify.f1 == gfc_simplify_max)
2337 result = gfc_simplify_max (e);
2341 if (specific->simplify.f1 == NULL)
2347 arg = e->value.function.actual;
2352 if (specific->simplify.cc == gfc_convert_constant)
2354 result = gfc_convert_constant (a1, specific->ts.type, specific->ts.kind);
2358 /* TODO: Warn if -pedantic and initialization expression and arg
2359 types not integer or character */
2362 result = (*specific->simplify.f1) (a1);
2369 result = (*specific->simplify.f2) (a1, a2);
2376 result = (*specific->simplify.f3) (a1, a2, a3);
2383 result = (*specific->simplify.f4) (a1, a2, a3, a4);
2390 result = (*specific->simplify.f5) (a1, a2, a3, a4, a5);
2393 ("do_simplify(): Too many args for intrinsic");
2400 if (result == &gfc_bad_expr)
2404 resolve_intrinsic (specific, e); /* Must call at run-time */
2407 result->where = e->where;
2408 gfc_replace_expr (e, result);
2415 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2416 error messages. This subroutine returns FAILURE if a subroutine
2417 has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2418 list cannot match any intrinsic. */
2421 init_arglist (gfc_intrinsic_sym * isym)
2423 gfc_intrinsic_arg *formal;
2426 gfc_current_intrinsic = isym->name;
2429 for (formal = isym->formal; formal; formal = formal->next)
2431 if (i >= MAX_INTRINSIC_ARGS)
2432 gfc_internal_error ("init_arglist(): too many arguments");
2433 gfc_current_intrinsic_arg[i++] = formal->name;
2438 /* Given a pointer to an intrinsic symbol and an expression consisting
2439 of a function call, see if the function call is consistent with the
2440 intrinsic's formal argument list. Return SUCCESS if the expression
2441 and intrinsic match, FAILURE otherwise. */
2444 check_specific (gfc_intrinsic_sym * specific, gfc_expr * expr, int error_flag)
2446 gfc_actual_arglist *arg, **ap;
2450 ap = &expr->value.function.actual;
2452 init_arglist (specific);
2454 /* Don't attempt to sort the argument list for min or max. */
2455 if (specific->check.f1m == gfc_check_min_max
2456 || specific->check.f1m == gfc_check_min_max_integer
2457 || specific->check.f1m == gfc_check_min_max_real
2458 || specific->check.f1m == gfc_check_min_max_double)
2459 return (*specific->check.f1m) (*ap);
2461 if (sort_actual (specific->name, ap, specific->formal,
2462 &expr->where) == FAILURE)
2465 if (specific->check.f3ml != gfc_check_minloc_maxloc)
2467 if (specific->check.f1 == NULL)
2469 t = check_arglist (ap, specific, error_flag);
2471 expr->ts = specific->ts;
2474 t = do_check (specific, *ap);
2477 /* This is special because we might have to reorder the argument
2479 t = gfc_check_minloc_maxloc (*ap);
2481 /* Check ranks for elemental intrinsics. */
2482 if (t == SUCCESS && specific->elemental)
2485 for (arg = expr->value.function.actual; arg; arg = arg->next)
2487 if (arg->expr == NULL || arg->expr->rank == 0)
2491 r = arg->expr->rank;
2495 if (arg->expr->rank != r)
2498 ("Ranks of arguments to elemental intrinsic '%s' differ "
2499 "at %L", specific->name, &arg->expr->where);
2506 remove_nullargs (ap);
2512 /* See if an intrinsic is one of the intrinsics we evaluate
2516 gfc_init_expr_extensions (gfc_intrinsic_sym *isym)
2518 /* FIXME: This should be moved into the intrinsic definitions. */
2519 static const char * const init_expr_extensions[] = {
2520 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2521 "precision", "present", "radix", "range", "selected_real_kind",
2527 for (i = 0; init_expr_extensions[i]; i++)
2528 if (strcmp (init_expr_extensions[i], isym->name) == 0)
2535 /* See if a function call corresponds to an intrinsic function call.
2538 MATCH_YES if the call corresponds to an intrinsic, simplification
2539 is done if possible.
2541 MATCH_NO if the call does not correspond to an intrinsic
2543 MATCH_ERROR if the call corresponds to an intrinsic but there was an
2544 error during the simplification process.
2546 The error_flag parameter enables an error reporting. */
2549 gfc_intrinsic_func_interface (gfc_expr * expr, int error_flag)
2551 gfc_intrinsic_sym *isym, *specific;
2552 gfc_actual_arglist *actual;
2556 if (expr->value.function.isym != NULL)
2557 return (do_simplify (expr->value.function.isym, expr) == FAILURE)
2558 ? MATCH_ERROR : MATCH_YES;
2560 gfc_suppress_error = !error_flag;
2563 for (actual = expr->value.function.actual; actual; actual = actual->next)
2564 if (actual->expr != NULL)
2565 flag |= (actual->expr->ts.type != BT_INTEGER
2566 && actual->expr->ts.type != BT_CHARACTER);
2568 name = expr->symtree->n.sym->name;
2570 isym = specific = gfc_find_function (name);
2573 gfc_suppress_error = 0;
2577 gfc_current_intrinsic_where = &expr->where;
2579 /* Bypass the generic list for min and max. */
2580 if (isym->check.f1m == gfc_check_min_max)
2582 init_arglist (isym);
2584 if (gfc_check_min_max (expr->value.function.actual) == SUCCESS)
2587 gfc_suppress_error = 0;
2591 /* If the function is generic, check all of its specific
2592 incarnations. If the generic name is also a specific, we check
2593 that name last, so that any error message will correspond to the
2595 gfc_suppress_error = 1;
2599 for (specific = isym->specific_head; specific;
2600 specific = specific->next)
2602 if (specific == isym)
2604 if (check_specific (specific, expr, 0) == SUCCESS)
2609 gfc_suppress_error = !error_flag;
2611 if (check_specific (isym, expr, error_flag) == FAILURE)
2613 gfc_suppress_error = 0;
2620 expr->value.function.isym = specific;
2621 gfc_intrinsic_symbol (expr->symtree->n.sym);
2623 if (do_simplify (specific, expr) == FAILURE)
2625 gfc_suppress_error = 0;
2629 /* TODO: We should probably only allow elemental functions here. */
2630 flag |= (expr->ts.type != BT_INTEGER && expr->ts.type != BT_CHARACTER);
2632 gfc_suppress_error = 0;
2633 if (pedantic && gfc_init_expr
2634 && flag && gfc_init_expr_extensions (specific))
2636 if (gfc_notify_std (GFC_STD_GNU, "Extension: Evaluation of "
2637 "nonstandard initialization expression at %L", &expr->where)
2648 /* See if a CALL statement corresponds to an intrinsic subroutine.
2649 Returns MATCH_YES if the subroutine corresponds to an intrinsic,
2650 MATCH_NO if not, and MATCH_ERROR if there was an error (but did
2654 gfc_intrinsic_sub_interface (gfc_code * c, int error_flag)
2656 gfc_intrinsic_sym *isym;
2659 name = c->symtree->n.sym->name;
2661 isym = find_subroutine (name);
2665 gfc_suppress_error = !error_flag;
2667 init_arglist (isym);
2669 if (sort_actual (name, &c->ext.actual, isym->formal, &c->loc) == FAILURE)
2672 if (isym->check.f1 != NULL)
2674 if (do_check (isym, c->ext.actual) == FAILURE)
2679 if (check_arglist (&c->ext.actual, isym, 1) == FAILURE)
2683 /* The subroutine corresponds to an intrinsic. Allow errors to be
2684 seen at this point. */
2685 gfc_suppress_error = 0;
2687 if (isym->resolve.s1 != NULL)
2688 isym->resolve.s1 (c);
2690 c->resolved_sym = gfc_get_intrinsic_sub_symbol (isym->lib_name);
2692 if (gfc_pure (NULL) && !isym->elemental)
2694 gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name,
2702 gfc_suppress_error = 0;
2707 /* Call gfc_convert_type() with warning enabled. */
2710 gfc_convert_type (gfc_expr * expr, gfc_typespec * ts, int eflag)
2712 return gfc_convert_type_warn (expr, ts, eflag, 1);
2716 /* Try to convert an expression (in place) from one type to another.
2717 'eflag' controls the behavior on error.
2719 The possible values are:
2721 1 Generate a gfc_error()
2722 2 Generate a gfc_internal_error().
2724 'wflag' controls the warning related to conversion. */
2727 gfc_convert_type_warn (gfc_expr * expr, gfc_typespec * ts, int eflag,
2730 gfc_intrinsic_sym *sym;
2731 gfc_typespec from_ts;
2736 from_ts = expr->ts; /* expr->ts gets clobbered */
2738 if (ts->type == BT_UNKNOWN)
2741 /* NULL and zero size arrays get their type here. */
2742 if (expr->expr_type == EXPR_NULL
2743 || (expr->expr_type == EXPR_ARRAY
2744 && expr->value.constructor == NULL))
2746 /* Sometimes the RHS acquire the type. */
2751 if (expr->ts.type == BT_UNKNOWN)
2754 if (expr->ts.type == BT_DERIVED
2755 && ts->type == BT_DERIVED
2756 && gfc_compare_types (&expr->ts, ts))
2759 sym = find_conv (&expr->ts, ts);
2763 /* At this point, a conversion is necessary. A warning may be needed. */
2764 if (wflag && gfc_option.warn_conversion)
2765 gfc_warning_now ("Conversion from %s to %s at %L",
2766 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
2768 /* Insert a pre-resolved function call to the right function. */
2769 old_where = expr->where;
2771 new = gfc_get_expr ();
2774 new = gfc_build_conversion (new);
2775 new->value.function.name = sym->lib_name;
2776 new->value.function.isym = sym;
2777 new->where = old_where;
2785 if (gfc_is_constant_expr (expr->value.function.actual->expr)
2786 && do_simplify (sym, expr) == FAILURE)
2791 return FAILURE; /* Error already generated in do_simplify() */
2799 gfc_error ("Can't convert %s to %s at %L",
2800 gfc_typename (&from_ts), gfc_typename (ts), &expr->where);
2804 gfc_internal_error ("Can't convert %s to %s at %L",
2805 gfc_typename (&from_ts), gfc_typename (ts),