OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/45197 ([F2008] Allow IMPURE elemental procedures) 

2010-08-15  Daniel Kraft  <d@domob.eu>

	PR fortran/45197
	* decl.c (gfc_match_prefix): Match IMPURE prefix and mark ELEMENTAL
	routines not IMPURE also as PURE.
	* intrinsic.c (enum klass): New class `CLASS_PURE' and renamed
	`NO_CLASS' in `CLASS_IMPURE'.
	(add_sym): Set symbol-attributes `pure' and `elemental' correctly.
	(add_sym_0s): Renamed `NO_CLASS' in `CLASS_IMPURE'.
	(add_functions): Ditto.
	(add_subroutines): Ditto and mark `MOVE_ALLOC' as CLASS_PURE.
	* resolve.c (gfc_pure): Do not treat ELEMENTAL as automatically PURE.
	(resolve_formal_arglist): Check that arguments to ELEMENTAL procedures
	are not ALLOCATABLE and have their INTENT specified.

2010-08-15  Daniel Kraft  <d@domob.eu>

	PR fortran/45197
	* gfortran.dg/elemental_args_check_3.f90: New test.
	* gfortran.dg/impure_1.f08: New test.
	* gfortran.dg/impure_2.f08: New test.
	* gfortran.dg/impure_3.f90: New test.
	* gfortran.dg/typebound_proc_6.f03: Changed expected error message.

From-SVN: r163261
This commit is contained in:
Daniel Kraft 2010-08-15 17:28:10 +02:00 committed by Daniel Kraft
parent 69f11a1360
commit e6c148988c
10 changed files with 414 additions and 197 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
gcc/fortran/ChangeLog
View File

@ -1,3 +1,18 @@
2010-08-15 Daniel Kraft <d@domob.eu>
PR fortran/45197
* decl.c (gfc_match_prefix): Match IMPURE prefix and mark ELEMENTAL
routines not IMPURE also as PURE.
* intrinsic.c (enum klass): New class `CLASS_PURE' and renamed
`NO_CLASS' in `CLASS_IMPURE'.
(add_sym): Set symbol-attributes `pure' and `elemental' correctly.
(add_sym_0s): Renamed `NO_CLASS' in `CLASS_IMPURE'.
(add_functions): Ditto.
(add_subroutines): Ditto and mark `MOVE_ALLOC' as CLASS_PURE.
* resolve.c (gfc_pure): Do not treat ELEMENTAL as automatically PURE.
(resolve_formal_arglist): Check that arguments to ELEMENTAL procedures
are not ALLOCATABLE and have their INTENT specified.
2010-08-13 Daniel Kraft <d@domob.eu>
* gfortran.h (array_type): New type `AS_IMPLIED_SHAPE'.

88
gcc/fortran/decl.c
View File

@ -4052,45 +4052,81 @@ match
gfc_match_prefix (gfc_typespec *ts)
{
bool seen_type;
bool seen_impure;
bool found_prefix;
gfc_clear_attr (&current_attr);
seen_type = 0;
seen_type = false;
seen_impure = false;
gcc_assert (!gfc_matching_prefix);
gfc_matching_prefix = true;
loop:
if (!seen_type && ts != NULL
&& gfc_match_decl_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == MATCH_YES)
do
{
found_prefix = false;
seen_type = 1;
goto loop;
if (!seen_type && ts != NULL
&& gfc_match_decl_type_spec (ts, 0) == MATCH_YES
&& gfc_match_space () == MATCH_YES)
{
seen_type = true;
found_prefix = true;
}
if (gfc_match ("elemental% ") == MATCH_YES)
{
if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
goto error;
found_prefix = true;
}
if (gfc_match ("pure% ") == MATCH_YES)
{
if (gfc_add_pure (&current_attr, NULL) == FAILURE)
goto error;
found_prefix = true;
}
if (gfc_match ("recursive% ") == MATCH_YES)
{
if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
goto error;
found_prefix = true;
}
/* IMPURE is a somewhat special case, as it needs not set an actual
attribute but rather only prevents ELEMENTAL routines from being
automatically PURE. */
if (gfc_match ("impure% ") == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2008,
"Fortran 2008: IMPURE procedure at %C")
== FAILURE)
goto error;
seen_impure = true;
found_prefix = true;
}
}
while (found_prefix);
/* IMPURE and PURE must not both appear, of course. */
if (seen_impure && current_attr.pure)
{
gfc_error ("PURE and IMPURE must not appear both at %C");
goto error;
}
if (gfc_match ("elemental% ") == MATCH_YES)
{
if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
goto error;
goto loop;
}
if (gfc_match ("pure% ") == MATCH_YES)
/* If IMPURE it not seen but the procedure is ELEMENTAL, mark it as PURE. */
if (!seen_impure && current_attr.elemental && !current_attr.pure)
{
if (gfc_add_pure (&current_attr, NULL) == FAILURE)
goto error;
goto loop;
}
if (gfc_match ("recursive% ") == MATCH_YES)
{
if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
goto error;
goto loop;
}
/* At this point, the next item is not a prefix. */

345
gcc/fortran/intrinsic.c
View File

