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_5 (const char *name
, int elemental
, int actual_ok
, bt type
,
566 try (*check
)(gfc_expr
*,gfc_expr
*,gfc_expr
*,gfc_expr
*,gfc_expr
*),
567 gfc_expr
*(*simplify
)(gfc_expr
*,gfc_expr
*,gfc_expr
*,gfc_expr
*,gfc_expr
*),
568 void (*resolve
)(gfc_expr
*,gfc_expr
*,gfc_expr
*,gfc_expr
*,gfc_expr
*,gfc_expr
*),
569 const char* a1
, bt type1
, int kind1
, int optional1
,
570 const char* a2
, bt type2
, int kind2
, int optional2
,
571 const char* a3
, bt type3
, int kind3
, int optional3
,
572 const char* a4
, bt type4
, int kind4
, int optional4
,
573 const char* a5
, bt type5
, int kind5
, int optional5
583 add_sym (name
, elemental
, actual_ok
, type
, kind
, cf
, sf
, rf
,
584 a1
, type1
, kind1
, optional1
,
585 a2
, type2
, kind2
, optional2
,
586 a3
, type3
, kind3
, optional3
,
587 a4
, type4
, kind4
, optional4
,
588 a5
, type5
, kind5
, optional5
,
593 /* Locate an intrinsic symbol given a base pointer, number of elements
594 in the table and a pointer to a name. Returns the NULL pointer if
595 a name is not found. */
597 static gfc_intrinsic_sym
*
598 find_sym (gfc_intrinsic_sym
* start
, int n
, const char *name
)
603 if (strcmp (name
, start
->name
) == 0)
614 /* Given a name, find a function in the intrinsic function table.
615 Returns NULL if not found. */
618 gfc_find_function (const char *name
)
621 return find_sym (functions
, nfunc
, name
);
625 /* Given a name, find a function in the intrinsic subroutine table.
626 Returns NULL if not found. */
628 static gfc_intrinsic_sym
*
629 find_subroutine (const char *name
)
632 return find_sym (subroutines
, nsub
, name
);
636 /* Given a string, figure out if it is the name of a generic intrinsic
640 gfc_generic_intrinsic (const char *name
)
642 gfc_intrinsic_sym
*sym
;
644 sym
= gfc_find_function (name
);
645 return (sym
== NULL
) ? 0 : sym
->generic
;
649 /* Given a string, figure out if it is the name of a specific
650 intrinsic function or not. */
653 gfc_specific_intrinsic (const char *name
)
655 gfc_intrinsic_sym
*sym
;
657 sym
= gfc_find_function (name
);
658 return (sym
== NULL
) ? 0 : sym
->specific
;
662 /* Given a string, figure out if it is the name of an intrinsic
663 subroutine or function. There are no generic intrinsic
664 subroutines, they are all specific. */
667 gfc_intrinsic_name (const char *name
, int subroutine_flag
)
670 return subroutine_flag
?
671 find_subroutine (name
) != NULL
: gfc_find_function (name
) != NULL
;
675 /* Collect a set of intrinsic functions into a generic collection.
676 The first argument is the name of the generic function, which is
677 also the name of a specific function. The rest of the specifics
678 currently in the table are placed into the list of specific
679 functions associated with that generic. */
682 make_generic (const char *name
, gfc_generic_isym_id generic_id
)
684 gfc_intrinsic_sym
*g
;
686 if (sizing
!= SZ_NOTHING
)
689 g
= gfc_find_function (name
);
691 gfc_internal_error ("make_generic(): Can't find generic symbol '%s'",
696 g
->generic_id
= generic_id
;
697 if ((g
+ 1)->name
[0] != '\0')
698 g
->specific_head
= g
+ 1;
701 while (g
->name
[0] != '\0')
705 g
->generic_id
= generic_id
;
714 /* Create a duplicate intrinsic function entry for the current
715 function, the only difference being the alternate name. Note that
716 we use argument lists more than once, but all argument lists are
717 freed as a single block. */
720 make_alias (const char *name
)
734 next_sym
[0] = next_sym
[-1];
735 strcpy (next_sym
->name
, name
);
745 /* Add intrinsic functions. */
751 /* Argument names as in the standard (to be used as argument keywords). */
753 *a
= "a", *f
= "field", *pt
= "pointer", *tg
= "target",
754 *b
= "b", *m
= "matrix", *ma
= "matrix_a", *mb
= "matrix_b",
755 *c
= "c", *n
= "ncopies", *pos
= "pos", *bck
= "back",
756 *i
= "i", *v
= "vector", *va
= "vector_a", *vb
= "vector_b",
757 *j
= "j", *a1
= "a1", *fs
= "fsource", *ts
= "tsource",
758 *l
= "l", *a2
= "a2", *mo
= "mold", *ord
= "order",
759 *p
= "p", *ar
= "array", *shp
= "shape", *src
= "source",
760 *r
= "r", *bd
= "boundary", *pad
= "pad", *set
= "set",
761 *s
= "s", *dm
= "dim", *kind
= "kind", *msk
= "mask",
762 *x
= "x", *sh
= "shift", *stg
= "string", *ssg
= "substring",
763 *y
= "y", *sz
= "size", *sta
= "string_a", *stb
= "string_b",
764 *z
= "z", *ln
= "len";
766 int di
, dr
, dd
, dl
, dc
, dz
, ii
;
768 di
= gfc_default_integer_kind ();
769 dr
= gfc_default_real_kind ();
770 dd
= gfc_default_double_kind ();
771 dl
= gfc_default_logical_kind ();
772 dc
= gfc_default_character_kind ();
773 dz
= gfc_default_complex_kind ();
774 ii
= gfc_index_integer_kind
;
776 add_sym_1 ("abs", 1, 1, BT_REAL
, dr
,
777 gfc_check_abs
, gfc_simplify_abs
, gfc_resolve_abs
,
780 add_sym_1 ("iabs", 1, 1, BT_INTEGER
, di
,
781 NULL
, gfc_simplify_abs
, gfc_resolve_abs
,
782 a
, BT_INTEGER
, di
, 0);
784 add_sym_1 ("dabs", 1, 1, BT_REAL
, dd
,
785 NULL
, gfc_simplify_abs
, gfc_resolve_abs
, a
, BT_REAL
, dd
, 0);
787 add_sym_1 ("cabs", 1, 1, BT_REAL
, dr
,
788 NULL
, gfc_simplify_abs
, gfc_resolve_abs
,
789 a
, BT_COMPLEX
, dz
, 0);
791 add_sym_1 ("zabs", 1, 1, BT_REAL
, dd
, NULL
, gfc_simplify_abs
, gfc_resolve_abs
, a
, BT_COMPLEX
, dd
, 0); /* Extension */
793 make_alias ("cdabs");
795 make_generic ("abs", GFC_ISYM_ABS
);
797 add_sym_1 ("achar", 1, 1, BT_CHARACTER
, dc
,
798 NULL
, gfc_simplify_achar
, NULL
, i
, BT_INTEGER
, di
, 0);
800 make_generic ("achar", GFC_ISYM_ACHAR
);
802 add_sym_1 ("acos", 1, 1, BT_REAL
, dr
,
803 NULL
, gfc_simplify_acos
, gfc_resolve_acos
,
806 add_sym_1 ("dacos", 1, 1, BT_REAL
, dd
,
807 NULL
, gfc_simplify_acos
, gfc_resolve_acos
,
810 make_generic ("acos", GFC_ISYM_ACOS
);
812 add_sym_1 ("adjustl", 1, 1, BT_CHARACTER
, dc
,
813 NULL
, gfc_simplify_adjustl
, NULL
, stg
, BT_CHARACTER
, dc
, 0);
815 make_generic ("adjustl", GFC_ISYM_ADJUSTL
);
817 add_sym_1 ("adjustr", 1, 1, BT_CHARACTER
, dc
,
818 NULL
, gfc_simplify_adjustr
, NULL
, stg
, BT_CHARACTER
, dc
, 0);
820 make_generic ("adjustr", GFC_ISYM_ADJUSTR
);
822 add_sym_1 ("aimag", 1, 1, BT_REAL
, dr
,
823 NULL
, gfc_simplify_aimag
, gfc_resolve_aimag
,
824 z
, BT_COMPLEX
, dz
, 0);
826 add_sym_1 ("dimag", 1, 1, BT_REAL
, dd
, NULL
, gfc_simplify_aimag
, gfc_resolve_aimag
, z
, BT_COMPLEX
, dd
, 0); /* Extension */
828 make_generic ("aimag", GFC_ISYM_AIMAG
);
830 add_sym_2 ("aint", 1, 1, BT_REAL
, dr
,
831 gfc_check_a_xkind
, gfc_simplify_aint
, gfc_resolve_aint
,
832 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
834 add_sym_1 ("dint", 1, 1, BT_REAL
, dd
,
835 NULL
, gfc_simplify_dint
, gfc_resolve_dint
,
838 make_generic ("aint", GFC_ISYM_AINT
);
840 add_sym_2 ("all", 0, 1, BT_UNKNOWN
, 0,
841 gfc_check_all_any
, NULL
, gfc_resolve_all
,
842 msk
, BT_LOGICAL
, dl
, 0, dm
, BT_INTEGER
, ii
, 1);
844 make_generic ("all", GFC_ISYM_ALL
);
846 add_sym_1 ("allocated", 0, 1, BT_LOGICAL
, dl
,
847 gfc_check_allocated
, NULL
, NULL
, ar
, BT_UNKNOWN
, 0, 0);
849 make_generic ("allocated", GFC_ISYM_ALLOCATED
);
851 add_sym_2 ("anint", 1, 1, BT_REAL
, dr
,
852 gfc_check_a_xkind
, gfc_simplify_anint
, gfc_resolve_anint
,
853 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
855 add_sym_1 ("dnint", 1, 1, BT_REAL
, dd
,
856 NULL
, gfc_simplify_dnint
, gfc_resolve_dnint
,
859 make_generic ("anint", GFC_ISYM_ANINT
);
861 add_sym_2 ("any", 0, 1, BT_UNKNOWN
, 0,
862 gfc_check_all_any
, NULL
, gfc_resolve_any
,
863 msk
, BT_LOGICAL
, dl
, 0, dm
, BT_INTEGER
, ii
, 1);
865 make_generic ("any", GFC_ISYM_ANY
);
867 add_sym_1 ("asin", 1, 1, BT_REAL
, dr
,
868 NULL
, gfc_simplify_asin
, gfc_resolve_asin
,
871 add_sym_1 ("dasin", 1, 1, BT_REAL
, dd
,
872 NULL
, gfc_simplify_asin
, gfc_resolve_asin
,
875 make_generic ("asin", GFC_ISYM_ASIN
);
877 add_sym_2 ("associated", 0, 1, BT_LOGICAL
, dl
,
878 gfc_check_associated
, NULL
, NULL
,
879 pt
, BT_UNKNOWN
, 0, 0, tg
, BT_UNKNOWN
, 0, 1);
881 make_generic ("associated", GFC_ISYM_ASSOCIATED
);
883 add_sym_1 ("atan", 1, 1, BT_REAL
, dr
,
884 NULL
, gfc_simplify_atan
, gfc_resolve_atan
,
887 add_sym_1 ("datan", 1, 1, BT_REAL
, dd
,
888 NULL
, gfc_simplify_atan
, gfc_resolve_atan
,
891 make_generic ("atan", GFC_ISYM_ATAN
);
893 add_sym_2 ("atan2", 1, 1, BT_REAL
, dr
,
894 NULL
, gfc_simplify_atan2
, gfc_resolve_atan2
,
895 y
, BT_REAL
, dr
, 0, x
, BT_REAL
, dr
, 0);
897 add_sym_2 ("datan2", 1, 1, BT_REAL
, dd
,
898 NULL
, gfc_simplify_atan2
, gfc_resolve_atan2
,
899 y
, BT_REAL
, dd
, 0, x
, BT_REAL
, dd
, 0);
901 make_generic ("atan2", GFC_ISYM_ATAN2
);
903 add_sym_1 ("bit_size", 0, 1, BT_INTEGER
, di
,
904 gfc_check_i
, gfc_simplify_bit_size
, NULL
,
905 i
, BT_INTEGER
, di
, 0);
907 make_generic ("bit_size", GFC_ISYM_NONE
);
909 add_sym_2 ("btest", 1, 1, BT_LOGICAL
, dl
,
910 gfc_check_btest
, gfc_simplify_btest
, gfc_resolve_btest
,
911 i
, BT_INTEGER
, di
, 0, pos
, BT_INTEGER
, di
, 0);
913 make_generic ("btest", GFC_ISYM_BTEST
);
915 add_sym_2 ("ceiling", 1, 1, BT_INTEGER
, di
,
916 gfc_check_a_ikind
, gfc_simplify_ceiling
, gfc_resolve_ceiling
,
917 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
919 make_generic ("ceiling", GFC_ISYM_CEILING
);
921 add_sym_2 ("char", 1, 0, BT_CHARACTER
, dc
,
922 gfc_check_char
, gfc_simplify_char
, gfc_resolve_char
,
923 i
, BT_INTEGER
, di
, 0, kind
, BT_INTEGER
, di
, 1);
925 make_generic ("char", GFC_ISYM_CHAR
);
927 add_sym_3 ("cmplx", 1, 1, BT_COMPLEX
, dz
,
928 gfc_check_cmplx
, gfc_simplify_cmplx
, gfc_resolve_cmplx
,
929 x
, BT_UNKNOWN
, dr
, 0, y
, BT_UNKNOWN
, dr
, 1,
930 kind
, BT_INTEGER
, di
, 1);
932 make_generic ("cmplx", GFC_ISYM_CMPLX
);
934 /* Making dcmplx a specific of cmplx causes cmplx to return a double
935 complex instead of the default complex. */
937 add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX
, dd
,
938 gfc_check_dcmplx
, gfc_simplify_dcmplx
, gfc_resolve_dcmplx
,
939 x
, BT_REAL
, dd
, 0, y
, BT_REAL
, dd
, 1); /* Extension */
941 make_generic ("dcmplx", GFC_ISYM_CMPLX
);
943 add_sym_1 ("conjg", 1, 1, BT_COMPLEX
, dz
,
944 NULL
, gfc_simplify_conjg
, gfc_resolve_conjg
,
945 z
, BT_COMPLEX
, dz
, 0);
947 add_sym_1 ("dconjg", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_conjg
, gfc_resolve_conjg
, z
, BT_COMPLEX
, dd
, 0); /* Extension */
949 make_generic ("conjg", GFC_ISYM_CONJG
);
951 add_sym_1 ("cos", 1, 1, BT_REAL
, dr
,
952 NULL
, gfc_simplify_cos
, gfc_resolve_cos
, x
, BT_REAL
, dr
, 0);
954 add_sym_1 ("dcos", 1, 1, BT_REAL
, dd
,
955 NULL
, gfc_simplify_cos
, gfc_resolve_cos
, x
, BT_REAL
, dd
, 0);
957 add_sym_1 ("ccos", 1, 1, BT_COMPLEX
, dz
,
958 NULL
, gfc_simplify_cos
, gfc_resolve_cos
,
959 x
, BT_COMPLEX
, dz
, 0);
961 add_sym_1 ("zcos", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_cos
, gfc_resolve_cos
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
963 make_alias ("cdcos");
965 make_generic ("cos", GFC_ISYM_COS
);
967 add_sym_1 ("cosh", 1, 1, BT_REAL
, dr
,
968 NULL
, gfc_simplify_cosh
, gfc_resolve_cosh
,
971 add_sym_1 ("dcosh", 1, 1, BT_REAL
, dd
,
972 NULL
, gfc_simplify_cosh
, gfc_resolve_cosh
,
975 make_generic ("cosh", GFC_ISYM_COSH
);
977 add_sym_2 ("count", 0, 1, BT_INTEGER
, di
,
978 gfc_check_count
, NULL
, gfc_resolve_count
,
979 msk
, BT_LOGICAL
, dl
, 0, dm
, BT_INTEGER
, ii
, 1);
981 make_generic ("count", GFC_ISYM_COUNT
);
983 add_sym_3 ("cshift", 0, 1, BT_REAL
, dr
,
984 gfc_check_cshift
, NULL
, gfc_resolve_cshift
,
985 ar
, BT_REAL
, dr
, 0, sh
, BT_INTEGER
, di
, 0,
986 dm
, BT_INTEGER
, ii
, 1);
988 make_generic ("cshift", GFC_ISYM_CSHIFT
);
990 add_sym_1 ("dble", 1, 1, BT_REAL
, dd
,
991 gfc_check_dble
, gfc_simplify_dble
, gfc_resolve_dble
,
994 make_generic ("dble", GFC_ISYM_DBLE
);
996 add_sym_1 ("digits", 0, 1, BT_INTEGER
, di
,
997 gfc_check_digits
, gfc_simplify_digits
, NULL
,
998 x
, BT_UNKNOWN
, dr
, 0);
1000 make_generic ("digits", GFC_ISYM_NONE
);
1002 add_sym_2 ("dim", 1, 1, BT_REAL
, dr
,
1003 gfc_check_a_p
, gfc_simplify_dim
, gfc_resolve_dim
,
1004 x
, BT_UNKNOWN
, dr
, 0, y
, BT_UNKNOWN
, dr
, 0);
1006 add_sym_2 ("idim", 1, 1, BT_INTEGER
, di
,
1007 NULL
, gfc_simplify_dim
, gfc_resolve_dim
,
1008 x
, BT_INTEGER
, di
, 0, y
, BT_INTEGER
, di
, 0);
1010 add_sym_2 ("ddim", 1, 1, BT_REAL
, dd
,
1011 NULL
, gfc_simplify_dim
, gfc_resolve_dim
,
1012 x
, BT_REAL
, dd
, 0, y
, BT_REAL
, dd
, 0);
1014 make_generic ("dim", GFC_ISYM_DIM
);
1016 add_sym_2 ("dot_product", 0, 1, BT_UNKNOWN
, 0,
1017 gfc_check_dot_product
, NULL
, gfc_resolve_dot_product
,
1018 va
, BT_REAL
, dr
, 0, vb
, BT_REAL
, dr
, 0);
1020 make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT
);
1022 add_sym_2 ("dprod", 1, 1, BT_REAL
, dd
,
1023 NULL
, gfc_simplify_dprod
, gfc_resolve_dprod
,
1024 x
, BT_REAL
, dr
, 0, y
, BT_REAL
, dr
, 0);
1026 make_generic ("dprod", GFC_ISYM_DPROD
);
1028 add_sym_1 ("dreal", 1, 0, BT_REAL
, dd
, NULL
, NULL
, NULL
, a
, BT_COMPLEX
, dd
, 0); /* Extension */
1030 make_generic ("dreal", GFC_ISYM_REAL
);
1032 add_sym_4 ("eoshift", 0, 1, BT_REAL
, dr
,
1033 gfc_check_eoshift
, NULL
, gfc_resolve_eoshift
,
1034 ar
, BT_REAL
, dr
, 0, sh
, BT_INTEGER
, ii
, 0,
1035 bd
, BT_REAL
, dr
, 1, dm
, BT_INTEGER
, ii
, 1);
1037 make_generic ("eoshift", GFC_ISYM_EOSHIFT
);
1039 add_sym_1 ("epsilon", 0, 1, BT_REAL
, dr
,
1040 gfc_check_x
, gfc_simplify_epsilon
, NULL
,
1043 make_generic ("epsilon", GFC_ISYM_NONE
);
1045 /* G77 compatibility */
1046 add_sym_1 ("etime", 0, 1, BT_REAL
, 4,
1047 gfc_check_etime
, NULL
, NULL
,
1050 make_alias ("dtime");
1052 make_generic ("etime", GFC_ISYM_ETIME
);
1055 add_sym_1 ("exp", 1, 1, BT_REAL
, dr
,
1056 NULL
, gfc_simplify_exp
, gfc_resolve_exp
, x
, BT_REAL
, dr
, 0);
1058 add_sym_1 ("dexp", 1, 1, BT_REAL
, dd
,
1059 NULL
, gfc_simplify_exp
, gfc_resolve_exp
, x
, BT_REAL
, dd
, 0);
1061 add_sym_1 ("cexp", 1, 1, BT_COMPLEX
, dz
,
1062 NULL
, gfc_simplify_exp
, gfc_resolve_exp
,
1063 x
, BT_COMPLEX
, dz
, 0);
1065 add_sym_1 ("zexp", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_exp
, gfc_resolve_exp
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
1067 make_alias ("cdexp");
1069 make_generic ("exp", GFC_ISYM_EXP
);
1071 add_sym_1 ("exponent", 1, 1, BT_INTEGER
, di
,
1072 gfc_check_x
, gfc_simplify_exponent
, gfc_resolve_exponent
,
1075 make_generic ("exponent", GFC_ISYM_EXPONENT
);
1077 add_sym_2 ("floor", 1, 1, BT_INTEGER
, di
,
1078 gfc_check_a_ikind
, gfc_simplify_floor
, gfc_resolve_floor
,
1079 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
1081 make_generic ("floor", GFC_ISYM_FLOOR
);
1083 add_sym_1 ("fraction", 1, 1, BT_REAL
, dr
,
1084 gfc_check_x
, gfc_simplify_fraction
, gfc_resolve_fraction
,
1087 make_generic ("fraction", GFC_ISYM_FRACTION
);
1089 add_sym_1 ("huge", 0, 1, BT_REAL
, dr
,
1090 gfc_check_huge
, gfc_simplify_huge
, NULL
,
1091 x
, BT_UNKNOWN
, dr
, 0);
1093 make_generic ("huge", GFC_ISYM_NONE
);
1095 add_sym_1 ("iachar", 1, 1, BT_INTEGER
, di
,
1096 NULL
, gfc_simplify_iachar
, NULL
, c
, BT_CHARACTER
, dc
, 0);
1098 make_generic ("iachar", GFC_ISYM_IACHAR
);
1100 add_sym_2 ("iand", 1, 1, BT_INTEGER
, di
,
1101 gfc_check_iand
, gfc_simplify_iand
, gfc_resolve_iand
,
1102 i
, BT_INTEGER
, di
, 0, j
, BT_INTEGER
, di
, 0);
1104 make_generic ("iand", GFC_ISYM_IAND
);
1106 add_sym_0 ("iargc", 1, 1, BT_INTEGER
, di
, NULL
, NULL
, NULL
); /* Extension, takes no arguments */
1107 make_generic ("iargc", GFC_ISYM_IARGC
);
1109 add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER
, di
, NULL
, NULL
, NULL
);
1110 make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT
);
1112 add_sym_2 ("ibclr", 1, 1, BT_INTEGER
, di
,
1113 gfc_check_ibclr
, gfc_simplify_ibclr
, gfc_resolve_ibclr
,
1114 i
, BT_INTEGER
, di
, 0, pos
, BT_INTEGER
, di
, 0);
1116 make_generic ("ibclr", GFC_ISYM_IBCLR
);
1118 add_sym_3 ("ibits", 1, 1, BT_INTEGER
, di
,
1119 gfc_check_ibits
, gfc_simplify_ibits
, gfc_resolve_ibits
,
1120 i
, BT_INTEGER
, di
, 0, pos
, BT_INTEGER
, di
, 0,
1121 ln
, BT_INTEGER
, di
, 0);
1123 make_generic ("ibits", GFC_ISYM_IBITS
);
1125 add_sym_2 ("ibset", 1, 1, BT_INTEGER
, di
,
1126 gfc_check_ibset
, gfc_simplify_ibset
, gfc_resolve_ibset
,
1127 i
, BT_INTEGER
, di
, 0, pos
, BT_INTEGER
, di
, 0);
1129 make_generic ("ibset", GFC_ISYM_IBSET
);
1131 add_sym_1 ("ichar", 1, 0, BT_INTEGER
, di
,
1132 NULL
, gfc_simplify_ichar
, gfc_resolve_ichar
,
1133 c
, BT_CHARACTER
, dc
, 0);
1135 make_generic ("ichar", GFC_ISYM_ICHAR
);
1137 add_sym_2 ("ieor", 1, 1, BT_INTEGER
, di
,
1138 gfc_check_ieor
, gfc_simplify_ieor
, gfc_resolve_ieor
,
1139 i
, BT_INTEGER
, di
, 0, j
, BT_INTEGER
, di
, 0);
1141 make_generic ("ieor", GFC_ISYM_IEOR
);
1143 add_sym_3 ("index", 1, 1, BT_INTEGER
, di
,
1144 gfc_check_index
, gfc_simplify_index
, NULL
,
1145 stg
, BT_CHARACTER
, dc
, 0, ssg
, BT_CHARACTER
, dc
, 0,
1146 bck
, BT_LOGICAL
, dl
, 1);
1148 make_generic ("index", GFC_ISYM_INDEX
);
1150 add_sym_2 ("int", 1, 1, BT_INTEGER
, di
,
1151 gfc_check_int
, gfc_simplify_int
, gfc_resolve_int
,
1152 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
1154 add_sym_1 ("ifix", 1, 0, BT_INTEGER
, di
,
1155 NULL
, gfc_simplify_ifix
, NULL
, a
, BT_REAL
, dr
, 0);
1157 add_sym_1 ("idint", 1, 0, BT_INTEGER
, di
,
1158 NULL
, gfc_simplify_idint
, NULL
, a
, BT_REAL
, dd
, 0);
1160 make_generic ("int", GFC_ISYM_INT
);
1162 add_sym_2 ("ior", 1, 1, BT_INTEGER
, di
,
1163 gfc_check_ior
, gfc_simplify_ior
, gfc_resolve_ior
,
1164 i
, BT_INTEGER
, di
, 0, j
, BT_INTEGER
, di
, 0);
1166 make_generic ("ior", GFC_ISYM_IOR
);
1168 /* The following function is for G77 compatibility. */
1169 add_sym_1 ("irand", 0, 1, BT_INTEGER
, 4,
1170 gfc_check_irand
, NULL
, NULL
,
1171 i
, BT_INTEGER
, 4, 0);
1173 make_generic ("irand", GFC_ISYM_IRAND
);
1175 add_sym_2 ("ishft", 1, 1, BT_INTEGER
, di
,
1176 gfc_check_ishft
, gfc_simplify_ishft
, gfc_resolve_ishft
,
1177 i
, BT_INTEGER
, di
, 0, sh
, BT_INTEGER
, di
, 0);
1179 make_generic ("ishft", GFC_ISYM_ISHFT
);
1181 add_sym_3 ("ishftc", 1, 1, BT_INTEGER
, di
,
1182 gfc_check_ishftc
, gfc_simplify_ishftc
, gfc_resolve_ishftc
,
1183 i
, BT_INTEGER
, di
, 0, sh
, BT_INTEGER
, di
, 0,
1184 sz
, BT_INTEGER
, di
, 1);
1186 make_generic ("ishftc", GFC_ISYM_ISHFTC
);
1188 add_sym_1 ("kind", 0, 1, BT_INTEGER
, di
,
1189 gfc_check_kind
, gfc_simplify_kind
, NULL
, x
, BT_REAL
, dr
, 0);
1191 make_generic ("kind", GFC_ISYM_NONE
);
1193 add_sym_2 ("lbound", 0, 1, BT_INTEGER
, di
,
1194 gfc_check_lbound
, gfc_simplify_lbound
, gfc_resolve_lbound
,
1195 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, di
, 1);
1197 make_generic ("lbound", GFC_ISYM_LBOUND
);
1199 add_sym_1 ("len", 0, 1, BT_INTEGER
, di
,
1200 NULL
, gfc_simplify_len
, gfc_resolve_len
,
1201 stg
, BT_CHARACTER
, dc
, 0);
1203 make_generic ("len", GFC_ISYM_LEN
);
1205 add_sym_1 ("len_trim", 1, 1, BT_INTEGER
, di
,
1206 NULL
, gfc_simplify_len_trim
, gfc_resolve_len_trim
,
1207 stg
, BT_CHARACTER
, dc
, 0);
1209 make_generic ("len_trim", GFC_ISYM_LEN_TRIM
);
1211 add_sym_2 ("lge", 1, 0, BT_LOGICAL
, dl
,
1212 NULL
, gfc_simplify_lge
, NULL
,
1213 sta
, BT_CHARACTER
, dc
, 0, stb
, BT_CHARACTER
, dc
, 0);
1215 make_generic ("lge", GFC_ISYM_LGE
);
1217 add_sym_2 ("lgt", 1, 0, BT_LOGICAL
, dl
,
1218 NULL
, gfc_simplify_lgt
, NULL
,
1219 sta
, BT_CHARACTER
, dc
, 0, stb
, BT_CHARACTER
, dc
, 0);
1221 make_generic ("lgt", GFC_ISYM_LGT
);
1223 add_sym_2 ("lle", 1, 0, BT_LOGICAL
, dl
,
1224 NULL
, gfc_simplify_lle
, NULL
,
1225 sta
, BT_CHARACTER
, dc
, 0, stb
, BT_CHARACTER
, dc
, 0);
1227 make_generic ("lle", GFC_ISYM_LLE
);
1229 add_sym_2 ("llt", 1, 0, BT_LOGICAL
, dl
,
1230 NULL
, gfc_simplify_llt
, NULL
,
1231 sta
, BT_CHARACTER
, dc
, 0, stb
, BT_CHARACTER
, dc
, 0);
1233 make_generic ("llt", GFC_ISYM_LLT
);
1235 add_sym_1 ("log", 1, 1, BT_REAL
, dr
,
1236 NULL
, gfc_simplify_log
, gfc_resolve_log
, x
, BT_REAL
, dr
, 0);
1238 add_sym_1 ("alog", 1, 1, BT_REAL
, dr
,
1239 NULL
, gfc_simplify_log
, gfc_resolve_log
, x
, BT_REAL
, dr
, 0);
1241 add_sym_1 ("dlog", 1, 1, BT_REAL
, dd
,
1242 NULL
, gfc_simplify_log
, gfc_resolve_log
, x
, BT_REAL
, dd
, 0);
1244 add_sym_1 ("clog", 1, 1, BT_COMPLEX
, dz
,
1245 NULL
, gfc_simplify_log
, gfc_resolve_log
,
1246 x
, BT_COMPLEX
, dz
, 0);
1248 add_sym_1 ("zlog", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_log
, gfc_resolve_log
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
1250 make_alias ("cdlog");
1252 make_generic ("log", GFC_ISYM_LOG
);
1254 add_sym_1 ("log10", 1, 1, BT_REAL
, dr
,
1255 NULL
, gfc_simplify_log10
, gfc_resolve_log10
,
1258 add_sym_1 ("alog10", 1, 1, BT_REAL
, dr
,
1259 NULL
, gfc_simplify_log10
, gfc_resolve_log10
,
1262 add_sym_1 ("dlog10", 1, 1, BT_REAL
, dd
,
1263 NULL
, gfc_simplify_log10
, gfc_resolve_log10
,
1266 make_generic ("log10", GFC_ISYM_LOG10
);
1268 add_sym_2 ("logical", 0, 1, BT_LOGICAL
, dl
,
1269 gfc_check_logical
, gfc_simplify_logical
, gfc_resolve_logical
,
1270 l
, BT_LOGICAL
, dl
, 0, kind
, BT_INTEGER
, di
, 1);
1272 make_generic ("logical", GFC_ISYM_LOGICAL
);
1274 add_sym_2 ("matmul", 0, 1, BT_REAL
, dr
,
1275 gfc_check_matmul
, NULL
, gfc_resolve_matmul
,
1276 ma
, BT_REAL
, dr
, 0, mb
, BT_REAL
, dr
, 0);
1278 make_generic ("matmul", GFC_ISYM_MATMUL
);
1280 /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1281 int(max). The max function must take at least two arguments. */
1283 add_sym_1m ("max", 1, 0, BT_UNKNOWN
, 0,
1284 gfc_check_min_max
, gfc_simplify_max
, gfc_resolve_max
,
1285 a1
, BT_UNKNOWN
, dr
, 0, a2
, BT_UNKNOWN
, dr
, 0);
1287 add_sym_1m ("max0", 1, 0, BT_INTEGER
, di
,
1288 gfc_check_min_max_integer
, gfc_simplify_max
, NULL
,
1289 a1
, BT_INTEGER
, di
, 0, a2
, BT_INTEGER
, di
, 0);
1291 add_sym_1m ("amax0", 1, 0, BT_REAL
, dr
,
1292 gfc_check_min_max_integer
, gfc_simplify_max
, NULL
,
1293 a1
, BT_INTEGER
, di
, 0, a2
, BT_INTEGER
, di
, 0);
1295 add_sym_1m ("amax1", 1, 0, BT_REAL
, dr
,
1296 gfc_check_min_max_real
, gfc_simplify_max
, NULL
,
1297 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1299 add_sym_1m ("max1", 1, 0, BT_INTEGER
, di
,
1300 gfc_check_min_max_real
, gfc_simplify_max
, NULL
,
1301 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1303 add_sym_1m ("dmax1", 1, 0, BT_REAL
, dd
,
1304 gfc_check_min_max_double
, gfc_simplify_max
, NULL
,
1305 a1
, BT_REAL
, dd
, 0, a2
, BT_REAL
, dd
, 0);
1307 make_generic ("max", GFC_ISYM_MAX
);
1309 add_sym_1 ("maxexponent", 0, 1, BT_INTEGER
, di
,
1310 gfc_check_x
, gfc_simplify_maxexponent
, NULL
,
1311 x
, BT_UNKNOWN
, dr
, 0);
1313 make_generic ("maxexponent", GFC_ISYM_NONE
);
1315 add_sym_3ml ("maxloc", 0, 1, BT_INTEGER
, di
,
1316 gfc_check_minloc_maxloc
, NULL
, gfc_resolve_maxloc
,
1317 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1318 msk
, BT_LOGICAL
, dl
, 1);
1320 make_generic ("maxloc", GFC_ISYM_MAXLOC
);
1322 add_sym_3 ("maxval", 0, 1, BT_REAL
, dr
,
1323 gfc_check_minval_maxval
, NULL
, gfc_resolve_maxval
,
1324 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1325 msk
, BT_LOGICAL
, dl
, 1);
1327 make_generic ("maxval", GFC_ISYM_MAXVAL
);
1329 add_sym_3 ("merge", 1, 1, BT_REAL
, dr
,
1330 gfc_check_merge
, NULL
, gfc_resolve_merge
,
1331 ts
, BT_REAL
, dr
, 0, fs
, BT_REAL
, dr
, 0,
1332 msk
, BT_LOGICAL
, dl
, 0);
1334 make_generic ("merge", GFC_ISYM_MERGE
);
1336 /* Note: amin0 is equivalent to real(min), min1 is equivalent to int(min). */
1338 add_sym_1m ("min", 1, 0, BT_UNKNOWN
, 0,
1339 gfc_check_min_max
, gfc_simplify_min
, gfc_resolve_min
,
1340 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1342 add_sym_1m ("min0", 1, 0, BT_INTEGER
, di
,
1343 gfc_check_min_max_integer
, gfc_simplify_min
, NULL
,
1344 a1
, BT_INTEGER
, di
, 0, a2
, BT_INTEGER
, di
, 0);
1346 add_sym_1m ("amin0", 1, 0, BT_REAL
, dr
,
1347 gfc_check_min_max_integer
, gfc_simplify_min
, NULL
,
1348 a1
, BT_INTEGER
, di
, 0, a2
, BT_INTEGER
, di
, 0);
1350 add_sym_1m ("amin1", 1, 0, BT_REAL
, dr
,
1351 gfc_check_min_max_real
, gfc_simplify_min
, NULL
,
1352 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1354 add_sym_1m ("min1", 1, 0, BT_INTEGER
, di
,
1355 gfc_check_min_max_real
, gfc_simplify_min
, NULL
,
1356 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1358 add_sym_1m ("dmin1", 1, 0, BT_REAL
, dd
,
1359 gfc_check_min_max_double
, gfc_simplify_min
, NULL
,
1360 a1
, BT_REAL
, dd
, 0, a2
, BT_REAL
, dd
, 0);
1362 make_generic ("min", GFC_ISYM_MIN
);
1364 add_sym_1 ("minexponent", 0, 1, BT_INTEGER
, di
,
1365 gfc_check_x
, gfc_simplify_minexponent
, NULL
,
1366 x
, BT_UNKNOWN
, dr
, 0);
1368 make_generic ("minexponent", GFC_ISYM_NONE
);
1370 add_sym_3ml ("minloc", 0, 1, BT_INTEGER
, di
,
1371 gfc_check_minloc_maxloc
, NULL
, gfc_resolve_minloc
,
1372 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1373 msk
, BT_LOGICAL
, dl
, 1);
1375 make_generic ("minloc", GFC_ISYM_MINLOC
);
1377 add_sym_3 ("minval", 0, 1, BT_REAL
, dr
,
1378 gfc_check_minval_maxval
, NULL
, gfc_resolve_minval
,
1379 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1380 msk
, BT_LOGICAL
, dl
, 1);
1382 make_generic ("minval", GFC_ISYM_MINVAL
);
1384 add_sym_2 ("mod", 1, 1, BT_INTEGER
, di
,
1385 gfc_check_a_p
, gfc_simplify_mod
, gfc_resolve_mod
,
1386 a
, BT_INTEGER
, di
, 0, p
, BT_INTEGER
, di
, 0);
1388 add_sym_2 ("amod", 1, 1, BT_REAL
, dr
,
1389 NULL
, gfc_simplify_mod
, gfc_resolve_mod
,
1390 a
, BT_REAL
, dr
, 0, p
, BT_REAL
, dr
, 0);
1392 add_sym_2 ("dmod", 1, 1, BT_REAL
, dd
,
1393 NULL
, gfc_simplify_mod
, gfc_resolve_mod
,
1394 a
, BT_REAL
, dd
, 0, p
, BT_REAL
, dd
, 0);
1396 make_generic ("mod", GFC_ISYM_MOD
);
1398 add_sym_2 ("modulo", 1, 1, BT_REAL
, di
,
1399 gfc_check_a_p
, gfc_simplify_modulo
, gfc_resolve_modulo
,
1400 a
, BT_REAL
, di
, 0, p
, BT_REAL
, di
, 0);
1402 make_generic ("modulo", GFC_ISYM_MODULO
);
1404 add_sym_2 ("nearest", 1, 1, BT_REAL
, dr
,
1405 gfc_check_nearest
, gfc_simplify_nearest
, gfc_resolve_nearest
,
1406 x
, BT_REAL
, dr
, 0, s
, BT_REAL
, dr
, 0);
1408 make_generic ("nearest", GFC_ISYM_NEAREST
);
1410 add_sym_2 ("nint", 1, 1, BT_INTEGER
, di
,
1411 gfc_check_a_ikind
, gfc_simplify_nint
, gfc_resolve_nint
,
1412 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
1414 add_sym_1 ("idnint", 1, 1, BT_INTEGER
, di
,
1415 gfc_check_idnint
, gfc_simplify_idnint
, gfc_resolve_idnint
,
1418 make_generic ("nint", GFC_ISYM_NINT
);
1420 add_sym_1 ("not", 1, 1, BT_INTEGER
, di
,
1421 gfc_check_i
, gfc_simplify_not
, gfc_resolve_not
,
1422 i
, BT_INTEGER
, di
, 0);
1424 make_generic ("not", GFC_ISYM_NOT
);
1426 add_sym_1 ("null", 0, 1, BT_INTEGER
, di
,
1427 gfc_check_null
, gfc_simplify_null
, NULL
,
1428 mo
, BT_INTEGER
, di
, 1);
1430 make_generic ("null", GFC_ISYM_NONE
);
1432 add_sym_3 ("pack", 0, 1, BT_REAL
, dr
,
1433 gfc_check_pack
, NULL
, gfc_resolve_pack
,
1434 ar
, BT_REAL
, dr
, 0, msk
, BT_LOGICAL
, dl
, 0,
1437 make_generic ("pack", GFC_ISYM_PACK
);
1439 add_sym_1 ("precision", 0, 1, BT_INTEGER
, di
,
1440 gfc_check_precision
, gfc_simplify_precision
, NULL
,
1441 x
, BT_UNKNOWN
, 0, 0);
1443 make_generic ("precision", GFC_ISYM_NONE
);
1445 add_sym_1 ("present", 0, 1, BT_LOGICAL
, dl
,
1446 gfc_check_present
, NULL
, NULL
, a
, BT_REAL
, dr
, 0);
1448 make_generic ("present", GFC_ISYM_PRESENT
);
1450 add_sym_3 ("product", 0, 1, BT_REAL
, dr
,
1451 gfc_check_product
, NULL
, gfc_resolve_product
,
1452 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1453 msk
, BT_LOGICAL
, dl
, 1);
1455 make_generic ("product", GFC_ISYM_PRODUCT
);
1457 add_sym_1 ("radix", 0, 1, BT_INTEGER
, di
,
1458 gfc_check_radix
, gfc_simplify_radix
, NULL
,
1459 x
, BT_UNKNOWN
, 0, 0);
1461 make_generic ("radix", GFC_ISYM_NONE
);
1463 /* The following function is for G77 compatibility. */
1464 add_sym_1 ("rand", 0, 1, BT_REAL
, 4,
1465 gfc_check_rand
, NULL
, NULL
,
1466 i
, BT_INTEGER
, 4, 0);
1468 make_generic ("rand", GFC_ISYM_RAND
);
1470 add_sym_1 ("range", 0, 1, BT_INTEGER
, di
,
1471 gfc_check_range
, gfc_simplify_range
, NULL
,
1474 make_generic ("range", GFC_ISYM_NONE
);
1476 add_sym_2 ("real", 1, 0, BT_REAL
, dr
,
1477 gfc_check_real
, gfc_simplify_real
, gfc_resolve_real
,
1478 a
, BT_UNKNOWN
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
1480 add_sym_1 ("float", 1, 0, BT_REAL
, dr
,
1481 NULL
, gfc_simplify_float
, NULL
, a
, BT_INTEGER
, di
, 0);
1483 add_sym_1 ("sngl", 1, 0, BT_REAL
, dr
,
1484 NULL
, gfc_simplify_sngl
, NULL
, a
, BT_REAL
, dd
, 0);
1486 make_generic ("real", GFC_ISYM_REAL
);
1488 add_sym_2 ("repeat", 0, 1, BT_CHARACTER
, dc
,
1489 gfc_check_repeat
, gfc_simplify_repeat
, gfc_resolve_repeat
,
1490 stg
, BT_CHARACTER
, dc
, 0, n
, BT_INTEGER
, di
, 0);
1492 make_generic ("repeat", GFC_ISYM_REPEAT
);
1494 add_sym_4 ("reshape", 0, 1, BT_REAL
, dr
,
1495 gfc_check_reshape
, gfc_simplify_reshape
, gfc_resolve_reshape
,
1496 src
, BT_REAL
, dr
, 0, shp
, BT_INTEGER
, ii
, 0,
1497 pad
, BT_REAL
, dr
, 1, ord
, BT_INTEGER
, ii
, 1);
1499 make_generic ("reshape", GFC_ISYM_RESHAPE
);
1501 add_sym_1 ("rrspacing", 1, 1, BT_REAL
, dr
,
1502 gfc_check_x
, gfc_simplify_rrspacing
, gfc_resolve_rrspacing
,
1505 make_generic ("rrspacing", GFC_ISYM_RRSPACING
);
1507 add_sym_2 ("scale", 1, 1, BT_REAL
, dr
,
1508 gfc_check_scale
, gfc_simplify_scale
, gfc_resolve_scale
,
1509 x
, BT_REAL
, dr
, 0, i
, BT_INTEGER
, di
, 0);
1511 make_generic ("scale", GFC_ISYM_SCALE
);
1513 add_sym_3 ("scan", 1, 1, BT_INTEGER
, di
,
1514 gfc_check_scan
, gfc_simplify_scan
, gfc_resolve_scan
,
1515 stg
, BT_CHARACTER
, dc
, 0, set
, BT_CHARACTER
, dc
, 0,
1516 bck
, BT_LOGICAL
, dl
, 1);
1518 make_generic ("scan", GFC_ISYM_SCAN
);
1520 /* Added for G77 compatibility garbage. */
1521 add_sym_0 ("second", 0, 1, BT_REAL
, 4, NULL
, NULL
, NULL
);
1523 make_generic ("second", GFC_ISYM_SECOND
);
1525 add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER
, di
,
1526 NULL
, gfc_simplify_selected_int_kind
, NULL
,
1527 r
, BT_INTEGER
, di
, 0);
1529 make_generic ("selected_int_kind", GFC_ISYM_SI_KIND
);
1531 add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER
, di
,
1532 gfc_check_selected_real_kind
, gfc_simplify_selected_real_kind
,
1533 NULL
, p
, BT_INTEGER
, di
, 1, r
, BT_INTEGER
, di
, 1);
1535 make_generic ("selected_real_kind", GFC_ISYM_SR_KIND
);
1537 add_sym_2 ("set_exponent", 1, 1, BT_REAL
, dr
,
1538 gfc_check_set_exponent
, gfc_simplify_set_exponent
,
1539 gfc_resolve_set_exponent
,
1540 x
, BT_REAL
, dr
, 0, i
, BT_INTEGER
, di
, 0);
1542 make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT
);
1544 add_sym_1 ("shape", 0, 1, BT_INTEGER
, di
,
1545 gfc_check_shape
, gfc_simplify_shape
, gfc_resolve_shape
,
1546 src
, BT_REAL
, dr
, 0);
1548 make_generic ("shape", GFC_ISYM_SHAPE
);
1550 add_sym_2 ("sign", 1, 1, BT_REAL
, dr
,
1551 gfc_check_sign
, gfc_simplify_sign
, gfc_resolve_sign
,
1552 a
, BT_REAL
, dr
, 0, b
, BT_REAL
, dr
, 0);
1554 add_sym_2 ("isign", 1, 1, BT_INTEGER
, di
,
1555 NULL
, gfc_simplify_sign
, gfc_resolve_sign
,
1556 a
, BT_INTEGER
, di
, 0, b
, BT_INTEGER
, di
, 0);
1558 add_sym_2 ("dsign", 1, 1, BT_REAL
, dd
,
1559 NULL
, gfc_simplify_sign
, gfc_resolve_sign
,
1560 a
, BT_REAL
, dd
, 0, b
, BT_REAL
, dd
, 0);
1562 make_generic ("sign", GFC_ISYM_SIGN
);
1564 add_sym_1 ("sin", 1, 1, BT_REAL
, dr
,
1565 NULL
, gfc_simplify_sin
, gfc_resolve_sin
, x
, BT_REAL
, dr
, 0);
1567 add_sym_1 ("dsin", 1, 1, BT_REAL
, dd
,
1568 NULL
, gfc_simplify_sin
, gfc_resolve_sin
, x
, BT_REAL
, dd
, 0);
1570 add_sym_1 ("csin", 1, 1, BT_COMPLEX
, dz
,
1571 NULL
, gfc_simplify_sin
, gfc_resolve_sin
,
1572 x
, BT_COMPLEX
, dz
, 0);
1574 add_sym_1 ("zsin", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_sin
, gfc_resolve_sin
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
1576 make_alias ("cdsin");
1578 make_generic ("sin", GFC_ISYM_SIN
);
1580 add_sym_1 ("sinh", 1, 1, BT_REAL
, dr
,
1581 NULL
, gfc_simplify_sinh
, gfc_resolve_sinh
,
1584 add_sym_1 ("dsinh", 1, 1, BT_REAL
, dd
,
1585 NULL
, gfc_simplify_sinh
, gfc_resolve_sinh
,
1588 make_generic ("sinh", GFC_ISYM_SINH
);
1590 add_sym_2 ("size", 0, 1, BT_INTEGER
, di
,
1591 gfc_check_size
, gfc_simplify_size
, NULL
,
1592 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1);
1594 make_generic ("size", GFC_ISYM_SIZE
);
1596 add_sym_1 ("spacing", 1, 1, BT_REAL
, dr
,
1597 gfc_check_x
, gfc_simplify_spacing
, gfc_resolve_spacing
,
1600 make_generic ("spacing", GFC_ISYM_SPACING
);
1602 add_sym_3 ("spread", 0, 1, BT_REAL
, dr
,
1603 gfc_check_spread
, NULL
, gfc_resolve_spread
,
1604 src
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 0,
1605 n
, BT_INTEGER
, di
, 0);
1607 make_generic ("spread", GFC_ISYM_SPREAD
);
1609 add_sym_1 ("sqrt", 1, 1, BT_REAL
, dr
,
1610 NULL
, gfc_simplify_sqrt
, gfc_resolve_sqrt
,
1613 add_sym_1 ("dsqrt", 1, 1, BT_REAL
, dd
,
1614 NULL
, gfc_simplify_sqrt
, gfc_resolve_sqrt
,
1617 add_sym_1 ("csqrt", 1, 1, BT_COMPLEX
, dz
,
1618 NULL
, gfc_simplify_sqrt
, gfc_resolve_sqrt
,
1619 x
, BT_COMPLEX
, dz
, 0);
1621 add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_sqrt
, gfc_resolve_sqrt
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
1623 make_alias ("cdsqrt");
1625 make_generic ("sqrt", GFC_ISYM_SQRT
);
1627 add_sym_3 ("sum", 0, 1, BT_UNKNOWN
, 0,
1628 gfc_check_sum
, NULL
, gfc_resolve_sum
,
1629 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1630 msk
, BT_LOGICAL
, dl
, 1);
1632 make_generic ("sum", GFC_ISYM_SUM
);
1634 add_sym_1 ("tan", 1, 1, BT_REAL
, dr
,
1635 NULL
, gfc_simplify_tan
, gfc_resolve_tan
, x
, BT_REAL
, dr
, 0);
1637 add_sym_1 ("dtan", 1, 1, BT_REAL
, dd
,
1638 NULL
, gfc_simplify_tan
, gfc_resolve_tan
, x
, BT_REAL
, dd
, 0);
1640 make_generic ("tan", GFC_ISYM_TAN
);
1642 add_sym_1 ("tanh", 1, 1, BT_REAL
, dr
,
1643 NULL
, gfc_simplify_tanh
, gfc_resolve_tanh
,
1646 add_sym_1 ("dtanh", 1, 1, BT_REAL
, dd
,
1647 NULL
, gfc_simplify_tanh
, gfc_resolve_tanh
,
1650 make_generic ("tanh", GFC_ISYM_TANH
);
1652 add_sym_1 ("tiny", 0, 1, BT_REAL
, dr
,
1653 gfc_check_x
, gfc_simplify_tiny
, NULL
, x
, BT_REAL
, dr
, 0);
1655 make_generic ("tiny", GFC_ISYM_NONE
);
1657 add_sym_3 ("transfer", 0, 1, BT_REAL
, dr
,
1658 gfc_check_transfer
, NULL
, gfc_resolve_transfer
,
1659 src
, BT_REAL
, dr
, 0, mo
, BT_REAL
, dr
, 0,
1660 sz
, BT_INTEGER
, di
, 1);
1662 make_generic ("transfer", GFC_ISYM_TRANSFER
);
1664 add_sym_1 ("transpose", 0, 1, BT_REAL
, dr
,
1665 gfc_check_transpose
, NULL
, gfc_resolve_transpose
,
1668 make_generic ("transpose", GFC_ISYM_TRANSPOSE
);
1670 add_sym_1 ("trim", 0, 1, BT_CHARACTER
, dc
,
1671 gfc_check_trim
, gfc_simplify_trim
, gfc_resolve_trim
,
1672 stg
, BT_CHARACTER
, dc
, 0);
1674 make_generic ("trim", GFC_ISYM_TRIM
);
1676 add_sym_2 ("ubound", 0, 1, BT_INTEGER
, di
,
1677 gfc_check_ubound
, gfc_simplify_ubound
, gfc_resolve_ubound
,
1678 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1);
1680 make_generic ("ubound", GFC_ISYM_UBOUND
);
1682 add_sym_3 ("unpack", 0, 1, BT_REAL
, dr
,
1683 gfc_check_unpack
, NULL
, gfc_resolve_unpack
,
1684 v
, BT_REAL
, dr
, 0, msk
, BT_LOGICAL
, dl
, 0,
1687 make_generic ("unpack", GFC_ISYM_UNPACK
);
1689 add_sym_3 ("verify", 1, 1, BT_INTEGER
, di
,
1690 gfc_check_verify
, gfc_simplify_verify
, gfc_resolve_verify
,
1691 stg
, BT_CHARACTER
, dc
, 0, set
, BT_CHARACTER
, dc
, 0,
1692 bck
, BT_LOGICAL
, dl
, 1);
1694 make_generic ("verify", GFC_ISYM_VERIFY
);
1701 /* Add intrinsic subroutines. */
1704 add_subroutines (void)
1706 /* Argument names as in the standard (to be used as argument keywords). */
1708 *h
= "harvest", *dt
= "date", *vl
= "values", *pt
= "put",
1709 *c
= "count", *tm
= "time", *tp
= "topos", *gt
= "get",
1710 *t
= "to", *zn
= "zone", *fp
= "frompos", *cm
= "count_max",
1711 *f
= "from", *sz
= "size", *ln
= "len", *cr
= "count_rate",
1712 *com
= "command", *length
= "length", *st
= "status",
1713 *val
= "value", *num
= "number";
1717 di
= gfc_default_integer_kind ();
1718 dr
= gfc_default_real_kind ();
1719 dc
= gfc_default_character_kind ();
1721 add_sym_0s ("abort", 1, NULL
);
1723 add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN
, 0,
1724 gfc_check_cpu_time
, NULL
, gfc_resolve_cpu_time
,
1725 tm
, BT_REAL
, dr
, 0);
1727 /* More G77 compatibility garbage. */
1728 add_sym_1s ("second", 0, 1, BT_UNKNOWN
, 0,
1729 gfc_check_second_sub
, NULL
, gfc_resolve_second_sub
,
1730 tm
, BT_REAL
, dr
, 0);
1732 add_sym_4 ("date_and_time", 0, 1, BT_UNKNOWN
, 0,
1733 gfc_check_date_and_time
, NULL
, NULL
,
1734 dt
, BT_CHARACTER
, dc
, 1, tm
, BT_CHARACTER
, dc
, 1,
1735 zn
, BT_CHARACTER
, dc
, 1, vl
, BT_INTEGER
, di
, 1);
1737 /* More G77 compatibility garbage. */
1738 add_sym_2s ("etime", 0, 1, BT_UNKNOWN
, 0,
1739 gfc_check_etime_sub
, NULL
, gfc_resolve_etime_sub
,
1740 vl
, BT_REAL
, 4, 0, tm
, BT_REAL
, 4, 0);
1742 add_sym_2s ("dtime", 0, 1, BT_UNKNOWN
, 0,
1743 gfc_check_etime_sub
, NULL
, gfc_resolve_etime_sub
,
1744 vl
, BT_REAL
, 4, 0, tm
, BT_REAL
, 4, 0);
1746 add_sym_2 ("getarg", 0, 1, BT_UNKNOWN
, 0,
1747 NULL
, NULL
, gfc_resolve_getarg
,
1748 c
, BT_INTEGER
, di
, 0, vl
, BT_CHARACTER
, dc
, 0);
1750 /* F2003 commandline routines. */
1752 add_sym_3s ("get_command", 0, 1, BT_UNKNOWN
, 0,
1753 NULL
, NULL
, gfc_resolve_get_command
,
1754 com
, BT_CHARACTER
, dc
, 1,
1755 length
, BT_INTEGER
, di
, 1,
1756 st
, BT_INTEGER
, di
, 1);
1758 add_sym_4 ("get_command_argument", 0, 1, BT_UNKNOWN
, 0,
1759 NULL
, NULL
, gfc_resolve_get_command_argument
,
1760 num
, BT_INTEGER
, di
, 0,
1761 val
, BT_CHARACTER
, dc
, 1,
1762 length
, BT_INTEGER
, di
, 1,
1763 st
, BT_INTEGER
, di
, 1);
1767 add_sym_5 ("mvbits", 1, 1, BT_UNKNOWN
, 0,
1768 gfc_check_mvbits
, gfc_simplify_mvbits
, NULL
,
1769 f
, BT_INTEGER
, di
, 0, fp
, BT_INTEGER
, di
, 0,
1770 ln
, BT_INTEGER
, di
, 0, t
, BT_INTEGER
, di
, 0,
1771 tp
, BT_INTEGER
, di
, 0);
1773 add_sym_1s ("random_number", 0, 1, BT_UNKNOWN
, 0,
1774 gfc_check_random_number
, NULL
, gfc_resolve_random_number
,
1777 add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN
, 0,
1778 gfc_check_random_seed
, NULL
, NULL
,
1779 sz
, BT_INTEGER
, di
, 1, pt
, BT_INTEGER
, di
, 1,
1780 gt
, BT_INTEGER
, di
, 1);
1782 /* More G77 compatibility garbage. */
1783 add_sym_1s ("srand", 0, 1, BT_UNKNOWN
, di
,
1784 gfc_check_srand
, NULL
, gfc_resolve_srand
,
1785 c
, BT_INTEGER
, 4, 0);
1787 add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN
, 0,
1788 gfc_check_system_clock
, NULL
, gfc_resolve_system_clock
,
1789 c
, BT_INTEGER
, di
, 1, cr
, BT_INTEGER
, di
, 1,
1790 cm
, BT_INTEGER
, di
, 1);
1794 /* Add a function to the list of conversion symbols. */
1797 add_conv (bt from_type
, int from_kind
, bt to_type
, int to_kind
,
1798 gfc_expr
* (*simplify
) (gfc_expr
*, bt
, int))
1801 gfc_typespec from
, to
;
1802 gfc_intrinsic_sym
*sym
;
1804 if (sizing
== SZ_CONVS
)
1810 gfc_clear_ts (&from
);
1811 from
.type
= from_type
;
1812 from
.kind
= from_kind
;
1818 sym
= conversion
+ nconv
;
1820 strcpy (sym
->name
, conv_name (&from
, &to
));
1821 strcpy (sym
->lib_name
, sym
->name
);
1822 sym
->simplify
.cc
= simplify
;
1825 sym
->generic_id
= GFC_ISYM_CONVERSION
;
1831 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
1832 functions by looping over the kind tables. */
1835 add_conversions (void)
1839 /* Integer-Integer conversions. */
1840 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
1841 for (j
= 0; gfc_integer_kinds
[j
].kind
!= 0; j
++)
1846 add_conv (BT_INTEGER
, gfc_integer_kinds
[i
].kind
,
1847 BT_INTEGER
, gfc_integer_kinds
[j
].kind
, gfc_convert_constant
);
1850 /* Integer-Real/Complex conversions. */
1851 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
1852 for (j
= 0; gfc_real_kinds
[j
].kind
!= 0; j
++)
1854 add_conv (BT_INTEGER
, gfc_integer_kinds
[i
].kind
,
1855 BT_REAL
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1857 add_conv (BT_REAL
, gfc_real_kinds
[j
].kind
,
1858 BT_INTEGER
, gfc_integer_kinds
[i
].kind
, gfc_convert_constant
);
1860 add_conv (BT_INTEGER
, gfc_integer_kinds
[i
].kind
,
1861 BT_COMPLEX
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1863 add_conv (BT_COMPLEX
, gfc_real_kinds
[j
].kind
,
1864 BT_INTEGER
, gfc_integer_kinds
[i
].kind
, gfc_convert_constant
);
1867 /* Real/Complex - Real/Complex conversions. */
1868 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
1869 for (j
= 0; gfc_real_kinds
[j
].kind
!= 0; j
++)
1873 add_conv (BT_REAL
, gfc_real_kinds
[i
].kind
,
1874 BT_REAL
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1876 add_conv (BT_COMPLEX
, gfc_real_kinds
[i
].kind
,
1877 BT_COMPLEX
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1880 add_conv (BT_REAL
, gfc_real_kinds
[i
].kind
,
1881 BT_COMPLEX
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1883 add_conv (BT_COMPLEX
, gfc_real_kinds
[i
].kind
,
1884 BT_REAL
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1887 /* Logical/Logical kind conversion. */
1888 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
1889 for (j
= 0; gfc_logical_kinds
[j
].kind
; j
++)
1894 add_conv (BT_LOGICAL
, gfc_logical_kinds
[i
].kind
,
1895 BT_LOGICAL
, gfc_logical_kinds
[j
].kind
, gfc_convert_constant
);
1900 /* Initialize the table of intrinsics. */
1902 gfc_intrinsic_init_1 (void)
1906 nargs
= nfunc
= nsub
= nconv
= 0;
1908 /* Create a namespace to hold the resolved intrinsic symbols. */
1909 gfc_intrinsic_namespace
= gfc_get_namespace (NULL
);
1918 functions
= gfc_getmem (sizeof (gfc_intrinsic_sym
) * (nfunc
+ nsub
)
1919 + sizeof (gfc_intrinsic_arg
) * nargs
);
1921 next_sym
= functions
;
1922 subroutines
= functions
+ nfunc
;
1924 conversion
= gfc_getmem (sizeof (gfc_intrinsic_sym
) * nconv
);
1926 next_arg
= ((gfc_intrinsic_arg
*) (subroutines
+ nsub
)) - 1;
1928 sizing
= SZ_NOTHING
;
1935 /* Set the pure flag. All intrinsic functions are pure, and
1936 intrinsic subroutines are pure if they are elemental. */
1938 for (i
= 0; i
< nfunc
; i
++)
1939 functions
[i
].pure
= 1;
1941 for (i
= 0; i
< nsub
; i
++)
1942 subroutines
[i
].pure
= subroutines
[i
].elemental
;
1947 gfc_intrinsic_done_1 (void)
1949 gfc_free (functions
);
1950 gfc_free (conversion
);
1951 gfc_free_namespace (gfc_intrinsic_namespace
);
1955 /******** Subroutines to check intrinsic interfaces ***********/
1957 /* Given a formal argument list, remove any NULL arguments that may
1958 have been left behind by a sort against some formal argument list. */
1961 remove_nullargs (gfc_actual_arglist
** ap
)
1963 gfc_actual_arglist
*head
, *tail
, *next
;
1967 for (head
= *ap
; head
; head
= next
)
1971 if (head
->expr
== NULL
)
1974 gfc_free_actual_arglist (head
);
1993 /* Given an actual arglist and a formal arglist, sort the actual
1994 arglist so that its arguments are in a one-to-one correspondence
1995 with the format arglist. Arguments that are not present are given
1996 a blank gfc_actual_arglist structure. If something is obviously
1997 wrong (say, a missing required argument) we abort sorting and
2001 sort_actual (const char *name
, gfc_actual_arglist
** ap
,
2002 gfc_intrinsic_arg
* formal
, locus
* where
)
2005 gfc_actual_arglist
*actual
, *a
;
2006 gfc_intrinsic_arg
*f
;
2008 remove_nullargs (ap
);
2011 for (f
= formal
; f
; f
= f
->next
)
2017 if (f
== NULL
&& a
== NULL
) /* No arguments */
2021 { /* Put the nonkeyword arguments in a 1:1 correspondence */
2027 if (a
->name
[0] != '\0')
2039 gfc_error ("Too many arguments in call to '%s' at %L", name
, where
);
2043 /* Associate the remaining actual arguments, all of which have
2044 to be keyword arguments. */
2045 for (; a
; a
= a
->next
)
2047 for (f
= formal
; f
; f
= f
->next
)
2048 if (strcmp (a
->name
, f
->name
) == 0)
2053 gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2054 a
->name
, name
, where
);
2058 if (f
->actual
!= NULL
)
2060 gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2061 f
->name
, name
, where
);
2069 /* At this point, all unmatched formal args must be optional. */
2070 for (f
= formal
; f
; f
= f
->next
)
2072 if (f
->actual
== NULL
&& f
->optional
== 0)
2074 gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2075 f
->name
, name
, where
);
2081 /* Using the formal argument list, string the actual argument list
2082 together in a way that corresponds with the formal list. */
2085 for (f
= formal
; f
; f
= f
->next
)
2087 if (f
->actual
== NULL
)
2089 a
= gfc_get_actual_arglist ();
2090 a
->missing_arg_type
= f
->ts
.type
;
2102 actual
->next
= NULL
; /* End the sorted argument list. */
2108 /* Compare an actual argument list with an intrinsic's formal argument
2109 list. The lists are checked for agreement of type. We don't check
2110 for arrayness here. */
2113 check_arglist (gfc_actual_arglist
** ap
, gfc_intrinsic_sym
* sym
,
2116 gfc_actual_arglist
*actual
;
2117 gfc_intrinsic_arg
*formal
;
2120 formal
= sym
->formal
;
2124 for (; formal
; formal
= formal
->next
, actual
= actual
->next
, i
++)
2126 if (actual
->expr
== NULL
)
2129 if (!gfc_compare_types (&formal
->ts
, &actual
->expr
->ts
))
2133 ("Type of argument '%s' in call to '%s' at %L should be "
2134 "%s, not %s", gfc_current_intrinsic_arg
[i
],
2135 gfc_current_intrinsic
, &actual
->expr
->where
,
2136 gfc_typename (&formal
->ts
), gfc_typename (&actual
->expr
->ts
));
2145 /* Given a pointer to an intrinsic symbol and an expression node that
2146 represent the function call to that subroutine, figure out the type
2147 of the result. This may involve calling a resolution subroutine. */
2150 resolve_intrinsic (gfc_intrinsic_sym
* specific
, gfc_expr
* e
)
2152 gfc_expr
*a1
, *a2
, *a3
, *a4
, *a5
;
2153 gfc_actual_arglist
*arg
;
2155 if (specific
->resolve
.f1
== NULL
)
2157 if (e
->value
.function
.name
== NULL
)
2158 e
->value
.function
.name
= specific
->lib_name
;
2160 if (e
->ts
.type
== BT_UNKNOWN
)
2161 e
->ts
= specific
->ts
;
2165 arg
= e
->value
.function
.actual
;
2167 /* At present only the iargc extension intrinsic takes no arguments,
2168 and it doesn't need a resolution function, but this is here for
2172 (*specific
->resolve
.f0
) (e
);
2176 /* Special case hacks for MIN and MAX. */
2177 if (specific
->resolve
.f1m
== gfc_resolve_max
2178 || specific
->resolve
.f1m
== gfc_resolve_min
)
2180 (*specific
->resolve
.f1m
) (e
, arg
);
2189 (*specific
->resolve
.f1
) (e
, a1
);
2198 (*specific
->resolve
.f2
) (e
, a1
, a2
);
2207 (*specific
->resolve
.f3
) (e
, a1
, a2
, a3
);
2216 (*specific
->resolve
.f4
) (e
, a1
, a2
, a3
, a4
);
2225 (*specific
->resolve
.f5
) (e
, a1
, a2
, a3
, a4
, a5
);
2229 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2233 /* Given an intrinsic symbol node and an expression node, call the
2234 simplification function (if there is one), perhaps replacing the
2235 expression with something simpler. We return FAILURE on an error
2236 of the simplification, SUCCESS if the simplification worked, even
2237 if nothing has changed in the expression itself. */
2240 do_simplify (gfc_intrinsic_sym
* specific
, gfc_expr
* e
)
2242 gfc_expr
*result
, *a1
, *a2
, *a3
, *a4
, *a5
;
2243 gfc_actual_arglist
*arg
;
2245 /* Max and min require special handling due to the variable number
2247 if (specific
->simplify
.f1
== gfc_simplify_min
)
2249 result
= gfc_simplify_min (e
);
2253 if (specific
->simplify
.f1
== gfc_simplify_max
)
2255 result
= gfc_simplify_max (e
);
2259 if (specific
->simplify
.f1
== NULL
)
2265 arg
= e
->value
.function
.actual
;
2270 if (specific
->simplify
.cc
== gfc_convert_constant
)
2272 result
= gfc_convert_constant (a1
, specific
->ts
.type
, specific
->ts
.kind
);
2276 /* TODO: Warn if -pedantic and initialization expression and arg
2277 types not integer or character */
2280 result
= (*specific
->simplify
.f1
) (a1
);
2287 result
= (*specific
->simplify
.f2
) (a1
, a2
);
2294 result
= (*specific
->simplify
.f3
) (a1
, a2
, a3
);
2301 result
= (*specific
->simplify
.f4
) (a1
, a2
, a3
, a4
);
2308 result
= (*specific
->simplify
.f5
) (a1
, a2
, a3
, a4
, a5
);
2311 ("do_simplify(): Too many args for intrinsic");
2318 if (result
== &gfc_bad_expr
)
2322 resolve_intrinsic (specific
, e
); /* Must call at run-time */
2325 result
->where
= e
->where
;
2326 gfc_replace_expr (e
, result
);
2333 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2334 error messages. This subroutine returns FAILURE if a subroutine
2335 has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2336 list cannot match any intrinsic. */
2339 init_arglist (gfc_intrinsic_sym
* isym
)
2341 gfc_intrinsic_arg
*formal
;
2344 gfc_current_intrinsic
= isym
->name
;
2347 for (formal
= isym
->formal
; formal
; formal
= formal
->next
)
2349 if (i
>= MAX_INTRINSIC_ARGS
)
2350 gfc_internal_error ("init_arglist(): too many arguments");
2351 gfc_current_intrinsic_arg
[i
++] = formal
->name
;
2356 /* Given a pointer to an intrinsic symbol and an expression consisting
2357 of a function call, see if the function call is consistent with the
2358 intrinsic's formal argument list. Return SUCCESS if the expression
2359 and intrinsic match, FAILURE otherwise. */
2362 check_specific (gfc_intrinsic_sym
* specific
, gfc_expr
* expr
, int error_flag
)
2364 gfc_actual_arglist
*arg
, **ap
;
2368 ap
= &expr
->value
.function
.actual
;
2370 init_arglist (specific
);
2372 /* Don't attempt to sort the argument list for min or max. */
2373 if (specific
->check
.f1m
== gfc_check_min_max
2374 || specific
->check
.f1m
== gfc_check_min_max_integer
2375 || specific
->check
.f1m
== gfc_check_min_max_real
2376 || specific
->check
.f1m
== gfc_check_min_max_double
)
2377 return (*specific
->check
.f1m
) (*ap
);
2379 if (sort_actual (specific
->name
, ap
, specific
->formal
,
2380 &expr
->where
) == FAILURE
)
2383 if (specific
->check
.f3ml
!= gfc_check_minloc_maxloc
)
2385 if (specific
->check
.f1
== NULL
)
2387 t
= check_arglist (ap
, specific
, error_flag
);
2389 expr
->ts
= specific
->ts
;
2392 t
= do_check (specific
, *ap
);
2395 /* This is special because we might have to reorder the argument
2397 t
= gfc_check_minloc_maxloc (*ap
);
2399 /* Check ranks for elemental intrinsics. */
2400 if (t
== SUCCESS
&& specific
->elemental
)
2403 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2405 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2409 r
= arg
->expr
->rank
;
2413 if (arg
->expr
->rank
!= r
)
2416 ("Ranks of arguments to elemental intrinsic '%s' differ "
2417 "at %L", specific
->name
, &arg
->expr
->where
);
2424 remove_nullargs (ap
);
2430 /* See if an intrinsic is one of the intrinsics we evaluate
2434 gfc_init_expr_extensions (gfc_intrinsic_sym
*isym
)
2436 /* FIXME: This should be moved into the intrinsic definitions. */
2437 static const char * const init_expr_extensions
[] = {
2438 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2439 "precision", "present", "radix", "range", "selected_real_kind",
2445 for (i
= 0; init_expr_extensions
[i
]; i
++)
2446 if (strcmp (init_expr_extensions
[i
], isym
->name
) == 0)
2453 /* See if a function call corresponds to an intrinsic function call.
2456 MATCH_YES if the call corresponds to an intrinsic, simplification
2457 is done if possible.
2459 MATCH_NO if the call does not correspond to an intrinsic
2461 MATCH_ERROR if the call corresponds to an intrinsic but there was an
2462 error during the simplification process.
2464 The error_flag parameter enables an error reporting. */
2467 gfc_intrinsic_func_interface (gfc_expr
* expr
, int error_flag
)
2469 gfc_intrinsic_sym
*isym
, *specific
;
2470 gfc_actual_arglist
*actual
;
2474 if (expr
->value
.function
.isym
!= NULL
)
2475 return (do_simplify (expr
->value
.function
.isym
, expr
) == FAILURE
)
2476 ? MATCH_ERROR
: MATCH_YES
;
2478 gfc_suppress_error
= !error_flag
;
2481 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2482 if (actual
->expr
!= NULL
)
2483 flag
|= (actual
->expr
->ts
.type
!= BT_INTEGER
2484 && actual
->expr
->ts
.type
!= BT_CHARACTER
);
2486 name
= expr
->symtree
->n
.sym
->name
;
2488 isym
= specific
= gfc_find_function (name
);
2491 gfc_suppress_error
= 0;
2495 gfc_current_intrinsic_where
= &expr
->where
;
2497 /* Bypass the generic list for min and max. */
2498 if (isym
->check
.f1m
== gfc_check_min_max
)
2500 init_arglist (isym
);
2502 if (gfc_check_min_max (expr
->value
.function
.actual
) == SUCCESS
)
2505 gfc_suppress_error
= 0;
2509 /* If the function is generic, check all of its specific
2510 incarnations. If the generic name is also a specific, we check
2511 that name last, so that any error message will correspond to the
2513 gfc_suppress_error
= 1;
2517 for (specific
= isym
->specific_head
; specific
;
2518 specific
= specific
->next
)
2520 if (specific
== isym
)
2522 if (check_specific (specific
, expr
, 0) == SUCCESS
)
2527 gfc_suppress_error
= !error_flag
;
2529 if (check_specific (isym
, expr
, error_flag
) == FAILURE
)
2531 gfc_suppress_error
= 0;
2538 expr
->value
.function
.isym
= specific
;
2539 gfc_intrinsic_symbol (expr
->symtree
->n
.sym
);
2541 if (do_simplify (specific
, expr
) == FAILURE
)
2543 gfc_suppress_error
= 0;
2547 /* TODO: We should probably only allow elemental functions here. */
2548 flag
|= (expr
->ts
.type
!= BT_INTEGER
&& expr
->ts
.type
!= BT_CHARACTER
);
2550 gfc_suppress_error
= 0;
2551 if (pedantic
&& gfc_init_expr
2552 && flag
&& gfc_init_expr_extensions (specific
))
2554 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Evaluation of "
2555 "nonstandard initialization expression at %L", &expr
->where
)
2566 /* See if a CALL statement corresponds to an intrinsic subroutine.
2567 Returns MATCH_YES if the subroutine corresponds to an intrinsic,
2568 MATCH_NO if not, and MATCH_ERROR if there was an error (but did
2572 gfc_intrinsic_sub_interface (gfc_code
* c
, int error_flag
)
2574 gfc_intrinsic_sym
*isym
;
2577 name
= c
->symtree
->n
.sym
->name
;
2579 isym
= find_subroutine (name
);
2583 gfc_suppress_error
= !error_flag
;
2585 init_arglist (isym
);
2587 if (sort_actual (name
, &c
->ext
.actual
, isym
->formal
, &c
->loc
) == FAILURE
)
2590 if (isym
->check
.f1
!= NULL
)
2592 if (do_check (isym
, c
->ext
.actual
) == FAILURE
)
2597 if (check_arglist (&c
->ext
.actual
, isym
, 1) == FAILURE
)
2601 /* The subroutine corresponds to an intrinsic. Allow errors to be
2602 seen at this point. */
2603 gfc_suppress_error
= 0;
2605 if (isym
->resolve
.s1
!= NULL
)
2606 isym
->resolve
.s1 (c
);
2608 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (isym
->lib_name
);
2610 if (gfc_pure (NULL
) && !isym
->elemental
)
2612 gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name
,
2620 gfc_suppress_error
= 0;
2625 /* Call gfc_convert_type() with warning enabled. */
2628 gfc_convert_type (gfc_expr
* expr
, gfc_typespec
* ts
, int eflag
)
2630 return gfc_convert_type_warn (expr
, ts
, eflag
, 1);
2634 /* Try to convert an expression (in place) from one type to another.
2635 'eflag' controls the behavior on error.
2637 The possible values are:
2639 1 Generate a gfc_error()
2640 2 Generate a gfc_internal_error().
2642 'wflag' controls the warning related to conversion. */
2645 gfc_convert_type_warn (gfc_expr
* expr
, gfc_typespec
* ts
, int eflag
,
2648 gfc_intrinsic_sym
*sym
;
2649 gfc_typespec from_ts
;
2654 from_ts
= expr
->ts
; /* expr->ts gets clobbered */
2656 if (ts
->type
== BT_UNKNOWN
)
2659 /* NULL and zero size arrays get their type here. */
2660 if (expr
->expr_type
== EXPR_NULL
2661 || (expr
->expr_type
== EXPR_ARRAY
2662 && expr
->value
.constructor
== NULL
))
2664 /* Sometimes the RHS acquire the type. */
2669 if (expr
->ts
.type
== BT_UNKNOWN
)
2672 if (expr
->ts
.type
== BT_DERIVED
2673 && ts
->type
== BT_DERIVED
2674 && gfc_compare_types (&expr
->ts
, ts
))
2677 sym
= find_conv (&expr
->ts
, ts
);
2681 /* At this point, a conversion is necessary. A warning may be needed. */
2682 if (wflag
&& gfc_option
.warn_conversion
)
2683 gfc_warning_now ("Conversion from %s to %s at %L",
2684 gfc_typename (&from_ts
), gfc_typename (ts
), &expr
->where
);
2686 /* Insert a pre-resolved function call to the right function. */
2687 old_where
= expr
->where
;
2689 new = gfc_get_expr ();
2692 new = gfc_build_conversion (new);
2693 new->value
.function
.name
= sym
->lib_name
;
2694 new->value
.function
.isym
= sym
;
2695 new->where
= old_where
;
2703 if (gfc_is_constant_expr (expr
->value
.function
.actual
->expr
)
2704 && do_simplify (sym
, expr
) == FAILURE
)
2709 return FAILURE
; /* Error already generated in do_simplify() */
2717 gfc_error ("Can't convert %s to %s at %L",
2718 gfc_typename (&from_ts
), gfc_typename (ts
), &expr
->where
);
2722 gfc_internal_error ("Can't convert %s to %s at %L",
2723 gfc_typename (&from_ts
), gfc_typename (ts
),