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 /* Locate an intrinsic symbol given a base pointer, number of elements
621 in the table and a pointer to a name. Returns the NULL pointer if
622 a name is not found. */
624 static gfc_intrinsic_sym
*
625 find_sym (gfc_intrinsic_sym
* start
, int n
, const char *name
)
630 if (strcmp (name
, start
->name
) == 0)
641 /* Given a name, find a function in the intrinsic function table.
642 Returns NULL if not found. */
645 gfc_find_function (const char *name
)
648 return find_sym (functions
, nfunc
, name
);
652 /* Given a name, find a function in the intrinsic subroutine table.
653 Returns NULL if not found. */
655 static gfc_intrinsic_sym
*
656 find_subroutine (const char *name
)
659 return find_sym (subroutines
, nsub
, name
);
663 /* Given a string, figure out if it is the name of a generic intrinsic
667 gfc_generic_intrinsic (const char *name
)
669 gfc_intrinsic_sym
*sym
;
671 sym
= gfc_find_function (name
);
672 return (sym
== NULL
) ? 0 : sym
->generic
;
676 /* Given a string, figure out if it is the name of a specific
677 intrinsic function or not. */
680 gfc_specific_intrinsic (const char *name
)
682 gfc_intrinsic_sym
*sym
;
684 sym
= gfc_find_function (name
);
685 return (sym
== NULL
) ? 0 : sym
->specific
;
689 /* Given a string, figure out if it is the name of an intrinsic
690 subroutine or function. There are no generic intrinsic
691 subroutines, they are all specific. */
694 gfc_intrinsic_name (const char *name
, int subroutine_flag
)
697 return subroutine_flag
?
698 find_subroutine (name
) != NULL
: gfc_find_function (name
) != NULL
;
702 /* Collect a set of intrinsic functions into a generic collection.
703 The first argument is the name of the generic function, which is
704 also the name of a specific function. The rest of the specifics
705 currently in the table are placed into the list of specific
706 functions associated with that generic. */
709 make_generic (const char *name
, gfc_generic_isym_id generic_id
)
711 gfc_intrinsic_sym
*g
;
713 if (sizing
!= SZ_NOTHING
)
716 g
= gfc_find_function (name
);
718 gfc_internal_error ("make_generic(): Can't find generic symbol '%s'",
723 g
->generic_id
= generic_id
;
724 if ((g
+ 1)->name
[0] != '\0')
725 g
->specific_head
= g
+ 1;
728 while (g
->name
[0] != '\0')
732 g
->generic_id
= generic_id
;
741 /* Create a duplicate intrinsic function entry for the current
742 function, the only difference being the alternate name. Note that
743 we use argument lists more than once, but all argument lists are
744 freed as a single block. */
747 make_alias (const char *name
)
761 next_sym
[0] = next_sym
[-1];
762 strcpy (next_sym
->name
, name
);
772 /* Add intrinsic functions. */
778 /* Argument names as in the standard (to be used as argument keywords). */
780 *a
= "a", *f
= "field", *pt
= "pointer", *tg
= "target",
781 *b
= "b", *m
= "matrix", *ma
= "matrix_a", *mb
= "matrix_b",
782 *c
= "c", *n
= "ncopies", *pos
= "pos", *bck
= "back",
783 *i
= "i", *v
= "vector", *va
= "vector_a", *vb
= "vector_b",
784 *j
= "j", *a1
= "a1", *fs
= "fsource", *ts
= "tsource",
785 *l
= "l", *a2
= "a2", *mo
= "mold", *ord
= "order",
786 *p
= "p", *ar
= "array", *shp
= "shape", *src
= "source",
787 *r
= "r", *bd
= "boundary", *pad
= "pad", *set
= "set",
788 *s
= "s", *dm
= "dim", *kind
= "kind", *msk
= "mask",
789 *x
= "x", *sh
= "shift", *stg
= "string", *ssg
= "substring",
790 *y
= "y", *sz
= "size", *sta
= "string_a", *stb
= "string_b",
791 *z
= "z", *ln
= "len";
793 int di
, dr
, dd
, dl
, dc
, dz
, ii
;
795 di
= gfc_default_integer_kind ();
796 dr
= gfc_default_real_kind ();
797 dd
= gfc_default_double_kind ();
798 dl
= gfc_default_logical_kind ();
799 dc
= gfc_default_character_kind ();
800 dz
= gfc_default_complex_kind ();
801 ii
= gfc_index_integer_kind
;
803 add_sym_1 ("abs", 1, 1, BT_REAL
, dr
,
804 gfc_check_abs
, gfc_simplify_abs
, gfc_resolve_abs
,
807 add_sym_1 ("iabs", 1, 1, BT_INTEGER
, di
,
808 NULL
, gfc_simplify_abs
, gfc_resolve_abs
,
809 a
, BT_INTEGER
, di
, 0);
811 add_sym_1 ("dabs", 1, 1, BT_REAL
, dd
,
812 NULL
, gfc_simplify_abs
, gfc_resolve_abs
, a
, BT_REAL
, dd
, 0);
814 add_sym_1 ("cabs", 1, 1, BT_REAL
, dr
,
815 NULL
, gfc_simplify_abs
, gfc_resolve_abs
,
816 a
, BT_COMPLEX
, dz
, 0);
818 add_sym_1 ("zabs", 1, 1, BT_REAL
, dd
, NULL
, gfc_simplify_abs
, gfc_resolve_abs
, a
, BT_COMPLEX
, dd
, 0); /* Extension */
820 make_alias ("cdabs");
822 make_generic ("abs", GFC_ISYM_ABS
);
824 add_sym_1 ("achar", 1, 1, BT_CHARACTER
, dc
,
825 NULL
, gfc_simplify_achar
, NULL
, i
, BT_INTEGER
, di
, 0);
827 make_generic ("achar", GFC_ISYM_ACHAR
);
829 add_sym_1 ("acos", 1, 1, BT_REAL
, dr
,
830 NULL
, gfc_simplify_acos
, gfc_resolve_acos
,
833 add_sym_1 ("dacos", 1, 1, BT_REAL
, dd
,
834 NULL
, gfc_simplify_acos
, gfc_resolve_acos
,
837 make_generic ("acos", GFC_ISYM_ACOS
);
839 add_sym_1 ("adjustl", 1, 1, BT_CHARACTER
, dc
,
840 NULL
, gfc_simplify_adjustl
, NULL
, stg
, BT_CHARACTER
, dc
, 0);
842 make_generic ("adjustl", GFC_ISYM_ADJUSTL
);
844 add_sym_1 ("adjustr", 1, 1, BT_CHARACTER
, dc
,
845 NULL
, gfc_simplify_adjustr
, NULL
, stg
, BT_CHARACTER
, dc
, 0);
847 make_generic ("adjustr", GFC_ISYM_ADJUSTR
);
849 add_sym_1 ("aimag", 1, 1, BT_REAL
, dr
,
850 NULL
, gfc_simplify_aimag
, gfc_resolve_aimag
,
851 z
, BT_COMPLEX
, dz
, 0);
853 add_sym_1 ("dimag", 1, 1, BT_REAL
, dd
, NULL
, gfc_simplify_aimag
, gfc_resolve_aimag
, z
, BT_COMPLEX
, dd
, 0); /* Extension */
855 make_generic ("aimag", GFC_ISYM_AIMAG
);
857 add_sym_2 ("aint", 1, 1, BT_REAL
, dr
,
858 gfc_check_a_xkind
, gfc_simplify_aint
, gfc_resolve_aint
,
859 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
861 add_sym_1 ("dint", 1, 1, BT_REAL
, dd
,
862 NULL
, gfc_simplify_dint
, gfc_resolve_dint
,
865 make_generic ("aint", GFC_ISYM_AINT
);
867 add_sym_2 ("all", 0, 1, BT_UNKNOWN
, 0,
868 gfc_check_all_any
, NULL
, gfc_resolve_all
,
869 msk
, BT_LOGICAL
, dl
, 0, dm
, BT_INTEGER
, ii
, 1);
871 make_generic ("all", GFC_ISYM_ALL
);
873 add_sym_1 ("allocated", 0, 1, BT_LOGICAL
, dl
,
874 gfc_check_allocated
, NULL
, NULL
, ar
, BT_UNKNOWN
, 0, 0);
876 make_generic ("allocated", GFC_ISYM_ALLOCATED
);
878 add_sym_2 ("anint", 1, 1, BT_REAL
, dr
,
879 gfc_check_a_xkind
, gfc_simplify_anint
, gfc_resolve_anint
,
880 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
882 add_sym_1 ("dnint", 1, 1, BT_REAL
, dd
,
883 NULL
, gfc_simplify_dnint
, gfc_resolve_dnint
,
886 make_generic ("anint", GFC_ISYM_ANINT
);
888 add_sym_2 ("any", 0, 1, BT_UNKNOWN
, 0,
889 gfc_check_all_any
, NULL
, gfc_resolve_any
,
890 msk
, BT_LOGICAL
, dl
, 0, dm
, BT_INTEGER
, ii
, 1);
892 make_generic ("any", GFC_ISYM_ANY
);
894 add_sym_1 ("asin", 1, 1, BT_REAL
, dr
,
895 NULL
, gfc_simplify_asin
, gfc_resolve_asin
,
898 add_sym_1 ("dasin", 1, 1, BT_REAL
, dd
,
899 NULL
, gfc_simplify_asin
, gfc_resolve_asin
,
902 make_generic ("asin", GFC_ISYM_ASIN
);
904 add_sym_2 ("associated", 0, 1, BT_LOGICAL
, dl
,
905 gfc_check_associated
, NULL
, NULL
,
906 pt
, BT_UNKNOWN
, 0, 0, tg
, BT_UNKNOWN
, 0, 1);
908 make_generic ("associated", GFC_ISYM_ASSOCIATED
);
910 add_sym_1 ("atan", 1, 1, BT_REAL
, dr
,
911 NULL
, gfc_simplify_atan
, gfc_resolve_atan
,
914 add_sym_1 ("datan", 1, 1, BT_REAL
, dd
,
915 NULL
, gfc_simplify_atan
, gfc_resolve_atan
,
918 make_generic ("atan", GFC_ISYM_ATAN
);
920 add_sym_2 ("atan2", 1, 1, BT_REAL
, dr
,
921 NULL
, gfc_simplify_atan2
, gfc_resolve_atan2
,
922 y
, BT_REAL
, dr
, 0, x
, BT_REAL
, dr
, 0);
924 add_sym_2 ("datan2", 1, 1, BT_REAL
, dd
,
925 NULL
, gfc_simplify_atan2
, gfc_resolve_atan2
,
926 y
, BT_REAL
, dd
, 0, x
, BT_REAL
, dd
, 0);
928 make_generic ("atan2", GFC_ISYM_ATAN2
);
930 add_sym_1 ("bit_size", 0, 1, BT_INTEGER
, di
,
931 gfc_check_i
, gfc_simplify_bit_size
, NULL
,
932 i
, BT_INTEGER
, di
, 0);
934 make_generic ("bit_size", GFC_ISYM_NONE
);
936 add_sym_2 ("btest", 1, 1, BT_LOGICAL
, dl
,
937 gfc_check_btest
, gfc_simplify_btest
, gfc_resolve_btest
,
938 i
, BT_INTEGER
, di
, 0, pos
, BT_INTEGER
, di
, 0);
940 make_generic ("btest", GFC_ISYM_BTEST
);
942 add_sym_2 ("ceiling", 1, 1, BT_INTEGER
, di
,
943 gfc_check_a_ikind
, gfc_simplify_ceiling
, gfc_resolve_ceiling
,
944 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
946 make_generic ("ceiling", GFC_ISYM_CEILING
);
948 add_sym_2 ("char", 1, 0, BT_CHARACTER
, dc
,
949 gfc_check_char
, gfc_simplify_char
, gfc_resolve_char
,
950 i
, BT_INTEGER
, di
, 0, kind
, BT_INTEGER
, di
, 1);
952 make_generic ("char", GFC_ISYM_CHAR
);
954 add_sym_3 ("cmplx", 1, 1, BT_COMPLEX
, dz
,
955 gfc_check_cmplx
, gfc_simplify_cmplx
, gfc_resolve_cmplx
,
956 x
, BT_UNKNOWN
, dr
, 0, y
, BT_UNKNOWN
, dr
, 1,
957 kind
, BT_INTEGER
, di
, 1);
959 make_generic ("cmplx", GFC_ISYM_CMPLX
);
961 /* Making dcmplx a specific of cmplx causes cmplx to return a double
962 complex instead of the default complex. */
964 add_sym_2 ("dcmplx", 1, 1, BT_COMPLEX
, dd
,
965 gfc_check_dcmplx
, gfc_simplify_dcmplx
, gfc_resolve_dcmplx
,
966 x
, BT_REAL
, dd
, 0, y
, BT_REAL
, dd
, 1); /* Extension */
968 make_generic ("dcmplx", GFC_ISYM_CMPLX
);
970 add_sym_1 ("conjg", 1, 1, BT_COMPLEX
, dz
,
971 NULL
, gfc_simplify_conjg
, gfc_resolve_conjg
,
972 z
, BT_COMPLEX
, dz
, 0);
974 add_sym_1 ("dconjg", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_conjg
, gfc_resolve_conjg
, z
, BT_COMPLEX
, dd
, 0); /* Extension */
976 make_generic ("conjg", GFC_ISYM_CONJG
);
978 add_sym_1 ("cos", 1, 1, BT_REAL
, dr
,
979 NULL
, gfc_simplify_cos
, gfc_resolve_cos
, x
, BT_REAL
, dr
, 0);
981 add_sym_1 ("dcos", 1, 1, BT_REAL
, dd
,
982 NULL
, gfc_simplify_cos
, gfc_resolve_cos
, x
, BT_REAL
, dd
, 0);
984 add_sym_1 ("ccos", 1, 1, BT_COMPLEX
, dz
,
985 NULL
, gfc_simplify_cos
, gfc_resolve_cos
,
986 x
, BT_COMPLEX
, dz
, 0);
988 add_sym_1 ("zcos", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_cos
, gfc_resolve_cos
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
990 make_alias ("cdcos");
992 make_generic ("cos", GFC_ISYM_COS
);
994 add_sym_1 ("cosh", 1, 1, BT_REAL
, dr
,
995 NULL
, gfc_simplify_cosh
, gfc_resolve_cosh
,
998 add_sym_1 ("dcosh", 1, 1, BT_REAL
, dd
,
999 NULL
, gfc_simplify_cosh
, gfc_resolve_cosh
,
1002 make_generic ("cosh", GFC_ISYM_COSH
);
1004 add_sym_2 ("count", 0, 1, BT_INTEGER
, di
,
1005 gfc_check_count
, NULL
, gfc_resolve_count
,
1006 msk
, BT_LOGICAL
, dl
, 0, dm
, BT_INTEGER
, ii
, 1);
1008 make_generic ("count", GFC_ISYM_COUNT
);
1010 add_sym_3 ("cshift", 0, 1, BT_REAL
, dr
,
1011 gfc_check_cshift
, NULL
, gfc_resolve_cshift
,
1012 ar
, BT_REAL
, dr
, 0, sh
, BT_INTEGER
, di
, 0,
1013 dm
, BT_INTEGER
, ii
, 1);
1015 make_generic ("cshift", GFC_ISYM_CSHIFT
);
1017 add_sym_1 ("dble", 1, 1, BT_REAL
, dd
,
1018 gfc_check_dble
, gfc_simplify_dble
, gfc_resolve_dble
,
1021 make_generic ("dble", GFC_ISYM_DBLE
);
1023 add_sym_1 ("digits", 0, 1, BT_INTEGER
, di
,
1024 gfc_check_digits
, gfc_simplify_digits
, NULL
,
1025 x
, BT_UNKNOWN
, dr
, 0);
1027 make_generic ("digits", GFC_ISYM_NONE
);
1029 add_sym_2 ("dim", 1, 1, BT_REAL
, dr
,
1030 gfc_check_a_p
, gfc_simplify_dim
, gfc_resolve_dim
,
1031 x
, BT_UNKNOWN
, dr
, 0, y
, BT_UNKNOWN
, dr
, 0);
1033 add_sym_2 ("idim", 1, 1, BT_INTEGER
, di
,
1034 NULL
, gfc_simplify_dim
, gfc_resolve_dim
,
1035 x
, BT_INTEGER
, di
, 0, y
, BT_INTEGER
, di
, 0);
1037 add_sym_2 ("ddim", 1, 1, BT_REAL
, dd
,
1038 NULL
, gfc_simplify_dim
, gfc_resolve_dim
,
1039 x
, BT_REAL
, dd
, 0, y
, BT_REAL
, dd
, 0);
1041 make_generic ("dim", GFC_ISYM_DIM
);
1043 add_sym_2 ("dot_product", 0, 1, BT_UNKNOWN
, 0,
1044 gfc_check_dot_product
, NULL
, gfc_resolve_dot_product
,
1045 va
, BT_REAL
, dr
, 0, vb
, BT_REAL
, dr
, 0);
1047 make_generic ("dot_product", GFC_ISYM_DOT_PRODUCT
);
1049 add_sym_2 ("dprod", 1, 1, BT_REAL
, dd
,
1050 NULL
, gfc_simplify_dprod
, gfc_resolve_dprod
,
1051 x
, BT_REAL
, dr
, 0, y
, BT_REAL
, dr
, 0);
1053 make_generic ("dprod", GFC_ISYM_DPROD
);
1055 add_sym_1 ("dreal", 1, 0, BT_REAL
, dd
, NULL
, NULL
, NULL
, a
, BT_COMPLEX
, dd
, 0); /* Extension */
1057 make_generic ("dreal", GFC_ISYM_REAL
);
1059 add_sym_4 ("eoshift", 0, 1, BT_REAL
, dr
,
1060 gfc_check_eoshift
, NULL
, gfc_resolve_eoshift
,
1061 ar
, BT_REAL
, dr
, 0, sh
, BT_INTEGER
, ii
, 0,
1062 bd
, BT_REAL
, dr
, 1, dm
, BT_INTEGER
, ii
, 1);
1064 make_generic ("eoshift", GFC_ISYM_EOSHIFT
);
1066 add_sym_1 ("epsilon", 0, 1, BT_REAL
, dr
,
1067 gfc_check_x
, gfc_simplify_epsilon
, NULL
,
1070 make_generic ("epsilon", GFC_ISYM_NONE
);
1072 /* G77 compatibility */
1073 add_sym_1 ("etime", 0, 1, BT_REAL
, 4,
1074 gfc_check_etime
, NULL
, NULL
,
1077 make_alias ("dtime");
1079 make_generic ("etime", GFC_ISYM_ETIME
);
1082 add_sym_1 ("exp", 1, 1, BT_REAL
, dr
,
1083 NULL
, gfc_simplify_exp
, gfc_resolve_exp
, x
, BT_REAL
, dr
, 0);
1085 add_sym_1 ("dexp", 1, 1, BT_REAL
, dd
,
1086 NULL
, gfc_simplify_exp
, gfc_resolve_exp
, x
, BT_REAL
, dd
, 0);
1088 add_sym_1 ("cexp", 1, 1, BT_COMPLEX
, dz
,
1089 NULL
, gfc_simplify_exp
, gfc_resolve_exp
,
1090 x
, BT_COMPLEX
, dz
, 0);
1092 add_sym_1 ("zexp", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_exp
, gfc_resolve_exp
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
1094 make_alias ("cdexp");
1096 make_generic ("exp", GFC_ISYM_EXP
);
1098 add_sym_1 ("exponent", 1, 1, BT_INTEGER
, di
,
1099 gfc_check_x
, gfc_simplify_exponent
, gfc_resolve_exponent
,
1102 make_generic ("exponent", GFC_ISYM_EXPONENT
);
1104 add_sym_2 ("floor", 1, 1, BT_INTEGER
, di
,
1105 gfc_check_a_ikind
, gfc_simplify_floor
, gfc_resolve_floor
,
1106 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
1108 make_generic ("floor", GFC_ISYM_FLOOR
);
1110 add_sym_1 ("fraction", 1, 1, BT_REAL
, dr
,
1111 gfc_check_x
, gfc_simplify_fraction
, gfc_resolve_fraction
,
1114 make_generic ("fraction", GFC_ISYM_FRACTION
);
1116 add_sym_1 ("huge", 0, 1, BT_REAL
, dr
,
1117 gfc_check_huge
, gfc_simplify_huge
, NULL
,
1118 x
, BT_UNKNOWN
, dr
, 0);
1120 make_generic ("huge", GFC_ISYM_NONE
);
1122 add_sym_1 ("iachar", 1, 1, BT_INTEGER
, di
,
1123 NULL
, gfc_simplify_iachar
, NULL
, c
, BT_CHARACTER
, dc
, 0);
1125 make_generic ("iachar", GFC_ISYM_IACHAR
);
1127 add_sym_2 ("iand", 1, 1, BT_INTEGER
, di
,
1128 gfc_check_iand
, gfc_simplify_iand
, gfc_resolve_iand
,
1129 i
, BT_INTEGER
, di
, 0, j
, BT_INTEGER
, di
, 0);
1131 make_generic ("iand", GFC_ISYM_IAND
);
1133 add_sym_0 ("iargc", 1, 1, BT_INTEGER
, di
, NULL
, NULL
, NULL
); /* Extension, takes no arguments */
1134 make_generic ("iargc", GFC_ISYM_IARGC
);
1136 add_sym_0 ("command_argument_count", 1, 1, BT_INTEGER
, di
, NULL
, NULL
, NULL
);
1137 make_generic ("command_argument_count", GFC_ISYM_COMMAND_ARGUMENT_COUNT
);
1139 add_sym_2 ("ibclr", 1, 1, BT_INTEGER
, di
,
1140 gfc_check_ibclr
, gfc_simplify_ibclr
, gfc_resolve_ibclr
,
1141 i
, BT_INTEGER
, di
, 0, pos
, BT_INTEGER
, di
, 0);
1143 make_generic ("ibclr", GFC_ISYM_IBCLR
);
1145 add_sym_3 ("ibits", 1, 1, BT_INTEGER
, di
,
1146 gfc_check_ibits
, gfc_simplify_ibits
, gfc_resolve_ibits
,
1147 i
, BT_INTEGER
, di
, 0, pos
, BT_INTEGER
, di
, 0,
1148 ln
, BT_INTEGER
, di
, 0);
1150 make_generic ("ibits", GFC_ISYM_IBITS
);
1152 add_sym_2 ("ibset", 1, 1, BT_INTEGER
, di
,
1153 gfc_check_ibset
, gfc_simplify_ibset
, gfc_resolve_ibset
,
1154 i
, BT_INTEGER
, di
, 0, pos
, BT_INTEGER
, di
, 0);
1156 make_generic ("ibset", GFC_ISYM_IBSET
);
1158 add_sym_1 ("ichar", 1, 0, BT_INTEGER
, di
,
1159 NULL
, gfc_simplify_ichar
, gfc_resolve_ichar
,
1160 c
, BT_CHARACTER
, dc
, 0);
1162 make_generic ("ichar", GFC_ISYM_ICHAR
);
1164 add_sym_2 ("ieor", 1, 1, BT_INTEGER
, di
,
1165 gfc_check_ieor
, gfc_simplify_ieor
, gfc_resolve_ieor
,
1166 i
, BT_INTEGER
, di
, 0, j
, BT_INTEGER
, di
, 0);
1168 make_generic ("ieor", GFC_ISYM_IEOR
);
1170 add_sym_3 ("index", 1, 1, BT_INTEGER
, di
,
1171 gfc_check_index
, gfc_simplify_index
, NULL
,
1172 stg
, BT_CHARACTER
, dc
, 0, ssg
, BT_CHARACTER
, dc
, 0,
1173 bck
, BT_LOGICAL
, dl
, 1);
1175 make_generic ("index", GFC_ISYM_INDEX
);
1177 add_sym_2 ("int", 1, 1, BT_INTEGER
, di
,
1178 gfc_check_int
, gfc_simplify_int
, gfc_resolve_int
,
1179 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
1181 add_sym_1 ("ifix", 1, 0, BT_INTEGER
, di
,
1182 NULL
, gfc_simplify_ifix
, NULL
, a
, BT_REAL
, dr
, 0);
1184 add_sym_1 ("idint", 1, 0, BT_INTEGER
, di
,
1185 NULL
, gfc_simplify_idint
, NULL
, a
, BT_REAL
, dd
, 0);
1187 make_generic ("int", GFC_ISYM_INT
);
1189 add_sym_2 ("ior", 1, 1, BT_INTEGER
, di
,
1190 gfc_check_ior
, gfc_simplify_ior
, gfc_resolve_ior
,
1191 i
, BT_INTEGER
, di
, 0, j
, BT_INTEGER
, di
, 0);
1193 make_generic ("ior", GFC_ISYM_IOR
);
1195 /* The following function is for G77 compatibility. */
1196 add_sym_1 ("irand", 0, 1, BT_INTEGER
, 4,
1197 gfc_check_irand
, NULL
, NULL
,
1198 i
, BT_INTEGER
, 4, 0);
1200 make_generic ("irand", GFC_ISYM_IRAND
);
1202 add_sym_2 ("ishft", 1, 1, BT_INTEGER
, di
,
1203 gfc_check_ishft
, gfc_simplify_ishft
, gfc_resolve_ishft
,
1204 i
, BT_INTEGER
, di
, 0, sh
, BT_INTEGER
, di
, 0);
1206 make_generic ("ishft", GFC_ISYM_ISHFT
);
1208 add_sym_3 ("ishftc", 1, 1, BT_INTEGER
, di
,
1209 gfc_check_ishftc
, gfc_simplify_ishftc
, gfc_resolve_ishftc
,
1210 i
, BT_INTEGER
, di
, 0, sh
, BT_INTEGER
, di
, 0,
1211 sz
, BT_INTEGER
, di
, 1);
1213 make_generic ("ishftc", GFC_ISYM_ISHFTC
);
1215 add_sym_1 ("kind", 0, 1, BT_INTEGER
, di
,
1216 gfc_check_kind
, gfc_simplify_kind
, NULL
, x
, BT_REAL
, dr
, 0);
1218 make_generic ("kind", GFC_ISYM_NONE
);
1220 add_sym_2 ("lbound", 0, 1, BT_INTEGER
, di
,
1221 gfc_check_lbound
, gfc_simplify_lbound
, gfc_resolve_lbound
,
1222 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, di
, 1);
1224 make_generic ("lbound", GFC_ISYM_LBOUND
);
1226 add_sym_1 ("len", 0, 1, BT_INTEGER
, di
,
1227 NULL
, gfc_simplify_len
, gfc_resolve_len
,
1228 stg
, BT_CHARACTER
, dc
, 0);
1230 make_generic ("len", GFC_ISYM_LEN
);
1232 add_sym_1 ("len_trim", 1, 1, BT_INTEGER
, di
,
1233 NULL
, gfc_simplify_len_trim
, gfc_resolve_len_trim
,
1234 stg
, BT_CHARACTER
, dc
, 0);
1236 make_generic ("len_trim", GFC_ISYM_LEN_TRIM
);
1238 add_sym_2 ("lge", 1, 0, BT_LOGICAL
, dl
,
1239 NULL
, gfc_simplify_lge
, NULL
,
1240 sta
, BT_CHARACTER
, dc
, 0, stb
, BT_CHARACTER
, dc
, 0);
1242 make_generic ("lge", GFC_ISYM_LGE
);
1244 add_sym_2 ("lgt", 1, 0, BT_LOGICAL
, dl
,
1245 NULL
, gfc_simplify_lgt
, NULL
,
1246 sta
, BT_CHARACTER
, dc
, 0, stb
, BT_CHARACTER
, dc
, 0);
1248 make_generic ("lgt", GFC_ISYM_LGT
);
1250 add_sym_2 ("lle", 1, 0, BT_LOGICAL
, dl
,
1251 NULL
, gfc_simplify_lle
, NULL
,
1252 sta
, BT_CHARACTER
, dc
, 0, stb
, BT_CHARACTER
, dc
, 0);
1254 make_generic ("lle", GFC_ISYM_LLE
);
1256 add_sym_2 ("llt", 1, 0, BT_LOGICAL
, dl
,
1257 NULL
, gfc_simplify_llt
, NULL
,
1258 sta
, BT_CHARACTER
, dc
, 0, stb
, BT_CHARACTER
, dc
, 0);
1260 make_generic ("llt", GFC_ISYM_LLT
);
1262 add_sym_1 ("log", 1, 1, BT_REAL
, dr
,
1263 NULL
, gfc_simplify_log
, gfc_resolve_log
, x
, BT_REAL
, dr
, 0);
1265 add_sym_1 ("alog", 1, 1, BT_REAL
, dr
,
1266 NULL
, gfc_simplify_log
, gfc_resolve_log
, x
, BT_REAL
, dr
, 0);
1268 add_sym_1 ("dlog", 1, 1, BT_REAL
, dd
,
1269 NULL
, gfc_simplify_log
, gfc_resolve_log
, x
, BT_REAL
, dd
, 0);
1271 add_sym_1 ("clog", 1, 1, BT_COMPLEX
, dz
,
1272 NULL
, gfc_simplify_log
, gfc_resolve_log
,
1273 x
, BT_COMPLEX
, dz
, 0);
1275 add_sym_1 ("zlog", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_log
, gfc_resolve_log
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
1277 make_alias ("cdlog");
1279 make_generic ("log", GFC_ISYM_LOG
);
1281 add_sym_1 ("log10", 1, 1, BT_REAL
, dr
,
1282 NULL
, gfc_simplify_log10
, gfc_resolve_log10
,
1285 add_sym_1 ("alog10", 1, 1, BT_REAL
, dr
,
1286 NULL
, gfc_simplify_log10
, gfc_resolve_log10
,
1289 add_sym_1 ("dlog10", 1, 1, BT_REAL
, dd
,
1290 NULL
, gfc_simplify_log10
, gfc_resolve_log10
,
1293 make_generic ("log10", GFC_ISYM_LOG10
);
1295 add_sym_2 ("logical", 0, 1, BT_LOGICAL
, dl
,
1296 gfc_check_logical
, gfc_simplify_logical
, gfc_resolve_logical
,
1297 l
, BT_LOGICAL
, dl
, 0, kind
, BT_INTEGER
, di
, 1);
1299 make_generic ("logical", GFC_ISYM_LOGICAL
);
1301 add_sym_2 ("matmul", 0, 1, BT_REAL
, dr
,
1302 gfc_check_matmul
, NULL
, gfc_resolve_matmul
,
1303 ma
, BT_REAL
, dr
, 0, mb
, BT_REAL
, dr
, 0);
1305 make_generic ("matmul", GFC_ISYM_MATMUL
);
1307 /* Note: amax0 is equivalent to real(max), max1 is equivalent to
1308 int(max). The max function must take at least two arguments. */
1310 add_sym_1m ("max", 1, 0, BT_UNKNOWN
, 0,
1311 gfc_check_min_max
, gfc_simplify_max
, gfc_resolve_max
,
1312 a1
, BT_UNKNOWN
, dr
, 0, a2
, BT_UNKNOWN
, dr
, 0);
1314 add_sym_1m ("max0", 1, 0, BT_INTEGER
, di
,
1315 gfc_check_min_max_integer
, gfc_simplify_max
, NULL
,
1316 a1
, BT_INTEGER
, di
, 0, a2
, BT_INTEGER
, di
, 0);
1318 add_sym_1m ("amax0", 1, 0, BT_REAL
, dr
,
1319 gfc_check_min_max_integer
, gfc_simplify_max
, NULL
,
1320 a1
, BT_INTEGER
, di
, 0, a2
, BT_INTEGER
, di
, 0);
1322 add_sym_1m ("amax1", 1, 0, BT_REAL
, dr
,
1323 gfc_check_min_max_real
, gfc_simplify_max
, NULL
,
1324 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1326 add_sym_1m ("max1", 1, 0, BT_INTEGER
, di
,
1327 gfc_check_min_max_real
, gfc_simplify_max
, NULL
,
1328 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1330 add_sym_1m ("dmax1", 1, 0, BT_REAL
, dd
,
1331 gfc_check_min_max_double
, gfc_simplify_max
, NULL
,
1332 a1
, BT_REAL
, dd
, 0, a2
, BT_REAL
, dd
, 0);
1334 make_generic ("max", GFC_ISYM_MAX
);
1336 add_sym_1 ("maxexponent", 0, 1, BT_INTEGER
, di
,
1337 gfc_check_x
, gfc_simplify_maxexponent
, NULL
,
1338 x
, BT_UNKNOWN
, dr
, 0);
1340 make_generic ("maxexponent", GFC_ISYM_NONE
);
1342 add_sym_3ml ("maxloc", 0, 1, BT_INTEGER
, di
,
1343 gfc_check_minloc_maxloc
, NULL
, gfc_resolve_maxloc
,
1344 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1345 msk
, BT_LOGICAL
, dl
, 1);
1347 make_generic ("maxloc", GFC_ISYM_MAXLOC
);
1349 add_sym_3 ("maxval", 0, 1, BT_REAL
, dr
,
1350 gfc_check_minval_maxval
, NULL
, gfc_resolve_maxval
,
1351 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1352 msk
, BT_LOGICAL
, dl
, 1);
1354 make_generic ("maxval", GFC_ISYM_MAXVAL
);
1356 add_sym_3 ("merge", 1, 1, BT_REAL
, dr
,
1357 gfc_check_merge
, NULL
, gfc_resolve_merge
,
1358 ts
, BT_REAL
, dr
, 0, fs
, BT_REAL
, dr
, 0,
1359 msk
, BT_LOGICAL
, dl
, 0);
1361 make_generic ("merge", GFC_ISYM_MERGE
);
1363 /* Note: amin0 is equivalent to real(min), min1 is equivalent to int(min). */
1365 add_sym_1m ("min", 1, 0, BT_UNKNOWN
, 0,
1366 gfc_check_min_max
, gfc_simplify_min
, gfc_resolve_min
,
1367 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1369 add_sym_1m ("min0", 1, 0, BT_INTEGER
, di
,
1370 gfc_check_min_max_integer
, gfc_simplify_min
, NULL
,
1371 a1
, BT_INTEGER
, di
, 0, a2
, BT_INTEGER
, di
, 0);
1373 add_sym_1m ("amin0", 1, 0, BT_REAL
, dr
,
1374 gfc_check_min_max_integer
, gfc_simplify_min
, NULL
,
1375 a1
, BT_INTEGER
, di
, 0, a2
, BT_INTEGER
, di
, 0);
1377 add_sym_1m ("amin1", 1, 0, BT_REAL
, dr
,
1378 gfc_check_min_max_real
, gfc_simplify_min
, NULL
,
1379 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1381 add_sym_1m ("min1", 1, 0, BT_INTEGER
, di
,
1382 gfc_check_min_max_real
, gfc_simplify_min
, NULL
,
1383 a1
, BT_REAL
, dr
, 0, a2
, BT_REAL
, dr
, 0);
1385 add_sym_1m ("dmin1", 1, 0, BT_REAL
, dd
,
1386 gfc_check_min_max_double
, gfc_simplify_min
, NULL
,
1387 a1
, BT_REAL
, dd
, 0, a2
, BT_REAL
, dd
, 0);
1389 make_generic ("min", GFC_ISYM_MIN
);
1391 add_sym_1 ("minexponent", 0, 1, BT_INTEGER
, di
,
1392 gfc_check_x
, gfc_simplify_minexponent
, NULL
,
1393 x
, BT_UNKNOWN
, dr
, 0);
1395 make_generic ("minexponent", GFC_ISYM_NONE
);
1397 add_sym_3ml ("minloc", 0, 1, BT_INTEGER
, di
,
1398 gfc_check_minloc_maxloc
, NULL
, gfc_resolve_minloc
,
1399 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1400 msk
, BT_LOGICAL
, dl
, 1);
1402 make_generic ("minloc", GFC_ISYM_MINLOC
);
1404 add_sym_3 ("minval", 0, 1, BT_REAL
, dr
,
1405 gfc_check_minval_maxval
, NULL
, gfc_resolve_minval
,
1406 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1407 msk
, BT_LOGICAL
, dl
, 1);
1409 make_generic ("minval", GFC_ISYM_MINVAL
);
1411 add_sym_2 ("mod", 1, 1, BT_INTEGER
, di
,
1412 gfc_check_a_p
, gfc_simplify_mod
, gfc_resolve_mod
,
1413 a
, BT_INTEGER
, di
, 0, p
, BT_INTEGER
, di
, 0);
1415 add_sym_2 ("amod", 1, 1, BT_REAL
, dr
,
1416 NULL
, gfc_simplify_mod
, gfc_resolve_mod
,
1417 a
, BT_REAL
, dr
, 0, p
, BT_REAL
, dr
, 0);
1419 add_sym_2 ("dmod", 1, 1, BT_REAL
, dd
,
1420 NULL
, gfc_simplify_mod
, gfc_resolve_mod
,
1421 a
, BT_REAL
, dd
, 0, p
, BT_REAL
, dd
, 0);
1423 make_generic ("mod", GFC_ISYM_MOD
);
1425 add_sym_2 ("modulo", 1, 1, BT_REAL
, di
,
1426 gfc_check_a_p
, gfc_simplify_modulo
, gfc_resolve_modulo
,
1427 a
, BT_REAL
, di
, 0, p
, BT_REAL
, di
, 0);
1429 make_generic ("modulo", GFC_ISYM_MODULO
);
1431 add_sym_2 ("nearest", 1, 1, BT_REAL
, dr
,
1432 gfc_check_nearest
, gfc_simplify_nearest
, gfc_resolve_nearest
,
1433 x
, BT_REAL
, dr
, 0, s
, BT_REAL
, dr
, 0);
1435 make_generic ("nearest", GFC_ISYM_NEAREST
);
1437 add_sym_2 ("nint", 1, 1, BT_INTEGER
, di
,
1438 gfc_check_a_ikind
, gfc_simplify_nint
, gfc_resolve_nint
,
1439 a
, BT_REAL
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
1441 add_sym_1 ("idnint", 1, 1, BT_INTEGER
, di
,
1442 gfc_check_idnint
, gfc_simplify_idnint
, gfc_resolve_idnint
,
1445 make_generic ("nint", GFC_ISYM_NINT
);
1447 add_sym_1 ("not", 1, 1, BT_INTEGER
, di
,
1448 gfc_check_i
, gfc_simplify_not
, gfc_resolve_not
,
1449 i
, BT_INTEGER
, di
, 0);
1451 make_generic ("not", GFC_ISYM_NOT
);
1453 add_sym_1 ("null", 0, 1, BT_INTEGER
, di
,
1454 gfc_check_null
, gfc_simplify_null
, NULL
,
1455 mo
, BT_INTEGER
, di
, 1);
1457 make_generic ("null", GFC_ISYM_NONE
);
1459 add_sym_3 ("pack", 0, 1, BT_REAL
, dr
,
1460 gfc_check_pack
, NULL
, gfc_resolve_pack
,
1461 ar
, BT_REAL
, dr
, 0, msk
, BT_LOGICAL
, dl
, 0,
1464 make_generic ("pack", GFC_ISYM_PACK
);
1466 add_sym_1 ("precision", 0, 1, BT_INTEGER
, di
,
1467 gfc_check_precision
, gfc_simplify_precision
, NULL
,
1468 x
, BT_UNKNOWN
, 0, 0);
1470 make_generic ("precision", GFC_ISYM_NONE
);
1472 add_sym_1 ("present", 0, 1, BT_LOGICAL
, dl
,
1473 gfc_check_present
, NULL
, NULL
, a
, BT_REAL
, dr
, 0);
1475 make_generic ("present", GFC_ISYM_PRESENT
);
1477 add_sym_3 ("product", 0, 1, BT_REAL
, dr
,
1478 gfc_check_product
, NULL
, gfc_resolve_product
,
1479 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1480 msk
, BT_LOGICAL
, dl
, 1);
1482 make_generic ("product", GFC_ISYM_PRODUCT
);
1484 add_sym_1 ("radix", 0, 1, BT_INTEGER
, di
,
1485 gfc_check_radix
, gfc_simplify_radix
, NULL
,
1486 x
, BT_UNKNOWN
, 0, 0);
1488 make_generic ("radix", GFC_ISYM_NONE
);
1490 /* The following function is for G77 compatibility. */
1491 add_sym_1 ("rand", 0, 1, BT_REAL
, 4,
1492 gfc_check_rand
, NULL
, NULL
,
1493 i
, BT_INTEGER
, 4, 0);
1495 make_generic ("rand", GFC_ISYM_RAND
);
1497 add_sym_1 ("range", 0, 1, BT_INTEGER
, di
,
1498 gfc_check_range
, gfc_simplify_range
, NULL
,
1501 make_generic ("range", GFC_ISYM_NONE
);
1503 add_sym_2 ("real", 1, 0, BT_REAL
, dr
,
1504 gfc_check_real
, gfc_simplify_real
, gfc_resolve_real
,
1505 a
, BT_UNKNOWN
, dr
, 0, kind
, BT_INTEGER
, di
, 1);
1507 add_sym_1 ("float", 1, 0, BT_REAL
, dr
,
1508 NULL
, gfc_simplify_float
, NULL
, a
, BT_INTEGER
, di
, 0);
1510 add_sym_1 ("sngl", 1, 0, BT_REAL
, dr
,
1511 NULL
, gfc_simplify_sngl
, NULL
, a
, BT_REAL
, dd
, 0);
1513 make_generic ("real", GFC_ISYM_REAL
);
1515 add_sym_2 ("repeat", 0, 1, BT_CHARACTER
, dc
,
1516 gfc_check_repeat
, gfc_simplify_repeat
, gfc_resolve_repeat
,
1517 stg
, BT_CHARACTER
, dc
, 0, n
, BT_INTEGER
, di
, 0);
1519 make_generic ("repeat", GFC_ISYM_REPEAT
);
1521 add_sym_4 ("reshape", 0, 1, BT_REAL
, dr
,
1522 gfc_check_reshape
, gfc_simplify_reshape
, gfc_resolve_reshape
,
1523 src
, BT_REAL
, dr
, 0, shp
, BT_INTEGER
, ii
, 0,
1524 pad
, BT_REAL
, dr
, 1, ord
, BT_INTEGER
, ii
, 1);
1526 make_generic ("reshape", GFC_ISYM_RESHAPE
);
1528 add_sym_1 ("rrspacing", 1, 1, BT_REAL
, dr
,
1529 gfc_check_x
, gfc_simplify_rrspacing
, gfc_resolve_rrspacing
,
1532 make_generic ("rrspacing", GFC_ISYM_RRSPACING
);
1534 add_sym_2 ("scale", 1, 1, BT_REAL
, dr
,
1535 gfc_check_scale
, gfc_simplify_scale
, gfc_resolve_scale
,
1536 x
, BT_REAL
, dr
, 0, i
, BT_INTEGER
, di
, 0);
1538 make_generic ("scale", GFC_ISYM_SCALE
);
1540 add_sym_3 ("scan", 1, 1, BT_INTEGER
, di
,
1541 gfc_check_scan
, gfc_simplify_scan
, gfc_resolve_scan
,
1542 stg
, BT_CHARACTER
, dc
, 0, set
, BT_CHARACTER
, dc
, 0,
1543 bck
, BT_LOGICAL
, dl
, 1);
1545 make_generic ("scan", GFC_ISYM_SCAN
);
1547 /* Added for G77 compatibility garbage. */
1548 add_sym_0 ("second", 0, 1, BT_REAL
, 4, NULL
, NULL
, NULL
);
1550 make_generic ("second", GFC_ISYM_SECOND
);
1552 add_sym_1 ("selected_int_kind", 0, 1, BT_INTEGER
, di
,
1553 NULL
, gfc_simplify_selected_int_kind
, NULL
,
1554 r
, BT_INTEGER
, di
, 0);
1556 make_generic ("selected_int_kind", GFC_ISYM_SI_KIND
);
1558 add_sym_2 ("selected_real_kind", 0, 1, BT_INTEGER
, di
,
1559 gfc_check_selected_real_kind
, gfc_simplify_selected_real_kind
,
1560 NULL
, p
, BT_INTEGER
, di
, 1, r
, BT_INTEGER
, di
, 1);
1562 make_generic ("selected_real_kind", GFC_ISYM_SR_KIND
);
1564 add_sym_2 ("set_exponent", 1, 1, BT_REAL
, dr
,
1565 gfc_check_set_exponent
, gfc_simplify_set_exponent
,
1566 gfc_resolve_set_exponent
,
1567 x
, BT_REAL
, dr
, 0, i
, BT_INTEGER
, di
, 0);
1569 make_generic ("set_exponent", GFC_ISYM_SET_EXPONENT
);
1571 add_sym_1 ("shape", 0, 1, BT_INTEGER
, di
,
1572 gfc_check_shape
, gfc_simplify_shape
, gfc_resolve_shape
,
1573 src
, BT_REAL
, dr
, 0);
1575 make_generic ("shape", GFC_ISYM_SHAPE
);
1577 add_sym_2 ("sign", 1, 1, BT_REAL
, dr
,
1578 gfc_check_sign
, gfc_simplify_sign
, gfc_resolve_sign
,
1579 a
, BT_REAL
, dr
, 0, b
, BT_REAL
, dr
, 0);
1581 add_sym_2 ("isign", 1, 1, BT_INTEGER
, di
,
1582 NULL
, gfc_simplify_sign
, gfc_resolve_sign
,
1583 a
, BT_INTEGER
, di
, 0, b
, BT_INTEGER
, di
, 0);
1585 add_sym_2 ("dsign", 1, 1, BT_REAL
, dd
,
1586 NULL
, gfc_simplify_sign
, gfc_resolve_sign
,
1587 a
, BT_REAL
, dd
, 0, b
, BT_REAL
, dd
, 0);
1589 make_generic ("sign", GFC_ISYM_SIGN
);
1591 add_sym_1 ("sin", 1, 1, BT_REAL
, dr
,
1592 NULL
, gfc_simplify_sin
, gfc_resolve_sin
, x
, BT_REAL
, dr
, 0);
1594 add_sym_1 ("dsin", 1, 1, BT_REAL
, dd
,
1595 NULL
, gfc_simplify_sin
, gfc_resolve_sin
, x
, BT_REAL
, dd
, 0);
1597 add_sym_1 ("csin", 1, 1, BT_COMPLEX
, dz
,
1598 NULL
, gfc_simplify_sin
, gfc_resolve_sin
,
1599 x
, BT_COMPLEX
, dz
, 0);
1601 add_sym_1 ("zsin", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_sin
, gfc_resolve_sin
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
1603 make_alias ("cdsin");
1605 make_generic ("sin", GFC_ISYM_SIN
);
1607 add_sym_1 ("sinh", 1, 1, BT_REAL
, dr
,
1608 NULL
, gfc_simplify_sinh
, gfc_resolve_sinh
,
1611 add_sym_1 ("dsinh", 1, 1, BT_REAL
, dd
,
1612 NULL
, gfc_simplify_sinh
, gfc_resolve_sinh
,
1615 make_generic ("sinh", GFC_ISYM_SINH
);
1617 add_sym_2 ("size", 0, 1, BT_INTEGER
, di
,
1618 gfc_check_size
, gfc_simplify_size
, NULL
,
1619 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1);
1621 make_generic ("size", GFC_ISYM_SIZE
);
1623 add_sym_1 ("spacing", 1, 1, BT_REAL
, dr
,
1624 gfc_check_x
, gfc_simplify_spacing
, gfc_resolve_spacing
,
1627 make_generic ("spacing", GFC_ISYM_SPACING
);
1629 add_sym_3 ("spread", 0, 1, BT_REAL
, dr
,
1630 gfc_check_spread
, NULL
, gfc_resolve_spread
,
1631 src
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 0,
1632 n
, BT_INTEGER
, di
, 0);
1634 make_generic ("spread", GFC_ISYM_SPREAD
);
1636 add_sym_1 ("sqrt", 1, 1, BT_REAL
, dr
,
1637 NULL
, gfc_simplify_sqrt
, gfc_resolve_sqrt
,
1640 add_sym_1 ("dsqrt", 1, 1, BT_REAL
, dd
,
1641 NULL
, gfc_simplify_sqrt
, gfc_resolve_sqrt
,
1644 add_sym_1 ("csqrt", 1, 1, BT_COMPLEX
, dz
,
1645 NULL
, gfc_simplify_sqrt
, gfc_resolve_sqrt
,
1646 x
, BT_COMPLEX
, dz
, 0);
1648 add_sym_1 ("zsqrt", 1, 1, BT_COMPLEX
, dd
, NULL
, gfc_simplify_sqrt
, gfc_resolve_sqrt
, x
, BT_COMPLEX
, dd
, 0); /* Extension */
1650 make_alias ("cdsqrt");
1652 make_generic ("sqrt", GFC_ISYM_SQRT
);
1654 add_sym_3 ("sum", 0, 1, BT_UNKNOWN
, 0,
1655 gfc_check_sum
, NULL
, gfc_resolve_sum
,
1656 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1,
1657 msk
, BT_LOGICAL
, dl
, 1);
1659 make_generic ("sum", GFC_ISYM_SUM
);
1661 add_sym_1 ("tan", 1, 1, BT_REAL
, dr
,
1662 NULL
, gfc_simplify_tan
, gfc_resolve_tan
, x
, BT_REAL
, dr
, 0);
1664 add_sym_1 ("dtan", 1, 1, BT_REAL
, dd
,
1665 NULL
, gfc_simplify_tan
, gfc_resolve_tan
, x
, BT_REAL
, dd
, 0);
1667 make_generic ("tan", GFC_ISYM_TAN
);
1669 add_sym_1 ("tanh", 1, 1, BT_REAL
, dr
,
1670 NULL
, gfc_simplify_tanh
, gfc_resolve_tanh
,
1673 add_sym_1 ("dtanh", 1, 1, BT_REAL
, dd
,
1674 NULL
, gfc_simplify_tanh
, gfc_resolve_tanh
,
1677 make_generic ("tanh", GFC_ISYM_TANH
);
1679 add_sym_1 ("tiny", 0, 1, BT_REAL
, dr
,
1680 gfc_check_x
, gfc_simplify_tiny
, NULL
, x
, BT_REAL
, dr
, 0);
1682 make_generic ("tiny", GFC_ISYM_NONE
);
1684 add_sym_3 ("transfer", 0, 1, BT_REAL
, dr
,
1685 gfc_check_transfer
, NULL
, gfc_resolve_transfer
,
1686 src
, BT_REAL
, dr
, 0, mo
, BT_REAL
, dr
, 0,
1687 sz
, BT_INTEGER
, di
, 1);
1689 make_generic ("transfer", GFC_ISYM_TRANSFER
);
1691 add_sym_1 ("transpose", 0, 1, BT_REAL
, dr
,
1692 gfc_check_transpose
, NULL
, gfc_resolve_transpose
,
1695 make_generic ("transpose", GFC_ISYM_TRANSPOSE
);
1697 add_sym_1 ("trim", 0, 1, BT_CHARACTER
, dc
,
1698 gfc_check_trim
, gfc_simplify_trim
, gfc_resolve_trim
,
1699 stg
, BT_CHARACTER
, dc
, 0);
1701 make_generic ("trim", GFC_ISYM_TRIM
);
1703 add_sym_2 ("ubound", 0, 1, BT_INTEGER
, di
,
1704 gfc_check_ubound
, gfc_simplify_ubound
, gfc_resolve_ubound
,
1705 ar
, BT_REAL
, dr
, 0, dm
, BT_INTEGER
, ii
, 1);
1707 make_generic ("ubound", GFC_ISYM_UBOUND
);
1709 add_sym_3 ("unpack", 0, 1, BT_REAL
, dr
,
1710 gfc_check_unpack
, NULL
, gfc_resolve_unpack
,
1711 v
, BT_REAL
, dr
, 0, msk
, BT_LOGICAL
, dl
, 0,
1714 make_generic ("unpack", GFC_ISYM_UNPACK
);
1716 add_sym_3 ("verify", 1, 1, BT_INTEGER
, di
,
1717 gfc_check_verify
, gfc_simplify_verify
, gfc_resolve_verify
,
1718 stg
, BT_CHARACTER
, dc
, 0, set
, BT_CHARACTER
, dc
, 0,
1719 bck
, BT_LOGICAL
, dl
, 1);
1721 make_generic ("verify", GFC_ISYM_VERIFY
);
1728 /* Add intrinsic subroutines. */
1731 add_subroutines (void)
1733 /* Argument names as in the standard (to be used as argument keywords). */
1735 *h
= "harvest", *dt
= "date", *vl
= "values", *pt
= "put",
1736 *c
= "count", *tm
= "time", *tp
= "topos", *gt
= "get",
1737 *t
= "to", *zn
= "zone", *fp
= "frompos", *cm
= "count_max",
1738 *f
= "from", *sz
= "size", *ln
= "len", *cr
= "count_rate",
1739 *com
= "command", *length
= "length", *st
= "status",
1740 *val
= "value", *num
= "number";
1744 di
= gfc_default_integer_kind ();
1745 dr
= gfc_default_real_kind ();
1746 dc
= gfc_default_character_kind ();
1748 add_sym_0s ("abort", 1, NULL
);
1750 add_sym_1s ("cpu_time", 0, 1, BT_UNKNOWN
, 0,
1751 gfc_check_cpu_time
, NULL
, gfc_resolve_cpu_time
,
1752 tm
, BT_REAL
, dr
, 0);
1754 /* More G77 compatibility garbage. */
1755 add_sym_1s ("second", 0, 1, BT_UNKNOWN
, 0,
1756 gfc_check_second_sub
, NULL
, gfc_resolve_second_sub
,
1757 tm
, BT_REAL
, dr
, 0);
1759 add_sym_4s ("date_and_time", 0, 1, BT_UNKNOWN
, 0,
1760 gfc_check_date_and_time
, NULL
, NULL
,
1761 dt
, BT_CHARACTER
, dc
, 1, tm
, BT_CHARACTER
, dc
, 1,
1762 zn
, BT_CHARACTER
, dc
, 1, vl
, BT_INTEGER
, di
, 1);
1764 /* More G77 compatibility garbage. */
1765 add_sym_2s ("etime", 0, 1, BT_UNKNOWN
, 0,
1766 gfc_check_etime_sub
, NULL
, gfc_resolve_etime_sub
,
1767 vl
, BT_REAL
, 4, 0, tm
, BT_REAL
, 4, 0);
1769 add_sym_2s ("dtime", 0, 1, BT_UNKNOWN
, 0,
1770 gfc_check_etime_sub
, NULL
, gfc_resolve_etime_sub
,
1771 vl
, BT_REAL
, 4, 0, tm
, BT_REAL
, 4, 0);
1773 add_sym_2s ("getarg", 0, 1, BT_UNKNOWN
, 0,
1774 NULL
, NULL
, gfc_resolve_getarg
,
1775 c
, BT_INTEGER
, di
, 0, vl
, BT_CHARACTER
, dc
, 0);
1777 /* F2003 commandline routines. */
1779 add_sym_3s ("get_command", 0, 1, BT_UNKNOWN
, 0,
1780 NULL
, NULL
, gfc_resolve_get_command
,
1781 com
, BT_CHARACTER
, dc
, 1,
1782 length
, BT_INTEGER
, di
, 1,
1783 st
, BT_INTEGER
, di
, 1);
1785 add_sym_4s ("get_command_argument", 0, 1, BT_UNKNOWN
, 0,
1786 NULL
, NULL
, gfc_resolve_get_command_argument
,
1787 num
, BT_INTEGER
, di
, 0,
1788 val
, BT_CHARACTER
, dc
, 1,
1789 length
, BT_INTEGER
, di
, 1,
1790 st
, BT_INTEGER
, di
, 1);
1794 /* This needs changing to add_sym_5s if it gets a resolution function. */
1795 add_sym_5 ("mvbits", 1, 1, BT_UNKNOWN
, 0,
1796 gfc_check_mvbits
, gfc_simplify_mvbits
, NULL
,
1797 f
, BT_INTEGER
, di
, 0, fp
, BT_INTEGER
, di
, 0,
1798 ln
, BT_INTEGER
, di
, 0, t
, BT_INTEGER
, di
, 0,
1799 tp
, BT_INTEGER
, di
, 0);
1801 add_sym_1s ("random_number", 0, 1, BT_UNKNOWN
, 0,
1802 gfc_check_random_number
, NULL
, gfc_resolve_random_number
,
1805 add_sym_3s ("random_seed", 0, 1, BT_UNKNOWN
, 0,
1806 gfc_check_random_seed
, NULL
, NULL
,
1807 sz
, BT_INTEGER
, di
, 1, pt
, BT_INTEGER
, di
, 1,
1808 gt
, BT_INTEGER
, di
, 1);
1810 /* More G77 compatibility garbage. */
1811 add_sym_1s ("srand", 0, 1, BT_UNKNOWN
, di
,
1812 gfc_check_srand
, NULL
, gfc_resolve_srand
,
1813 c
, BT_INTEGER
, 4, 0);
1815 add_sym_3s ("system_clock", 0, 1, BT_UNKNOWN
, 0,
1816 gfc_check_system_clock
, NULL
, gfc_resolve_system_clock
,
1817 c
, BT_INTEGER
, di
, 1, cr
, BT_INTEGER
, di
, 1,
1818 cm
, BT_INTEGER
, di
, 1);
1822 /* Add a function to the list of conversion symbols. */
1825 add_conv (bt from_type
, int from_kind
, bt to_type
, int to_kind
,
1826 gfc_expr
* (*simplify
) (gfc_expr
*, bt
, int))
1829 gfc_typespec from
, to
;
1830 gfc_intrinsic_sym
*sym
;
1832 if (sizing
== SZ_CONVS
)
1838 gfc_clear_ts (&from
);
1839 from
.type
= from_type
;
1840 from
.kind
= from_kind
;
1846 sym
= conversion
+ nconv
;
1848 strcpy (sym
->name
, conv_name (&from
, &to
));
1849 strcpy (sym
->lib_name
, sym
->name
);
1850 sym
->simplify
.cc
= simplify
;
1853 sym
->generic_id
= GFC_ISYM_CONVERSION
;
1859 /* Create gfc_intrinsic_sym nodes for all intrinsic conversion
1860 functions by looping over the kind tables. */
1863 add_conversions (void)
1867 /* Integer-Integer conversions. */
1868 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
1869 for (j
= 0; gfc_integer_kinds
[j
].kind
!= 0; j
++)
1874 add_conv (BT_INTEGER
, gfc_integer_kinds
[i
].kind
,
1875 BT_INTEGER
, gfc_integer_kinds
[j
].kind
, gfc_convert_constant
);
1878 /* Integer-Real/Complex conversions. */
1879 for (i
= 0; gfc_integer_kinds
[i
].kind
!= 0; i
++)
1880 for (j
= 0; gfc_real_kinds
[j
].kind
!= 0; j
++)
1882 add_conv (BT_INTEGER
, gfc_integer_kinds
[i
].kind
,
1883 BT_REAL
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1885 add_conv (BT_REAL
, gfc_real_kinds
[j
].kind
,
1886 BT_INTEGER
, gfc_integer_kinds
[i
].kind
, gfc_convert_constant
);
1888 add_conv (BT_INTEGER
, gfc_integer_kinds
[i
].kind
,
1889 BT_COMPLEX
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1891 add_conv (BT_COMPLEX
, gfc_real_kinds
[j
].kind
,
1892 BT_INTEGER
, gfc_integer_kinds
[i
].kind
, gfc_convert_constant
);
1895 /* Real/Complex - Real/Complex conversions. */
1896 for (i
= 0; gfc_real_kinds
[i
].kind
!= 0; i
++)
1897 for (j
= 0; gfc_real_kinds
[j
].kind
!= 0; j
++)
1901 add_conv (BT_REAL
, gfc_real_kinds
[i
].kind
,
1902 BT_REAL
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1904 add_conv (BT_COMPLEX
, gfc_real_kinds
[i
].kind
,
1905 BT_COMPLEX
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1908 add_conv (BT_REAL
, gfc_real_kinds
[i
].kind
,
1909 BT_COMPLEX
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1911 add_conv (BT_COMPLEX
, gfc_real_kinds
[i
].kind
,
1912 BT_REAL
, gfc_real_kinds
[j
].kind
, gfc_convert_constant
);
1915 /* Logical/Logical kind conversion. */
1916 for (i
= 0; gfc_logical_kinds
[i
].kind
; i
++)
1917 for (j
= 0; gfc_logical_kinds
[j
].kind
; j
++)
1922 add_conv (BT_LOGICAL
, gfc_logical_kinds
[i
].kind
,
1923 BT_LOGICAL
, gfc_logical_kinds
[j
].kind
, gfc_convert_constant
);
1928 /* Initialize the table of intrinsics. */
1930 gfc_intrinsic_init_1 (void)
1934 nargs
= nfunc
= nsub
= nconv
= 0;
1936 /* Create a namespace to hold the resolved intrinsic symbols. */
1937 gfc_intrinsic_namespace
= gfc_get_namespace (NULL
);
1946 functions
= gfc_getmem (sizeof (gfc_intrinsic_sym
) * (nfunc
+ nsub
)
1947 + sizeof (gfc_intrinsic_arg
) * nargs
);
1949 next_sym
= functions
;
1950 subroutines
= functions
+ nfunc
;
1952 conversion
= gfc_getmem (sizeof (gfc_intrinsic_sym
) * nconv
);
1954 next_arg
= ((gfc_intrinsic_arg
*) (subroutines
+ nsub
)) - 1;
1956 sizing
= SZ_NOTHING
;
1963 /* Set the pure flag. All intrinsic functions are pure, and
1964 intrinsic subroutines are pure if they are elemental. */
1966 for (i
= 0; i
< nfunc
; i
++)
1967 functions
[i
].pure
= 1;
1969 for (i
= 0; i
< nsub
; i
++)
1970 subroutines
[i
].pure
= subroutines
[i
].elemental
;
1975 gfc_intrinsic_done_1 (void)
1977 gfc_free (functions
);
1978 gfc_free (conversion
);
1979 gfc_free_namespace (gfc_intrinsic_namespace
);
1983 /******** Subroutines to check intrinsic interfaces ***********/
1985 /* Given a formal argument list, remove any NULL arguments that may
1986 have been left behind by a sort against some formal argument list. */
1989 remove_nullargs (gfc_actual_arglist
** ap
)
1991 gfc_actual_arglist
*head
, *tail
, *next
;
1995 for (head
= *ap
; head
; head
= next
)
1999 if (head
->expr
== NULL
)
2002 gfc_free_actual_arglist (head
);
2021 /* Given an actual arglist and a formal arglist, sort the actual
2022 arglist so that its arguments are in a one-to-one correspondence
2023 with the format arglist. Arguments that are not present are given
2024 a blank gfc_actual_arglist structure. If something is obviously
2025 wrong (say, a missing required argument) we abort sorting and
2029 sort_actual (const char *name
, gfc_actual_arglist
** ap
,
2030 gfc_intrinsic_arg
* formal
, locus
* where
)
2033 gfc_actual_arglist
*actual
, *a
;
2034 gfc_intrinsic_arg
*f
;
2036 remove_nullargs (ap
);
2039 for (f
= formal
; f
; f
= f
->next
)
2045 if (f
== NULL
&& a
== NULL
) /* No arguments */
2049 { /* Put the nonkeyword arguments in a 1:1 correspondence */
2055 if (a
->name
[0] != '\0')
2067 gfc_error ("Too many arguments in call to '%s' at %L", name
, where
);
2071 /* Associate the remaining actual arguments, all of which have
2072 to be keyword arguments. */
2073 for (; a
; a
= a
->next
)
2075 for (f
= formal
; f
; f
= f
->next
)
2076 if (strcmp (a
->name
, f
->name
) == 0)
2081 gfc_error ("Can't find keyword named '%s' in call to '%s' at %L",
2082 a
->name
, name
, where
);
2086 if (f
->actual
!= NULL
)
2088 gfc_error ("Argument '%s' is appears twice in call to '%s' at %L",
2089 f
->name
, name
, where
);
2097 /* At this point, all unmatched formal args must be optional. */
2098 for (f
= formal
; f
; f
= f
->next
)
2100 if (f
->actual
== NULL
&& f
->optional
== 0)
2102 gfc_error ("Missing actual argument '%s' in call to '%s' at %L",
2103 f
->name
, name
, where
);
2109 /* Using the formal argument list, string the actual argument list
2110 together in a way that corresponds with the formal list. */
2113 for (f
= formal
; f
; f
= f
->next
)
2115 if (f
->actual
== NULL
)
2117 a
= gfc_get_actual_arglist ();
2118 a
->missing_arg_type
= f
->ts
.type
;
2130 actual
->next
= NULL
; /* End the sorted argument list. */
2136 /* Compare an actual argument list with an intrinsic's formal argument
2137 list. The lists are checked for agreement of type. We don't check
2138 for arrayness here. */
2141 check_arglist (gfc_actual_arglist
** ap
, gfc_intrinsic_sym
* sym
,
2144 gfc_actual_arglist
*actual
;
2145 gfc_intrinsic_arg
*formal
;
2148 formal
= sym
->formal
;
2152 for (; formal
; formal
= formal
->next
, actual
= actual
->next
, i
++)
2154 if (actual
->expr
== NULL
)
2157 if (!gfc_compare_types (&formal
->ts
, &actual
->expr
->ts
))
2161 ("Type of argument '%s' in call to '%s' at %L should be "
2162 "%s, not %s", gfc_current_intrinsic_arg
[i
],
2163 gfc_current_intrinsic
, &actual
->expr
->where
,
2164 gfc_typename (&formal
->ts
), gfc_typename (&actual
->expr
->ts
));
2173 /* Given a pointer to an intrinsic symbol and an expression node that
2174 represent the function call to that subroutine, figure out the type
2175 of the result. This may involve calling a resolution subroutine. */
2178 resolve_intrinsic (gfc_intrinsic_sym
* specific
, gfc_expr
* e
)
2180 gfc_expr
*a1
, *a2
, *a3
, *a4
, *a5
;
2181 gfc_actual_arglist
*arg
;
2183 if (specific
->resolve
.f1
== NULL
)
2185 if (e
->value
.function
.name
== NULL
)
2186 e
->value
.function
.name
= specific
->lib_name
;
2188 if (e
->ts
.type
== BT_UNKNOWN
)
2189 e
->ts
= specific
->ts
;
2193 arg
= e
->value
.function
.actual
;
2195 /* At present only the iargc extension intrinsic takes no arguments,
2196 and it doesn't need a resolution function, but this is here for
2200 (*specific
->resolve
.f0
) (e
);
2204 /* Special case hacks for MIN and MAX. */
2205 if (specific
->resolve
.f1m
== gfc_resolve_max
2206 || specific
->resolve
.f1m
== gfc_resolve_min
)
2208 (*specific
->resolve
.f1m
) (e
, arg
);
2217 (*specific
->resolve
.f1
) (e
, a1
);
2226 (*specific
->resolve
.f2
) (e
, a1
, a2
);
2235 (*specific
->resolve
.f3
) (e
, a1
, a2
, a3
);
2244 (*specific
->resolve
.f4
) (e
, a1
, a2
, a3
, a4
);
2253 (*specific
->resolve
.f5
) (e
, a1
, a2
, a3
, a4
, a5
);
2257 gfc_internal_error ("resolve_intrinsic(): Too many args for intrinsic");
2261 /* Given an intrinsic symbol node and an expression node, call the
2262 simplification function (if there is one), perhaps replacing the
2263 expression with something simpler. We return FAILURE on an error
2264 of the simplification, SUCCESS if the simplification worked, even
2265 if nothing has changed in the expression itself. */
2268 do_simplify (gfc_intrinsic_sym
* specific
, gfc_expr
* e
)
2270 gfc_expr
*result
, *a1
, *a2
, *a3
, *a4
, *a5
;
2271 gfc_actual_arglist
*arg
;
2273 /* Max and min require special handling due to the variable number
2275 if (specific
->simplify
.f1
== gfc_simplify_min
)
2277 result
= gfc_simplify_min (e
);
2281 if (specific
->simplify
.f1
== gfc_simplify_max
)
2283 result
= gfc_simplify_max (e
);
2287 if (specific
->simplify
.f1
== NULL
)
2293 arg
= e
->value
.function
.actual
;
2298 if (specific
->simplify
.cc
== gfc_convert_constant
)
2300 result
= gfc_convert_constant (a1
, specific
->ts
.type
, specific
->ts
.kind
);
2304 /* TODO: Warn if -pedantic and initialization expression and arg
2305 types not integer or character */
2308 result
= (*specific
->simplify
.f1
) (a1
);
2315 result
= (*specific
->simplify
.f2
) (a1
, a2
);
2322 result
= (*specific
->simplify
.f3
) (a1
, a2
, a3
);
2329 result
= (*specific
->simplify
.f4
) (a1
, a2
, a3
, a4
);
2336 result
= (*specific
->simplify
.f5
) (a1
, a2
, a3
, a4
, a5
);
2339 ("do_simplify(): Too many args for intrinsic");
2346 if (result
== &gfc_bad_expr
)
2350 resolve_intrinsic (specific
, e
); /* Must call at run-time */
2353 result
->where
= e
->where
;
2354 gfc_replace_expr (e
, result
);
2361 /* Initialize the gfc_current_intrinsic_arg[] array for the benefit of
2362 error messages. This subroutine returns FAILURE if a subroutine
2363 has more than MAX_INTRINSIC_ARGS, in which case the actual argument
2364 list cannot match any intrinsic. */
2367 init_arglist (gfc_intrinsic_sym
* isym
)
2369 gfc_intrinsic_arg
*formal
;
2372 gfc_current_intrinsic
= isym
->name
;
2375 for (formal
= isym
->formal
; formal
; formal
= formal
->next
)
2377 if (i
>= MAX_INTRINSIC_ARGS
)
2378 gfc_internal_error ("init_arglist(): too many arguments");
2379 gfc_current_intrinsic_arg
[i
++] = formal
->name
;
2384 /* Given a pointer to an intrinsic symbol and an expression consisting
2385 of a function call, see if the function call is consistent with the
2386 intrinsic's formal argument list. Return SUCCESS if the expression
2387 and intrinsic match, FAILURE otherwise. */
2390 check_specific (gfc_intrinsic_sym
* specific
, gfc_expr
* expr
, int error_flag
)
2392 gfc_actual_arglist
*arg
, **ap
;
2396 ap
= &expr
->value
.function
.actual
;
2398 init_arglist (specific
);
2400 /* Don't attempt to sort the argument list for min or max. */
2401 if (specific
->check
.f1m
== gfc_check_min_max
2402 || specific
->check
.f1m
== gfc_check_min_max_integer
2403 || specific
->check
.f1m
== gfc_check_min_max_real
2404 || specific
->check
.f1m
== gfc_check_min_max_double
)
2405 return (*specific
->check
.f1m
) (*ap
);
2407 if (sort_actual (specific
->name
, ap
, specific
->formal
,
2408 &expr
->where
) == FAILURE
)
2411 if (specific
->check
.f3ml
!= gfc_check_minloc_maxloc
)
2413 if (specific
->check
.f1
== NULL
)
2415 t
= check_arglist (ap
, specific
, error_flag
);
2417 expr
->ts
= specific
->ts
;
2420 t
= do_check (specific
, *ap
);
2423 /* This is special because we might have to reorder the argument
2425 t
= gfc_check_minloc_maxloc (*ap
);
2427 /* Check ranks for elemental intrinsics. */
2428 if (t
== SUCCESS
&& specific
->elemental
)
2431 for (arg
= expr
->value
.function
.actual
; arg
; arg
= arg
->next
)
2433 if (arg
->expr
== NULL
|| arg
->expr
->rank
== 0)
2437 r
= arg
->expr
->rank
;
2441 if (arg
->expr
->rank
!= r
)
2444 ("Ranks of arguments to elemental intrinsic '%s' differ "
2445 "at %L", specific
->name
, &arg
->expr
->where
);
2452 remove_nullargs (ap
);
2458 /* See if an intrinsic is one of the intrinsics we evaluate
2462 gfc_init_expr_extensions (gfc_intrinsic_sym
*isym
)
2464 /* FIXME: This should be moved into the intrinsic definitions. */
2465 static const char * const init_expr_extensions
[] = {
2466 "digits", "epsilon", "huge", "kind", "maxexponent", "minexponent",
2467 "precision", "present", "radix", "range", "selected_real_kind",
2473 for (i
= 0; init_expr_extensions
[i
]; i
++)
2474 if (strcmp (init_expr_extensions
[i
], isym
->name
) == 0)
2481 /* See if a function call corresponds to an intrinsic function call.
2484 MATCH_YES if the call corresponds to an intrinsic, simplification
2485 is done if possible.
2487 MATCH_NO if the call does not correspond to an intrinsic
2489 MATCH_ERROR if the call corresponds to an intrinsic but there was an
2490 error during the simplification process.
2492 The error_flag parameter enables an error reporting. */
2495 gfc_intrinsic_func_interface (gfc_expr
* expr
, int error_flag
)
2497 gfc_intrinsic_sym
*isym
, *specific
;
2498 gfc_actual_arglist
*actual
;
2502 if (expr
->value
.function
.isym
!= NULL
)
2503 return (do_simplify (expr
->value
.function
.isym
, expr
) == FAILURE
)
2504 ? MATCH_ERROR
: MATCH_YES
;
2506 gfc_suppress_error
= !error_flag
;
2509 for (actual
= expr
->value
.function
.actual
; actual
; actual
= actual
->next
)
2510 if (actual
->expr
!= NULL
)
2511 flag
|= (actual
->expr
->ts
.type
!= BT_INTEGER
2512 && actual
->expr
->ts
.type
!= BT_CHARACTER
);
2514 name
= expr
->symtree
->n
.sym
->name
;
2516 isym
= specific
= gfc_find_function (name
);
2519 gfc_suppress_error
= 0;
2523 gfc_current_intrinsic_where
= &expr
->where
;
2525 /* Bypass the generic list for min and max. */
2526 if (isym
->check
.f1m
== gfc_check_min_max
)
2528 init_arglist (isym
);
2530 if (gfc_check_min_max (expr
->value
.function
.actual
) == SUCCESS
)
2533 gfc_suppress_error
= 0;
2537 /* If the function is generic, check all of its specific
2538 incarnations. If the generic name is also a specific, we check
2539 that name last, so that any error message will correspond to the
2541 gfc_suppress_error
= 1;
2545 for (specific
= isym
->specific_head
; specific
;
2546 specific
= specific
->next
)
2548 if (specific
== isym
)
2550 if (check_specific (specific
, expr
, 0) == SUCCESS
)
2555 gfc_suppress_error
= !error_flag
;
2557 if (check_specific (isym
, expr
, error_flag
) == FAILURE
)
2559 gfc_suppress_error
= 0;
2566 expr
->value
.function
.isym
= specific
;
2567 gfc_intrinsic_symbol (expr
->symtree
->n
.sym
);
2569 if (do_simplify (specific
, expr
) == FAILURE
)
2571 gfc_suppress_error
= 0;
2575 /* TODO: We should probably only allow elemental functions here. */
2576 flag
|= (expr
->ts
.type
!= BT_INTEGER
&& expr
->ts
.type
!= BT_CHARACTER
);
2578 gfc_suppress_error
= 0;
2579 if (pedantic
&& gfc_init_expr
2580 && flag
&& gfc_init_expr_extensions (specific
))
2582 if (gfc_notify_std (GFC_STD_GNU
, "Extension: Evaluation of "
2583 "nonstandard initialization expression at %L", &expr
->where
)
2594 /* See if a CALL statement corresponds to an intrinsic subroutine.
2595 Returns MATCH_YES if the subroutine corresponds to an intrinsic,
2596 MATCH_NO if not, and MATCH_ERROR if there was an error (but did
2600 gfc_intrinsic_sub_interface (gfc_code
* c
, int error_flag
)
2602 gfc_intrinsic_sym
*isym
;
2605 name
= c
->symtree
->n
.sym
->name
;
2607 isym
= find_subroutine (name
);
2611 gfc_suppress_error
= !error_flag
;
2613 init_arglist (isym
);
2615 if (sort_actual (name
, &c
->ext
.actual
, isym
->formal
, &c
->loc
) == FAILURE
)
2618 if (isym
->check
.f1
!= NULL
)
2620 if (do_check (isym
, c
->ext
.actual
) == FAILURE
)
2625 if (check_arglist (&c
->ext
.actual
, isym
, 1) == FAILURE
)
2629 /* The subroutine corresponds to an intrinsic. Allow errors to be
2630 seen at this point. */
2631 gfc_suppress_error
= 0;
2633 if (isym
->resolve
.s1
!= NULL
)
2634 isym
->resolve
.s1 (c
);
2636 c
->resolved_sym
= gfc_get_intrinsic_sub_symbol (isym
->lib_name
);
2638 if (gfc_pure (NULL
) && !isym
->elemental
)
2640 gfc_error ("Subroutine call to intrinsic '%s' at %L is not PURE", name
,
2648 gfc_suppress_error
= 0;
2653 /* Call gfc_convert_type() with warning enabled. */
2656 gfc_convert_type (gfc_expr
* expr
, gfc_typespec
* ts
, int eflag
)
2658 return gfc_convert_type_warn (expr
, ts
, eflag
, 1);
2662 /* Try to convert an expression (in place) from one type to another.
2663 'eflag' controls the behavior on error.
2665 The possible values are:
2667 1 Generate a gfc_error()
2668 2 Generate a gfc_internal_error().
2670 'wflag' controls the warning related to conversion. */
2673 gfc_convert_type_warn (gfc_expr
* expr
, gfc_typespec
* ts
, int eflag
,
2676 gfc_intrinsic_sym
*sym
;
2677 gfc_typespec from_ts
;
2682 from_ts
= expr
->ts
; /* expr->ts gets clobbered */
2684 if (ts
->type
== BT_UNKNOWN
)
2687 /* NULL and zero size arrays get their type here. */
2688 if (expr
->expr_type
== EXPR_NULL
2689 || (expr
->expr_type
== EXPR_ARRAY
2690 && expr
->value
.constructor
== NULL
))
2692 /* Sometimes the RHS acquire the type. */
2697 if (expr
->ts
.type
== BT_UNKNOWN
)
2700 if (expr
->ts
.type
== BT_DERIVED
2701 && ts
->type
== BT_DERIVED
2702 && gfc_compare_types (&expr
->ts
, ts
))
2705 sym
= find_conv (&expr
->ts
, ts
);
2709 /* At this point, a conversion is necessary. A warning may be needed. */
2710 if (wflag
&& gfc_option
.warn_conversion
)
2711 gfc_warning_now ("Conversion from %s to %s at %L",
2712 gfc_typename (&from_ts
), gfc_typename (ts
), &expr
->where
);
2714 /* Insert a pre-resolved function call to the right function. */
2715 old_where
= expr
->where
;
2717 new = gfc_get_expr ();
2720 new = gfc_build_conversion (new);
2721 new->value
.function
.name
= sym
->lib_name
;
2722 new->value
.function
.isym
= sym
;
2723 new->where
= old_where
;
2731 if (gfc_is_constant_expr (expr
->value
.function
.actual
->expr
)
2732 && do_simplify (sym
, expr
) == FAILURE
)
2737 return FAILURE
; /* Error already generated in do_simplify() */
2745 gfc_error ("Can't convert %s to %s at %L",
2746 gfc_typename (&from_ts
), gfc_typename (ts
), &expr
->where
);
2750 gfc_internal_error ("Can't convert %s to %s at %L",
2751 gfc_typename (&from_ts
), gfc_typename (ts
),