@ -50,7 +50,8 @@ static enum
sizing;
enum klass
{ NO_CLASS = 0, CLASS_ELEMENTAL, CLASS_INQUIRY, CLASS_TRANSFORMATIONAL };
{ CLASS_IMPURE = 0, CLASS_PURE, CLASS_ELEMENTAL,
CLASS_INQUIRY, CLASS_TRANSFORMATIONAL };
#define ACTUAL_NO 0
#define ACTUAL_YES 1
@ -273,6 +274,10 @@ add_sym (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt type
strcat (buf, name);
next_sym->lib_name = gfc_get_string (buf);
/* There are no IMPURE ELEMENTAL intrinsics, thus the ELEMENTAL class
also implies PURE. Additionally, there's the PURE class itself. */
next_sym->pure = (cl == CLASS_ELEMENTAL || cl == CLASS_PURE);
next_sym->elemental = (cl == CLASS_ELEMENTAL);
next_sym->inquiry = (cl == CLASS_INQUIRY);
next_sym->transformational = (cl == CLASS_TRANSFORMATIONAL);
@ -362,7 +367,8 @@ add_sym_0 (const char *name, gfc_isym_id id, enum klass cl, int actual_ok, bt ty
0 arguments. */
static void
add_sym_0s (const char *name, gfc_isym_id id, int standard, void (*resolve) (gfc_code *))
add_sym_0s (const char *name, gfc_isym_id id, int standard,
void (*resolve) (gfc_code *))
{
gfc_check_f cf;
gfc_simplify_f sf;
@ -372,8 +378,8 @@ add_sym_0s (const char *name, gfc_isym_id id, int standard, void (*resolve) (gfc
sf.f1 = NULL;
rf.s1 = resolve;
add_sym (name, id, NO_CLASS, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf, rf,
(void *) 0);
add_sym (name, id, CLASS_IMPURE, ACTUAL_NO, BT_UNKNOWN, 0, standard, cf, sf,
rf, (void *) 0);
}
@ -1119,8 +1125,8 @@ add_functions (void)
/* The checking function for ACCESS is called gfc_check_access_func
because the name gfc_check_access is already used in module.c. */
add_sym_2 ("access", GFC_ISYM_ACCESS, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_access_func, NULL, gfc_resolve_access,
add_sym_2 ("access", GFC_ISYM_ACCESS, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_access_func, NULL, gfc_resolve_access,
nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
make_generic ("access", GFC_ISYM_ACCESS, GFC_STD_GNU);
@ -1373,14 +1379,14 @@ add_functions (void)
make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
add_sym_1 ("chdir", GFC_ISYM_CHDIR, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_1 ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_chdir, NULL, gfc_resolve_chdir,
nm, BT_CHARACTER, dc, REQUIRED);
make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
add_sym_2 ("chmod", GFC_ISYM_CHMOD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_chmod, NULL, gfc_resolve_chmod,
add_sym_2 ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_chmod, NULL, gfc_resolve_chmod,
nm, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED);
make_generic ("chmod", GFC_ISYM_CHMOD, GFC_STD_GNU);
@ -1468,9 +1474,9 @@ add_functions (void)
make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95);
add_sym_1 ("ctime", GFC_ISYM_CTIME, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
gfc_check_ctime, NULL, gfc_resolve_ctime,
tm, BT_INTEGER, di, REQUIRED);
add_sym_1 ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
0, GFC_STD_GNU, gfc_check_ctime, NULL, gfc_resolve_ctime,
tm, BT_INTEGER, di, REQUIRED);
make_generic ("ctime", GFC_ISYM_CTIME, GFC_STD_GNU);
@ -1560,14 +1566,14 @@ add_functions (void)
make_generic ("erfc_scaled", GFC_ISYM_ERFC_SCALED, GFC_STD_F2008);
/* G77 compatibility */
add_sym_1 ("dtime", GFC_ISYM_DTIME, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
gfc_check_dtime_etime, NULL, NULL,
add_sym_1 ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL,
x, BT_REAL, 4, REQUIRED);
make_generic ("dtime", GFC_ISYM_DTIME, GFC_STD_GNU);
add_sym_1 ("etime", GFC_ISYM_ETIME, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
gfc_check_dtime_etime, NULL, NULL,
add_sym_1 ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
4, GFC_STD_GNU, gfc_check_dtime_etime, NULL, NULL,
x, BT_REAL, 4, REQUIRED);
make_generic ("etime", GFC_ISYM_ETIME, GFC_STD_GNU);
@ -1604,8 +1610,8 @@ add_functions (void)
a, BT_UNKNOWN, 0, REQUIRED,
mo, BT_UNKNOWN, 0, REQUIRED);
add_sym_0 ("fdate", GFC_ISYM_FDATE, NO_CLASS, ACTUAL_NO, BT_CHARACTER, dc, GFC_STD_GNU,
NULL, NULL, gfc_resolve_fdate);
add_sym_0 ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
dc, GFC_STD_GNU, NULL, NULL, gfc_resolve_fdate);
make_generic ("fdate", GFC_ISYM_FDATE, GFC_STD_GNU);
@ -1616,8 +1622,8 @@ add_functions (void)
make_generic ("floor", GFC_ISYM_FLOOR, GFC_STD_F95);
/* G77 compatible fnum */
add_sym_1 ("fnum", GFC_ISYM_FNUM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_fnum, NULL, gfc_resolve_fnum,
add_sym_1 ("fnum", GFC_ISYM_FNUM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_fnum, NULL, gfc_resolve_fnum,
ut, BT_INTEGER, di, REQUIRED);
make_generic ("fnum", GFC_ISYM_FNUM, GFC_STD_GNU);
@ -1628,38 +1634,38 @@ add_functions (void)
make_generic ("fraction", GFC_ISYM_FRACTION, GFC_STD_F95);
add_sym_2 ("fstat", GFC_ISYM_FSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_2 ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_fstat, NULL, gfc_resolve_fstat,
ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
add_sym_1 ("ftell", GFC_ISYM_FTELL, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii, GFC_STD_GNU,
gfc_check_ftell, NULL, gfc_resolve_ftell,
add_sym_1 ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
ii, GFC_STD_GNU, gfc_check_ftell, NULL, gfc_resolve_ftell,
ut, BT_INTEGER, di, REQUIRED);
make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU);
add_sym_2 ("fgetc", GFC_ISYM_FGETC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
add_sym_2 ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU);
add_sym_1 ("fget", GFC_ISYM_FGET, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_fgetput, NULL, gfc_resolve_fget,
add_sym_1 ("fget", GFC_ISYM_FGET, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fget,
c, BT_CHARACTER, dc, REQUIRED);
make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU);
add_sym_2 ("fputc", GFC_ISYM_FPUTC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_fgetputc, NULL, gfc_resolve_fputc,
add_sym_2 ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_fgetputc, NULL, gfc_resolve_fputc,
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU);
add_sym_1 ("fput", GFC_ISYM_FPUT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_fgetput, NULL, gfc_resolve_fput,
add_sym_1 ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_fgetput, NULL, gfc_resolve_fput,
c, BT_CHARACTER, dc, REQUIRED);
make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
@ -1675,29 +1681,29 @@ add_functions (void)
make_generic ("gamma", GFC_ISYM_TGAMMA, GFC_STD_F2008);
/* Unix IDs (g77 compatibility) */
add_sym_1 ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, gfc_resolve_getcwd,
add_sym_1 ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getcwd,
c, BT_CHARACTER, dc, REQUIRED);
make_generic ("getcwd", GFC_ISYM_GETCWD, GFC_STD_GNU);
add_sym_0 ("getgid", GFC_ISYM_GETGID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, gfc_resolve_getgid);
add_sym_0 ("getgid", GFC_ISYM_GETGID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getgid);
make_generic ("getgid", GFC_ISYM_GETGID, GFC_STD_GNU);
add_sym_0 ("getpid", GFC_ISYM_GETPID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, gfc_resolve_getpid);
add_sym_0 ("getpid", GFC_ISYM_GETPID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getpid);
make_generic ("getpid", GFC_ISYM_GETPID, GFC_STD_GNU);
add_sym_0 ("getuid", GFC_ISYM_GETUID, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, gfc_resolve_getuid);
add_sym_0 ("getuid", GFC_ISYM_GETUID, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_getuid);
make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
add_sym_1 ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_hostnm, NULL, gfc_resolve_hostnm,
add_sym_1 ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_hostnm, NULL, gfc_resolve_hostnm,
a, BT_CHARACTER, dc, REQUIRED);
make_generic ("hostnm", GFC_ISYM_HOSTNM, GFC_STD_GNU);
@ -1728,14 +1734,14 @@ add_functions (void)
make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
add_sym_2 ("and", GFC_ISYM_AND, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
gfc_check_and, gfc_simplify_and, gfc_resolve_and,
add_sym_2 ("and", GFC_ISYM_AND, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_and, gfc_resolve_and,
i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
add_sym_0 ("iargc", GFC_ISYM_IARGC, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, NULL);
add_sym_0 ("iargc", GFC_ISYM_IARGC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, NULL);
make_generic ("iargc", GFC_ISYM_IARGC, GFC_STD_GNU);
@ -1771,14 +1777,14 @@ add_functions (void)
make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
add_sym_2 ("xor", GFC_ISYM_XOR, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
add_sym_2 ("xor", GFC_ISYM_XOR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU);
add_sym_0 ("ierrno", GFC_ISYM_IERRNO, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, gfc_resolve_ierrno);
add_sym_0 ("ierrno", GFC_ISYM_IERRNO, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_ierrno);
make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
@ -1836,21 +1842,21 @@ add_functions (void)
make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
add_sym_2 ("or", GFC_ISYM_OR, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
gfc_check_and, gfc_simplify_or, gfc_resolve_or,
add_sym_2 ("or", GFC_ISYM_OR, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
dl, GFC_STD_GNU, gfc_check_and, gfc_simplify_or, gfc_resolve_or,
i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
/* The following function is for G77 compatibility. */
add_sym_1 ("irand", GFC_ISYM_IRAND, NO_CLASS, ACTUAL_NO, BT_INTEGER, 4, GFC_STD_GNU,
gfc_check_irand, NULL, NULL,
add_sym_1 ("irand", GFC_ISYM_IRAND, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
4, GFC_STD_GNU, gfc_check_irand, NULL, NULL,
i, BT_INTEGER, 4, OPTIONAL);
make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
add_sym_1 ("isatty", GFC_ISYM_ISATTY, NO_CLASS, ACTUAL_NO, BT_LOGICAL, dl, GFC_STD_GNU,
gfc_check_isatty, NULL, gfc_resolve_isatty,
add_sym_1 ("isatty", GFC_ISYM_ISATTY, CLASS_IMPURE, ACTUAL_NO, BT_LOGICAL,
dl, GFC_STD_GNU, gfc_check_isatty, NULL, gfc_resolve_isatty,
ut, BT_INTEGER, di, REQUIRED);
make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU);
@ -1901,8 +1907,8 @@ add_functions (void)
make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
add_sym_2 ("kill", GFC_ISYM_KILL, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_kill, NULL, gfc_resolve_kill,
add_sym_2 ("kill", GFC_ISYM_KILL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_kill, NULL, gfc_resolve_kill,
a, BT_INTEGER, di, REQUIRED, b, BT_INTEGER, di, REQUIRED);
make_generic ("kill", GFC_ISYM_KILL, GFC_STD_GNU);
@ -1994,7 +2000,7 @@ add_functions (void)
make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
add_sym_2 ("link", GFC_ISYM_LINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_2 ("link", GFC_ISYM_LINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_link, NULL, gfc_resolve_link,
p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
@ -2044,13 +2050,13 @@ add_functions (void)
make_generic ("logical", GFC_ISYM_LOGICAL, GFC_STD_F95);
add_sym_2 ("lstat", GFC_ISYM_LSTAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_2 ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_stat, NULL, gfc_resolve_lstat,
nm, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
make_generic ("lstat", GFC_ISYM_LSTAT, GFC_STD_GNU);
add_sym_1 ("malloc", GFC_ISYM_MALLOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
add_sym_1 ("malloc", GFC_ISYM_MALLOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
GFC_STD_GNU, gfc_check_malloc, NULL, gfc_resolve_malloc,
sz, BT_INTEGER, di, REQUIRED);
@ -2111,13 +2117,13 @@ add_functions (void)
make_generic ("maxval", GFC_ISYM_MAXVAL, GFC_STD_F95);
add_sym_0 ("mclock", GFC_ISYM_MCLOCK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_0 ("mclock", GFC_ISYM_MCLOCK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock);
make_generic ("mclock", GFC_ISYM_MCLOCK, GFC_STD_GNU);
add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8);
add_sym_0 ("mclock8", GFC_ISYM_MCLOCK8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_mclock8);
make_generic ("mclock8", GFC_ISYM_MCLOCK8, GFC_STD_GNU);
@ -2267,8 +2273,8 @@ add_functions (void)
make_generic ("radix", GFC_ISYM_RADIX, GFC_STD_F95);
/* The following function is for G77 compatibility. */
add_sym_1 ("rand", GFC_ISYM_RAND, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
gfc_check_rand, NULL, NULL,
add_sym_1 ("rand", GFC_ISYM_RAND, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
4, GFC_STD_GNU, gfc_check_rand, NULL, NULL,
i, BT_INTEGER, 4, OPTIONAL);
/* Compatibility with HP FORTRAN 77/iX Reference. Note, rand() and ran()
@ -2306,7 +2312,7 @@ add_functions (void)
make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
add_sym_2 ("rename", GFC_ISYM_RENAME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_2 ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_rename, NULL, gfc_resolve_rename,
p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
@ -2352,14 +2358,14 @@ add_functions (void)
make_generic ("scan", GFC_ISYM_SCAN, GFC_STD_F95);
/* Added for G77 compatibility garbage. */
add_sym_0 ("second", GFC_ISYM_SECOND, NO_CLASS, ACTUAL_NO, BT_REAL, 4, GFC_STD_GNU,
NULL, NULL, NULL);
add_sym_0 ("second", GFC_ISYM_SECOND, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
4, GFC_STD_GNU, NULL, NULL, NULL);
make_generic ("second", GFC_ISYM_SECOND, GFC_STD_GNU);
/* Added for G77 compatibility. */
add_sym_1 ("secnds", GFC_ISYM_SECNDS, NO_CLASS, ACTUAL_NO, BT_REAL, dr, GFC_STD_GNU,
gfc_check_secnds, NULL, gfc_resolve_secnds,
add_sym_1 ("secnds", GFC_ISYM_SECNDS, CLASS_IMPURE, ACTUAL_NO, BT_REAL,
dr, GFC_STD_GNU, gfc_check_secnds, NULL, gfc_resolve_secnds,
x, BT_REAL, dr, REQUIRED);
make_generic ("secnds", GFC_ISYM_SECNDS, GFC_STD_GNU);
@ -2412,8 +2418,8 @@ add_functions (void)
make_generic ("sign", GFC_ISYM_SIGN, GFC_STD_F77);
add_sym_2 ("signal", GFC_ISYM_SIGNAL, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_signal, NULL, gfc_resolve_signal,
add_sym_2 ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_signal, NULL, gfc_resolve_signal,
num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED);
make_generic ("signal", GFC_ISYM_SIGNAL, GFC_STD_GNU);
@ -2456,7 +2462,7 @@ add_functions (void)
make_generic ("size", GFC_ISYM_SIZE, GFC_STD_F95);
add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
add_sym_1 ("sizeof", GFC_ISYM_SIZEOF, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
GFC_STD_GNU, gfc_check_sizeof, NULL, NULL,
x, BT_UNKNOWN, 0, REQUIRED);
@ -2499,7 +2505,7 @@ add_functions (void)
make_generic ("sqrt", GFC_ISYM_SQRT, GFC_STD_F77);
add_sym_2 ("stat", GFC_ISYM_STAT, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_2 ("stat", GFC_ISYM_STAT, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_stat, NULL, gfc_resolve_stat,
nm, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
@ -2518,13 +2524,13 @@ add_functions (void)
make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_2 ("symlnk", GFC_ISYM_SYMLNK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_symlnk, NULL, gfc_resolve_symlnk,
p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER, dc, REQUIRED);
make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
add_sym_1 ("system", GFC_ISYM_SYSTEM, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_1 ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, NULL, NULL, NULL,
com, BT_CHARACTER, dc, REQUIRED);
@ -2554,13 +2560,13 @@ add_functions (void)
gfc_check_this_image, gfc_simplify_this_image, gfc_resolve_this_image,
ca, BT_REAL, dr, OPTIONAL, dm, BT_INTEGER, ii, OPTIONAL);
add_sym_0 ("time", GFC_ISYM_TIME, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, gfc_resolve_time);
add_sym_0 ("time", GFC_ISYM_TIME, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time);
make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
add_sym_0 ("time8", GFC_ISYM_TIME8, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
NULL, NULL, gfc_resolve_time8);
add_sym_0 ("time8", GFC_ISYM_TIME8, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, NULL, NULL, gfc_resolve_time8);
make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
@ -2596,8 +2602,8 @@ add_functions (void)
make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, ACTUAL_NO, BT_CHARACTER, 0, GFC_STD_GNU,
gfc_check_ttynam, NULL, gfc_resolve_ttynam,
add_sym_1 ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, ACTUAL_NO, BT_CHARACTER,
0, GFC_STD_GNU, gfc_check_ttynam, NULL, gfc_resolve_ttynam,
ut, BT_INTEGER, di, REQUIRED);
make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
@ -2611,23 +2617,23 @@ add_functions (void)
make_generic ("ubound", GFC_ISYM_UBOUND, GFC_STD_F95);
add_sym_3 ("ucobound", GFC_ISYM_UCOBOUND, CLASS_INQUIRY, ACTUAL_NO,
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, OPTIONAL);
BT_INTEGER, di, GFC_STD_F2008,
gfc_check_ucobound, gfc_simplify_ucobound, gfc_resolve_ucobound,
ca, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL,
kind, BT_INTEGER, di, OPTIONAL);
make_generic ("ucobound", GFC_ISYM_UCOBOUND, GFC_STD_F2008);
/* g77 compatibility for UMASK. */
add_sym_1 ("umask", GFC_ISYM_UMASK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di,
add_sym_1 ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_GNU, gfc_check_umask, NULL, gfc_resolve_umask,
msk, BT_INTEGER, di, REQUIRED);
make_generic ("umask", GFC_ISYM_UMASK, GFC_STD_GNU);
/* g77 compatibility for UNLINK. */
add_sym_1 ("unlink", GFC_ISYM_UNLINK, NO_CLASS, ACTUAL_NO, BT_INTEGER, di, GFC_STD_GNU,
gfc_check_unlink, NULL, gfc_resolve_unlink,
add_sym_1 ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER,
di, GFC_STD_GNU, gfc_check_unlink, NULL, gfc_resolve_unlink,
"path", BT_CHARACTER, dc, REQUIRED);
make_generic ("unlink", GFC_ISYM_UNLINK, GFC_STD_GNU);
@ -2647,7 +2653,7 @@ add_functions (void)
make_generic ("verify", GFC_ISYM_VERIFY, GFC_STD_F95);
add_sym_1 ("loc", GFC_ISYM_LOC, NO_CLASS, ACTUAL_NO, BT_INTEGER, ii,
add_sym_1 ("loc", GFC_ISYM_LOC, CLASS_IMPURE, ACTUAL_NO, BT_INTEGER, ii,
GFC_STD_GNU, gfc_check_loc, NULL, gfc_resolve_loc,
x, BT_UNKNOWN, 0, REQUIRED);
@ -2685,96 +2691,97 @@ add_subroutines (void)
make_noreturn();
add_sym_1s_intent ("cpu_time", GFC_ISYM_CPU_TIME, NO_CLASS, BT_UNKNOWN, 0,
add_sym_1s_intent ("cpu_time", GFC_ISYM_CPU_TIME, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_F95, gfc_check_cpu_time, NULL,
gfc_resolve_cpu_time,
tm, BT_REAL, dr, REQUIRED, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_2s ("ctime", GFC_ISYM_CTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("ctime", GFC_ISYM_CTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ctime_sub, NULL, gfc_resolve_ctime_sub,
tm, BT_INTEGER, di, REQUIRED, res, BT_CHARACTER, dc, REQUIRED);
add_sym_1s ("idate", GFC_ISYM_IDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_1s ("idate", GFC_ISYM_IDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_itime_idate, NULL, gfc_resolve_idate,
vl, BT_INTEGER, 4, REQUIRED);
add_sym_1s ("itime", GFC_ISYM_ITIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_1s ("itime", GFC_ISYM_ITIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_itime_idate, NULL, gfc_resolve_itime,
vl, BT_INTEGER, 4, REQUIRED);
add_sym_2s ("ltime", GFC_ISYM_LTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("ltime", GFC_ISYM_LTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ltime_gmtime, NULL, gfc_resolve_ltime,
tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
add_sym_2s ("gmtime", GFC_ISYM_GMTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime,
add_sym_2s ("gmtime", GFC_ISYM_GMTIME, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_GNU, gfc_check_ltime_gmtime, NULL, gfc_resolve_gmtime,
tm, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED);
add_sym_1s ("second", GFC_ISYM_SECOND, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_second_sub, NULL, gfc_resolve_second_sub,
add_sym_1s ("second", GFC_ISYM_SECOND, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_GNU, gfc_check_second_sub, NULL, gfc_resolve_second_sub,
tm, BT_REAL, dr, REQUIRED);
add_sym_2s ("chdir", GFC_ISYM_CHDIR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("chdir", GFC_ISYM_CHDIR, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_chdir_sub, NULL, gfc_resolve_chdir_sub,
name, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("chmod", GFC_ISYM_CHMOD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_3s ("chmod", GFC_ISYM_CHMOD, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_chmod_sub, NULL, gfc_resolve_chmod_sub,
name, BT_CHARACTER, dc, REQUIRED, md, BT_CHARACTER, dc, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, NO_CLASS, BT_UNKNOWN, 0,
GFC_STD_F95, gfc_check_date_and_time, NULL, NULL,
add_sym_4s ("date_and_time", GFC_ISYM_DATE_AND_TIME, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_F95, gfc_check_date_and_time, NULL, NULL,
dt, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
tm, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
zn, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
vl, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_2s ("etime", GFC_ISYM_ETIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("etime", GFC_ISYM_ETIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_dtime_etime_sub, NULL, gfc_resolve_etime_sub,
vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
add_sym_2s ("dtime", GFC_ISYM_DTIME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("dtime", GFC_ISYM_DTIME, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_dtime_etime_sub, NULL, gfc_resolve_dtime_sub,
vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
add_sym_1s ("fdate", GFC_ISYM_FDATE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_1s ("fdate", GFC_ISYM_FDATE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fdate_sub, NULL, gfc_resolve_fdate_sub,
dt, BT_CHARACTER, dc, REQUIRED);
add_sym_1s ("gerror", GFC_ISYM_GERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_gerror, NULL, gfc_resolve_gerror, res, BT_CHARACTER,
dc, REQUIRED);
add_sym_1s ("gerror", GFC_ISYM_GERROR, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_GNU, gfc_check_gerror, NULL, gfc_resolve_gerror,
res, BT_CHARACTER, dc, REQUIRED);
add_sym_2s ("getcwd", GFC_ISYM_GETCWD, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
add_sym_2s ("getcwd", GFC_ISYM_GETCWD, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_GNU, gfc_check_getcwd_sub, NULL, gfc_resolve_getcwd_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("getenv", GFC_ISYM_GETENV, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, NULL,
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER, dc,
REQUIRED);
add_sym_2s ("getenv", GFC_ISYM_GETENV, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_GNU, NULL, NULL, NULL,
name, BT_CHARACTER, dc, REQUIRED,
val, BT_CHARACTER, dc, REQUIRED);
add_sym_2s ("getarg", GFC_ISYM_GETARG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_getarg, NULL, gfc_resolve_getarg,
add_sym_2s ("getarg", GFC_ISYM_GETARG, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_GNU, gfc_check_getarg, NULL, gfc_resolve_getarg,
pos, BT_INTEGER, di, REQUIRED, val, BT_CHARACTER, dc, REQUIRED);
add_sym_1s ("getlog", GFC_ISYM_GETLOG, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
dc, REQUIRED);
add_sym_1s ("getlog", GFC_ISYM_GETLOG, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_GNU, gfc_check_getlog, NULL, gfc_resolve_getlog,
c, BT_CHARACTER, dc, REQUIRED);
/* F2003 commandline routines. */
add_sym_3s_intent ("get_command", GFC_ISYM_GET_COMMAND, NO_CLASS, BT_UNKNOWN,
0, GFC_STD_F2003, NULL, NULL, gfc_resolve_get_command,
add_sym_3s_intent ("get_command", GFC_ISYM_GET_COMMAND, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_command,
com, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
length, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT, NO_CLASS,
BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL,
add_sym_4s ("get_command_argument", GFC_ISYM_GET_COMMAND_ARGUMENT,
CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003, NULL, NULL,
gfc_resolve_get_command_argument,
num, BT_INTEGER, di, REQUIRED, INTENT_IN,
val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
@ -2784,7 +2791,7 @@ add_subroutines (void)
/* F2003 subroutine to get environment variables. */
add_sym_5s ("get_environment_variable", GFC_ISYM_GET_ENVIRONMENT_VARIABLE,
NO_CLASS, BT_UNKNOWN, 0, GFC_STD_F2003,
CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_F2003,
NULL, NULL, gfc_resolve_get_environment_variable,
name, BT_CHARACTER, dc, REQUIRED, INTENT_IN,
val, BT_CHARACTER, dc, OPTIONAL, INTENT_OUT,
@ -2792,8 +2799,9 @@ add_subroutines (void)
st, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
trim_name, BT_LOGICAL, dl, OPTIONAL, INTENT_IN);
add_sym_2s_intent ("move_alloc", GFC_ISYM_MOVE_ALLOC, NO_CLASS, BT_UNKNOWN, 0,
GFC_STD_F2003, gfc_check_move_alloc, NULL, NULL,
add_sym_2s_intent ("move_alloc", GFC_ISYM_MOVE_ALLOC, CLASS_PURE,
BT_UNKNOWN, 0, GFC_STD_F2003,
gfc_check_move_alloc, NULL, NULL,
f, BT_UNKNOWN, 0, REQUIRED, INTENT_INOUT,
t, BT_UNKNOWN, 0, REQUIRED, INTENT_OUT);
@ -2806,12 +2814,12 @@ add_subroutines (void)
t, BT_INTEGER, di, REQUIRED, INTENT_INOUT,
tp, BT_INTEGER, di, REQUIRED, INTENT_IN);
add_sym_1s_intent ("random_number", GFC_ISYM_RANDOM_NUMBER, NO_CLASS,
add_sym_1s_intent ("random_number", GFC_ISYM_RANDOM_NUMBER, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F95, gfc_check_random_number, NULL,
gfc_resolve_random_number,
h, BT_REAL, dr, REQUIRED, INTENT_OUT);
add_sym_3s_intent ("random_seed", GFC_ISYM_RANDOM_SEED, NO_CLASS,
add_sym_3s_intent ("random_seed", GFC_ISYM_RANDOM_SEED, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_random_seed, NULL, gfc_resolve_random_seed,
sz, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
@ -2819,130 +2827,131 @@ add_subroutines (void)
gt, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
/* More G77 compatibility garbage. */
add_sym_3s ("alarm", GFC_ISYM_ALARM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_3s ("alarm", GFC_ISYM_ALARM, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_alarm_sub, NULL, gfc_resolve_alarm_sub,
sec, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("srand", GFC_ISYM_SRAND, NO_CLASS, BT_UNKNOWN, di, GFC_STD_GNU,
gfc_check_srand, NULL, gfc_resolve_srand,
add_sym_1s ("srand", GFC_ISYM_SRAND, CLASS_IMPURE, BT_UNKNOWN,
di, GFC_STD_GNU, gfc_check_srand, NULL, gfc_resolve_srand,
"seed", BT_INTEGER, 4, REQUIRED);
add_sym_1s ("exit", GFC_ISYM_EXIT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_1s ("exit", GFC_ISYM_EXIT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_exit, NULL, gfc_resolve_exit,
st, BT_INTEGER, di, OPTIONAL);
make_noreturn();
add_sym_3s ("fgetc", GFC_ISYM_FGETC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_3s ("fgetc", GFC_ISYM_FGETC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("fget", GFC_ISYM_FGET, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("fget", GFC_ISYM_FGET, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("flush", GFC_ISYM_FLUSH, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_1s ("flush", GFC_ISYM_FLUSH, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_flush, NULL, gfc_resolve_flush,
ut, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("fputc", GFC_ISYM_FPUTC, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_3s ("fputc", GFC_ISYM_FPUTC, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("fput", GFC_ISYM_FPUT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("fput", GFC_ISYM_FPUT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("free", GFC_ISYM_FREE, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_1s ("free", GFC_ISYM_FREE, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_free, NULL, gfc_resolve_free,
ptr, BT_INTEGER, ii, REQUIRED);
add_sym_4s ("fseek", GFC_ISYM_FSEEK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
add_sym_4s ("fseek", GFC_ISYM_FSEEK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fseek_sub, NULL, gfc_resolve_fseek_sub,
ut, BT_INTEGER, di, REQUIRED, INTENT_IN,
of, BT_INTEGER, di, REQUIRED, INTENT_IN,
whence, BT_INTEGER, di, REQUIRED, INTENT_IN,
whence, BT_INTEGER, di, REQUIRED, INTENT_IN,
st, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_2s ("ftell", GFC_ISYM_FTELL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("ftell", GFC_ISYM_FTELL, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
add_sym_2s ("hostnm", GFC_ISYM_HOSTNM, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_GNU, gfc_check_hostnm_sub, NULL, gfc_resolve_hostnm_sub,
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("kill", GFC_ISYM_KILL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_kill_sub,
add_sym_3s ("kill", GFC_ISYM_KILL, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_GNU, gfc_check_kill_sub,
NULL, gfc_resolve_kill_sub, c, BT_INTEGER, di, REQUIRED,
val, BT_INTEGER, di, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("link", GFC_ISYM_LINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_3s ("link", GFC_ISYM_LINK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_link_sub, NULL, gfc_resolve_link_sub,
p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("perror", GFC_ISYM_PERROR, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_perror, NULL, gfc_resolve_perror,
add_sym_1s ("perror", GFC_ISYM_PERROR, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_GNU, gfc_check_perror, NULL, gfc_resolve_perror,
"string", BT_CHARACTER, dc, REQUIRED);
add_sym_3s ("rename", GFC_ISYM_RENAME, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
add_sym_3s ("rename", GFC_ISYM_RENAME, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_GNU, gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_1s ("sleep", GFC_ISYM_SLEEP, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_1s ("sleep", GFC_ISYM_SLEEP, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
sec, BT_INTEGER, di, REQUIRED);
add_sym_3s ("fstat", GFC_ISYM_FSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_3s ("fstat", GFC_ISYM_FSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_fstat_sub, NULL, gfc_resolve_fstat_sub,
ut, BT_INTEGER, di, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("lstat", GFC_ISYM_LSTAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_3s ("lstat", GFC_ISYM_LSTAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_stat_sub, NULL, gfc_resolve_lstat_sub,
name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("stat", GFC_ISYM_STAT, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_3s ("stat", GFC_ISYM_STAT, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_stat_sub, NULL, gfc_resolve_stat_sub,
name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("signal", GFC_ISYM_SIGNAL, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
add_sym_3s ("signal", GFC_ISYM_SIGNAL, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_GNU, gfc_check_signal_sub, NULL, gfc_resolve_signal_sub,
num, BT_INTEGER, di, REQUIRED, han, BT_UNKNOWN, 0, REQUIRED,
st, BT_INTEGER, di, OPTIONAL);
add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
add_sym_3s ("symlnk", GFC_ISYM_SYMLINK, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_GNU, gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
p1, BT_CHARACTER, dc, REQUIRED, p2, BT_CHARACTER,
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("system", GFC_ISYM_SYSTEM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
NULL, NULL, gfc_resolve_system_sub,
add_sym_2s ("system", GFC_ISYM_SYSTEM, CLASS_IMPURE, BT_UNKNOWN,
0, GFC_STD_GNU, NULL, NULL, gfc_resolve_system_sub,
com, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
add_sym_3s_intent ("system_clock", GFC_ISYM_SYSTEM_CLOCK, NO_CLASS,
add_sym_3s_intent ("system_clock", GFC_ISYM_SYSTEM_CLOCK, CLASS_IMPURE,
BT_UNKNOWN, 0, GFC_STD_F95,
gfc_check_system_clock, NULL, gfc_resolve_system_clock,
c, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
cr, BT_INTEGER, di, OPTIONAL, INTENT_OUT,
cm, BT_INTEGER, di, OPTIONAL, INTENT_OUT);
add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
add_sym_2s ("ttynam", GFC_ISYM_TTYNAM, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_GNU, gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
ut, BT_INTEGER, di, REQUIRED, name, BT_CHARACTER, dc, REQUIRED);
add_sym_2s ("umask", GFC_ISYM_UMASK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
add_sym_2s ("umask", GFC_ISYM_UMASK, CLASS_IMPURE, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
msk, BT_INTEGER, di, REQUIRED, old, BT_INTEGER, di, OPTIONAL);
add_sym_2s ("unlink", GFC_ISYM_UNLINK, NO_CLASS, BT_UNKNOWN, 0, GFC_STD_GNU,
gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
add_sym_2s ("unlink", GFC_ISYM_UNLINK, CLASS_IMPURE, BT_UNKNOWN, 0,
GFC_STD_GNU, gfc_check_unlink_sub, NULL, gfc_resolve_unlink_sub,
"path", BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
}

20
gcc/fortran/resolve.c
View File

@ -278,6 +278,14 @@ resolve_formal_arglist (gfc_symbol *proc)
continue;
}
if (sym->attr.allocatable)
{
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
"have the ALLOCATABLE attribute", sym->name,
&sym->declared_at);
continue;
}
if (sym->attr.pointer)
{
gfc_error ("Argument '%s' of elemental procedure at %L cannot "
@ -293,6 +301,14 @@ resolve_formal_arglist (gfc_symbol *proc)
&sym->declared_at);
continue;
}
if (sym->attr.intent == INTENT_UNKNOWN)
{
gfc_error ("Argument '%s' of elemental procedure '%s' at %L must "
"have its INTENT specified", sym->name, proc->name,
&sym->declared_at);
continue;
}
}
/* Each dummy shall be specified to be scalar. */
@ -12474,7 +12490,7 @@ gfc_pure (gfc_symbol *sym)
if (sym == NULL)
return 0;
attr = sym->attr;
if (attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental))
if (attr.flavor == FL_PROCEDURE && attr.pure)
return 1;
}
return 0;
@ -12482,7 +12498,7 @@ gfc_pure (gfc_symbol *sym)
attr = sym->attr;
return attr.flavor == FL_PROCEDURE && (attr.pure || attr.elemental);
return attr.flavor == FL_PROCEDURE && attr.pure;
}

9
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,12 @@
2010-08-15 Daniel Kraft <d@domob.eu>
PR fortran/45197
* gfortran.dg/elemental_args_check_3.f90: New test.
* gfortran.dg/impure_1.f08: New test.
* gfortran.dg/impure_2.f08: New test.
* gfortran.dg/impure_3.f90: New test.
* gfortran.dg/typebound_proc_6.f03: Changed expected error message.
2010-08-15 Ira Rosen <irar@il.ibm.com>
* gcc.dg/vect/costmodel/ppc/costmodel-bb-slp-9a.c: New test.

23
gcc/testsuite/gfortran.dg/elemental_args_check_3.f90 Normal file
View File

@ -0,0 +1,23 @@
! { dg-do compile }
! Check for constraints restricting arguments of ELEMENTAL procedures.
! Contributed by Daniel Kraft, d@domob.eu.
PROGRAM main
IMPLICIT NONE
CONTAINS
IMPURE ELEMENTAL SUBROUTINE foobar &
(a, & ! { dg-error "must be scalar" }
b, & ! { dg-error "POINTER attribute" }
c, & ! { dg-error "ALLOCATABLE attribute" }
d) ! { dg-error "INTENT specified" }
INTEGER, INTENT(IN) :: a(:)
INTEGER, POINTER, INTENT(IN) :: b
INTEGER, ALLOCATABLE, INTENT(IN) :: c
INTEGER :: d
END SUBROUTINE foobar
END PROGRAM main

71
gcc/testsuite/gfortran.dg/impure_1.f08 Normal file
View File

@ -0,0 +1,71 @@
! { dg-do run }
! { dg-options "-std=f2008 -fall-intrinsics" }
! PR fortran/45197
! Check that IMPURE and IMPURE ELEMENTAL in particular works.
! Contributed by Daniel Kraft, d@domob.eu.
MODULE m
IMPLICIT NONE
INTEGER, PARAMETER :: n = 5
INTEGER :: i
INTEGER :: arr(n)
CONTAINS
! This ought to work (without any effect).
IMPURE SUBROUTINE foobar ()
END SUBROUTINE foobar
IMPURE ELEMENTAL SUBROUTINE impureSub (a)
INTEGER, INTENT(IN) :: a
arr(i) = a
i = i + 1
PRINT *, a
END SUBROUTINE impureSub
END MODULE m
PROGRAM main
USE :: m
IMPLICIT NONE
INTEGER :: a(n), b(n), s
a = (/ (i, i = 1, n) /)
! Traverse in forward order.
s = 0
b = accumulate (a, s)
IF (ANY (b /= (/ 1, 3, 6, 10, 15 /))) CALL abort ()
! And now backward.
s = 0
b = accumulate (a(n:1:-1), s)
IF (ANY (b /= (/ 5, 9, 12, 14, 15 /))) CALL abort ()
! Use subroutine.
i = 1
arr = 0
CALL impureSub (a)
IF (ANY (arr /= a)) CALL abort ()
CONTAINS
IMPURE ELEMENTAL FUNCTION accumulate (a, s)
INTEGER, INTENT(IN) :: a
INTEGER, INTENT(INOUT) :: s
INTEGER :: accumulate
s = s + a
accumulate = s
END FUNCTION accumulate
END PROGRAM main
! { dg-final { cleanup-modules "m" } }

27
gcc/testsuite/gfortran.dg/impure_2.f08 Normal file
View File

@ -0,0 +1,27 @@
! { dg-do compile }
! { dg-options "-std=f2008" }
! PR fortran/45197
! Check for errors with IMPURE.
! Contributed by Daniel Kraft, d@domob.eu.
MODULE m
IMPLICIT NONE
CONTAINS
IMPURE PURE SUBROUTINE foobar () ! { dg-error "must not appear both" }
PURE ELEMENTAL IMPURE FUNCTION xyz () ! { dg-error "must not appear both" }
IMPURE ELEMENTAL SUBROUTINE mysub ()
END SUBROUTINE mysub
PURE SUBROUTINE purified ()
CALL mysub () ! { dg-error "is not PURE" }
END SUBROUTINE purified
END MODULE m
! { dg-final { cleanup-modules "m" } }

11
gcc/testsuite/gfortran.dg/impure_3.f90 Normal file
View File

@ -0,0 +1,11 @@
! { dg-do compile }
! { dg-options "-std=f95" }
! PR fortran/45197
! Check that IMPURE gets rejected without F2008.
! Contributed by Daniel Kraft, d@domob.eu.
IMPURE SUBROUTINE foobar () ! { dg-error "Fortran 2008" }
IMPURE ELEMENTAL FUNCTION xyz () ! { dg-error "Fortran 2008" }

2
gcc/testsuite/gfortran.dg/typebound_proc_6.f03
View File

@ -59,7 +59,7 @@ MODULE testmod
PROCEDURE, NOPASS :: pure2 => proc_sub ! { dg-error "must also be PURE" }
PROCEDURE, NOPASS :: nonpure => proc_pure ! Ok, overridden not pure.
PROCEDURE, NOPASS :: elemental1 => proc_elemental ! Ok, both elemental.
PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be ELEMENTAL" }
PROCEDURE, NOPASS :: elemental2 => proc_nonelem ! { dg-error "must also be" }
PROCEDURE, NOPASS :: nonelem1 => proc_nonelem ! Ok, non elemental.
PROCEDURE, NOPASS :: nonelem2 => proc_elemental ! { dg-error "must not be ELEMENTAL" }