Makefile.am: Added new files.
* Makefile.am: Added new files.
* Makefile.in: Regenerate.
* aclocal.m4: Regenerate.
* configure.ac: add checks for signal.h headers file, as well as
following functions: chdir, strerror, getlogin, gethostname, kill,
link, symlink, perror, sleep, time.
* configure: Regenerate.
* intrinsics/chdir.c, intrinsics/gerror.c, intrinsics/getlog.c,
intrinsics/hostnm.c, intrinsics/ierrno.c, intrinsics/kill.c,
intrinsics/link.c, intrinsics/perror.c, intrinsics/rename.c,
intrinsics/sleep.c, intrinsics/symlnk.c, intrinsics/time.c: Newly
implementend g77 intrinsics.
* check.c (gfc_check_chdir, gfc_check_chdir_sub, gfc_check_kill,
gfc_check_kill_sub, gfc_check_link, gfc_check_link_sub,
gfc_check_symlnk, gfc_check_symlnk_sub, gfc_check_rename,
gfc_check_rename_sub, gfc_check_sleep_sub, gfc_check_gerror,
gfc_check_getlog, gfc_check_hostnm, gfc_check_hostnm_sub,
gfc_check_perror): new functions to check newly implemented
g77 intrinsics.
* gfortran.h: adding symbols for new intrinsics.
* intrinsic.c (add_functions): adding new intrinsics.
(add_subroutines): adding new intrinsics.
* intrinsic.h: prototype for all checking and resolving
functions.
* iresolve.c (gfc_resolve_chdir, gfc_resolve_chdir_sub,
gfc_resolve_hostnm, gfc_resolve_ierrno, gfc_resolve_kill,
gfc_resolve_link, gfc_resolve_rename, gfc_resolve_symlnk,
gfc_resolve_time, gfc_resolve_time8, gfc_resolve_rename_sub,
gfc_resolve_kill_sub, gfc_resolve_link_sub,
gfc_resolve_symlnk_sub, gfc_resolve_sleep_sub,
gfc_resolve_gerror, gfc_resolve_getlog, gfc_resolve_hostnm_sub,
gfc_resolve_perror): new functions to resolve intrinsics.
* trans-intrinsic.c (gfc_conv_intrinsic_function): add case
for new symbols.
* g77_intrinsics_funcs.f: New test.
* g77_intrinsics_sub.f: New test.
From-SVN: r96893
This commit is contained in:
François-Xavier Coudert
parent
e5c4f28a6c
commit
f77b6ca3da
28 changed files with 2318 additions and 519 deletions
|
|
@ -1,3 +1,28 @@
|
|||
2005-03-22 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* check.c (gfc_check_chdir, gfc_check_chdir_sub, gfc_check_kill,
|
||||
gfc_check_kill_sub, gfc_check_link, gfc_check_link_sub,
|
||||
gfc_check_symlnk, gfc_check_symlnk_sub, gfc_check_rename,
|
||||
gfc_check_rename_sub, gfc_check_sleep_sub, gfc_check_gerror,
|
||||
gfc_check_getlog, gfc_check_hostnm, gfc_check_hostnm_sub,
|
||||
gfc_check_perror): new functions to check newly implemented
|
||||
g77 intrinsics.
|
||||
* gfortran.h: adding symbols for new intrinsics.
|
||||
* intrinsic.c (add_functions): adding new intrinsics.
|
||||
(add_subroutines): adding new intrinsics.
|
||||
* intrinsic.h: prototype for all checking and resolving
|
||||
functions.
|
||||
* iresolve.c (gfc_resolve_chdir, gfc_resolve_chdir_sub,
|
||||
gfc_resolve_hostnm, gfc_resolve_ierrno, gfc_resolve_kill,
|
||||
gfc_resolve_link, gfc_resolve_rename, gfc_resolve_symlnk,
|
||||
gfc_resolve_time, gfc_resolve_time8, gfc_resolve_rename_sub,
|
||||
gfc_resolve_kill_sub, gfc_resolve_link_sub,
|
||||
gfc_resolve_symlnk_sub, gfc_resolve_sleep_sub,
|
||||
gfc_resolve_gerror, gfc_resolve_getlog, gfc_resolve_hostnm_sub,
|
||||
gfc_resolve_perror): new functions to resolve intrinsics.
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_function): add case
|
||||
for new symbols.
|
||||
|
||||
2005-03-19 Tobias Schl"uter <tobias.schlueter@physik.uni-muenchen.de>
|
||||
|
||||
* dump-parse-tree.c (gfc_show_expr): Dump name of namespace
|
||||
|
|
|
|||
|
|
@ -574,6 +574,35 @@ gfc_check_char (gfc_expr * i, gfc_expr * kind)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_chdir (gfc_expr * dir)
|
||||
{
|
||||
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_chdir_sub (gfc_expr * dir, gfc_expr * status)
|
||||
{
|
||||
if (type_check (dir, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (status == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (status, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
|
||||
{
|
||||
|
|
@ -1007,6 +1036,41 @@ gfc_check_ishftc (gfc_expr * i, gfc_expr * shift, gfc_expr * size)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_kill (gfc_expr * pid, gfc_expr * sig)
|
||||
{
|
||||
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_kill_sub (gfc_expr * pid, gfc_expr * sig, gfc_expr * status)
|
||||
{
|
||||
if (type_check (pid, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (sig, 1, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (status == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (status, 2) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_kind (gfc_expr * x)
|
||||
{
|
||||
|
|
@ -1038,6 +1102,76 @@ gfc_check_lbound (gfc_expr * array, gfc_expr * dim)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_link (gfc_expr * path1, gfc_expr * path2)
|
||||
{
|
||||
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_link_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
|
||||
{
|
||||
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (status == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (status, 2) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_symlnk (gfc_expr * path1, gfc_expr * path2)
|
||||
{
|
||||
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_symlnk_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
|
||||
{
|
||||
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (status == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (status, 2) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_logical (gfc_expr * a, gfc_expr * kind)
|
||||
{
|
||||
|
|
@ -1453,6 +1587,41 @@ gfc_check_real (gfc_expr * a, gfc_expr * kind)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_rename (gfc_expr * path1, gfc_expr * path2)
|
||||
{
|
||||
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_rename_sub (gfc_expr * path1, gfc_expr * path2, gfc_expr * status)
|
||||
{
|
||||
if (type_check (path1, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (path2, 1, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (status == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (type_check (status, 2, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (status, 2) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_repeat (gfc_expr * x, gfc_expr * y)
|
||||
{
|
||||
|
|
@ -1657,6 +1826,19 @@ gfc_check_size (gfc_expr * array, gfc_expr * dim)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_sleep_sub (gfc_expr * seconds)
|
||||
{
|
||||
if (type_check (seconds, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (seconds, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
|
||||
{
|
||||
|
|
@ -2233,6 +2415,16 @@ gfc_check_etime_sub (gfc_expr * values, gfc_expr * time)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_gerror (gfc_expr * msg)
|
||||
{
|
||||
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
|
||||
{
|
||||
|
|
@ -2252,6 +2444,16 @@ gfc_check_getcwd_sub (gfc_expr * cwd, gfc_expr * status)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_getlog (gfc_expr * msg)
|
||||
{
|
||||
if (type_check (msg, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_exit (gfc_expr * status)
|
||||
{
|
||||
|
|
@ -2284,6 +2486,45 @@ gfc_check_flush (gfc_expr * unit)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_hostnm (gfc_expr * name)
|
||||
{
|
||||
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
|
||||
{
|
||||
if (type_check (name, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (status == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (scalar_check (status, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (status, 1, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_perror (gfc_expr * string)
|
||||
{
|
||||
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_umask (gfc_expr * mask)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -292,6 +292,7 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_BTEST,
|
||||
GFC_ISYM_CEILING,
|
||||
GFC_ISYM_CHAR,
|
||||
GFC_ISYM_CHDIR,
|
||||
GFC_ISYM_CMPLX,
|
||||
GFC_ISYM_COMMAND_ARGUMENT_COUNT,
|
||||
GFC_ISYM_CONJG,
|
||||
|
|
@ -317,6 +318,7 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_GETGID,
|
||||
GFC_ISYM_GETPID,
|
||||
GFC_ISYM_GETUID,
|
||||
GFC_ISYM_HOSTNM,
|
||||
GFC_ISYM_IACHAR,
|
||||
GFC_ISYM_IAND,
|
||||
GFC_ISYM_IARGC,
|
||||
|
|
@ -325,15 +327,18 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_IBSET,
|
||||
GFC_ISYM_ICHAR,
|
||||
GFC_ISYM_IEOR,
|
||||
GFC_ISYM_IERRNO,
|
||||
GFC_ISYM_INDEX,
|
||||
GFC_ISYM_INT,
|
||||
GFC_ISYM_IOR,
|
||||
GFC_ISYM_IRAND,
|
||||
GFC_ISYM_ISHFT,
|
||||
GFC_ISYM_ISHFTC,
|
||||
GFC_ISYM_KILL,
|
||||
GFC_ISYM_LBOUND,
|
||||
GFC_ISYM_LEN,
|
||||
GFC_ISYM_LEN_TRIM,
|
||||
GFC_ISYM_LINK,
|
||||
GFC_ISYM_LGE,
|
||||
GFC_ISYM_LGT,
|
||||
GFC_ISYM_LLE,
|
||||
|
|
@ -359,6 +364,7 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_PRODUCT,
|
||||
GFC_ISYM_RAND,
|
||||
GFC_ISYM_REAL,
|
||||
GFC_ISYM_RENAME,
|
||||
GFC_ISYM_REPEAT,
|
||||
GFC_ISYM_RESHAPE,
|
||||
GFC_ISYM_RRSPACING,
|
||||
|
|
@ -378,9 +384,12 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_SR_KIND,
|
||||
GFC_ISYM_STAT,
|
||||
GFC_ISYM_SUM,
|
||||
GFC_ISYM_SYMLNK,
|
||||
GFC_ISYM_SYSTEM,
|
||||
GFC_ISYM_TAN,
|
||||
GFC_ISYM_TANH,
|
||||
GFC_ISYM_TIME,
|
||||
GFC_ISYM_TIME8,
|
||||
GFC_ISYM_TRANSFER,
|
||||
GFC_ISYM_TRANSPOSE,
|
||||
GFC_ISYM_TRIM,
|
||||
|
|
|
|||
|
|
@ -1092,6 +1092,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("char", GFC_ISYM_CHAR, GFC_STD_F77);
|
||||
|
||||
add_sym_1 ("chdir", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
gfc_check_chdir, NULL, gfc_resolve_chdir,
|
||||
a, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("chdir", GFC_ISYM_CHDIR, GFC_STD_GNU);
|
||||
|
||||
add_sym_3 ("cmplx", 1, 1, BT_COMPLEX, dz, GFC_STD_F77,
|
||||
gfc_check_cmplx, gfc_simplify_cmplx, gfc_resolve_cmplx,
|
||||
x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, OPTIONAL,
|
||||
|
|
@ -1323,6 +1329,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("getuid", GFC_ISYM_GETUID, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("hostnm", 0, 1, 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);
|
||||
|
||||
add_sym_1 ("huge", 0, 1, BT_REAL, dr, GFC_STD_F95,
|
||||
gfc_check_huge, gfc_simplify_huge, NULL,
|
||||
x, BT_UNKNOWN, dr, REQUIRED);
|
||||
|
|
@ -1383,6 +1395,11 @@ add_functions (void)
|
|||
|
||||
make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
|
||||
|
||||
add_sym_0 ("ierrno", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
|
||||
NULL, NULL, gfc_resolve_ierrno);
|
||||
|
||||
make_generic ("ierrno", GFC_ISYM_IERRNO, GFC_STD_GNU);
|
||||
|
||||
add_sym_3 ("index", 1, 1, BT_INTEGER, di, GFC_STD_F77,
|
||||
gfc_check_index, gfc_simplify_index, NULL,
|
||||
stg, BT_CHARACTER, dc, REQUIRED, ssg, BT_CHARACTER, dc, REQUIRED,
|
||||
|
|
@ -1430,6 +1447,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("ishftc", GFC_ISYM_ISHFTC, GFC_STD_F95);
|
||||
|
||||
add_sym_2 ("kill", 1, 1, 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);
|
||||
|
||||
add_sym_1 ("kind", 0, 1, BT_INTEGER, di, GFC_STD_F95,
|
||||
gfc_check_kind, gfc_simplify_kind, NULL,
|
||||
x, BT_REAL, dr, REQUIRED);
|
||||
|
|
@ -1452,6 +1475,8 @@ add_functions (void)
|
|||
NULL, gfc_simplify_len_trim, gfc_resolve_len_trim,
|
||||
stg, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_alias ("lnblnk", GFC_STD_GNU);
|
||||
|
||||
make_generic ("len_trim", GFC_ISYM_LEN_TRIM, GFC_STD_F95);
|
||||
|
||||
add_sym_2 ("lge", 1, 0, BT_LOGICAL, dl, GFC_STD_F77,
|
||||
|
|
@ -1478,6 +1503,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("llt", GFC_ISYM_LLT, GFC_STD_F77);
|
||||
|
||||
add_sym_2 ("link", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
gfc_check_link, NULL, gfc_resolve_link,
|
||||
a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("link", GFC_ISYM_LINK, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("log", 1, 1, BT_REAL, dr, GFC_STD_F77,
|
||||
gfc_check_fn_rc, gfc_simplify_log, gfc_resolve_log,
|
||||
x, BT_REAL, dr, REQUIRED);
|
||||
|
|
@ -1744,6 +1775,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("real", GFC_ISYM_REAL, GFC_STD_F77);
|
||||
|
||||
add_sym_2 ("rename", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
gfc_check_rename, NULL, gfc_resolve_rename,
|
||||
a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("rename", GFC_ISYM_RENAME, GFC_STD_GNU);
|
||||
|
||||
add_sym_2 ("repeat", 0, 1, BT_CHARACTER, dc, GFC_STD_F95,
|
||||
gfc_check_repeat, gfc_simplify_repeat, gfc_resolve_repeat,
|
||||
stg, BT_CHARACTER, dc, REQUIRED, n, BT_INTEGER, di, REQUIRED);
|
||||
|
|
@ -1904,6 +1941,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("sum", GFC_ISYM_SUM, GFC_STD_F95);
|
||||
|
||||
add_sym_2 ("symlnk", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
gfc_check_symlnk, NULL, gfc_resolve_symlnk,
|
||||
a, BT_CHARACTER, dc, REQUIRED, b, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("symlnk", GFC_ISYM_SYMLNK, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("system", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
NULL, NULL, NULL,
|
||||
c, BT_CHARACTER, dc, REQUIRED);
|
||||
|
|
@ -1930,6 +1973,16 @@ add_functions (void)
|
|||
|
||||
make_generic ("tanh", GFC_ISYM_TANH, GFC_STD_F77);
|
||||
|
||||
add_sym_0 ("time", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
|
||||
NULL, NULL, gfc_resolve_time);
|
||||
|
||||
make_generic ("time", GFC_ISYM_TIME, GFC_STD_GNU);
|
||||
|
||||
add_sym_0 ("time8", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
|
||||
NULL, NULL, gfc_resolve_time8);
|
||||
|
||||
make_generic ("time8", GFC_ISYM_TIME8, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("tiny", 0, 1, BT_REAL, dr, GFC_STD_F95,
|
||||
gfc_check_x, gfc_simplify_tiny, NULL,
|
||||
x, BT_REAL, dr, REQUIRED);
|
||||
|
|
@ -2024,6 +2077,10 @@ add_subroutines (void)
|
|||
gfc_check_second_sub, NULL, gfc_resolve_second_sub,
|
||||
tm, BT_REAL, dr, REQUIRED);
|
||||
|
||||
add_sym_2s ("chdir", 0, 1, 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_4s ("date_and_time", 0, 1, BT_UNKNOWN, 0, GFC_STD_F95,
|
||||
gfc_check_date_and_time, NULL, NULL,
|
||||
dt, BT_CHARACTER, dc, OPTIONAL, tm, BT_CHARACTER, dc, OPTIONAL,
|
||||
|
|
@ -2038,6 +2095,10 @@ add_subroutines (void)
|
|||
gfc_check_etime_sub, NULL, gfc_resolve_etime_sub,
|
||||
vl, BT_REAL, 4, REQUIRED, tm, BT_REAL, 4, REQUIRED);
|
||||
|
||||
add_sym_1s ("gerror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_gerror, NULL, gfc_resolve_gerror, c, BT_CHARACTER,
|
||||
dc, REQUIRED);
|
||||
|
||||
add_sym_2s ("getcwd", 0, 1, 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);
|
||||
|
|
@ -2050,6 +2111,10 @@ add_subroutines (void)
|
|||
NULL, NULL, gfc_resolve_getarg,
|
||||
c, BT_INTEGER, di, REQUIRED, vl, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
add_sym_1s ("getlog", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_getlog, NULL, gfc_resolve_getlog, c, BT_CHARACTER,
|
||||
dc, REQUIRED);
|
||||
|
||||
/* F2003 commandline routines. */
|
||||
|
||||
add_sym_3s ("get_command", 0, 1, BT_UNKNOWN, 0, GFC_STD_F2003,
|
||||
|
|
@ -2098,6 +2163,32 @@ add_subroutines (void)
|
|||
gfc_check_flush, NULL, gfc_resolve_flush,
|
||||
c, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_2s ("hostnm", 0, 1, 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", 0, 1, 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", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_link_sub, NULL, gfc_resolve_link_sub,
|
||||
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
|
||||
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_1s ("perror", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_perror, NULL, gfc_resolve_perror,
|
||||
c, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
add_sym_3s ("rename", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_rename_sub, NULL, gfc_resolve_rename_sub,
|
||||
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
|
||||
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_1s ("sleep", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_sleep_sub, NULL, gfc_resolve_sleep_sub,
|
||||
val, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
add_sym_3s ("fstat", 0, 1, 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,
|
||||
|
|
@ -2108,6 +2199,11 @@ add_subroutines (void)
|
|||
name, BT_CHARACTER, dc, REQUIRED, vl, BT_INTEGER, di, REQUIRED,
|
||||
st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_3s ("symlnk", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_symlnk_sub, NULL, gfc_resolve_symlnk_sub,
|
||||
name, BT_CHARACTER, dc, REQUIRED, val, BT_CHARACTER,
|
||||
dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_2s ("system", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
NULL, NULL, gfc_resolve_system_sub,
|
||||
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
|
||||
|
|
|
|||
|
|
@ -40,6 +40,7 @@ try gfc_check_atan2 (gfc_expr *, gfc_expr *);
|
|||
try gfc_check_besn (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_btest (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_char (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_chdir (gfc_expr *);
|
||||
try gfc_check_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_count (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
|
|
@ -55,6 +56,7 @@ try gfc_check_fn_r (gfc_expr *);
|
|||
try gfc_check_fn_rc (gfc_expr *);
|
||||
try gfc_check_fnum (gfc_expr *);
|
||||
try gfc_check_g77_math1 (gfc_expr *);
|
||||
try gfc_check_hostnm (gfc_expr *);
|
||||
try gfc_check_huge (gfc_expr *);
|
||||
try gfc_check_i (gfc_expr *);
|
||||
try gfc_check_iand (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -69,8 +71,10 @@ try gfc_check_ior (gfc_expr *, gfc_expr *);
|
|||
try gfc_check_irand (gfc_expr *);
|
||||
try gfc_check_ishft (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_kill (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_kind (gfc_expr *);
|
||||
try gfc_check_lbound (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_link (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_logical (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_min_max (gfc_actual_arglist *);
|
||||
try gfc_check_min_max_integer (gfc_actual_arglist *);
|
||||
|
|
@ -90,6 +94,7 @@ try gfc_check_radix (gfc_expr *);
|
|||
try gfc_check_rand (gfc_expr *);
|
||||
try gfc_check_range (gfc_expr *);
|
||||
try gfc_check_real (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_rename (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_repeat (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_scale (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -105,6 +110,7 @@ try gfc_check_spread (gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
try gfc_check_srand (gfc_expr *);
|
||||
try gfc_check_stat (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_sum (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_symlnk (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_transpose (gfc_expr *);
|
||||
try gfc_check_trim (gfc_expr *);
|
||||
|
|
@ -117,18 +123,28 @@ try gfc_check_x (gfc_expr *);
|
|||
|
||||
|
||||
/* Intrinsic subroutines. */
|
||||
try gfc_check_chdir_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_cpu_time (gfc_expr *);
|
||||
try gfc_check_system_clock (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_date_and_time (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_exit (gfc_expr *);
|
||||
try gfc_check_flush (gfc_expr *);
|
||||
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_gerror (gfc_expr *);
|
||||
try gfc_check_getlog (gfc_expr *);
|
||||
try gfc_check_mvbits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
|
||||
gfc_expr *);
|
||||
try gfc_check_random_number (gfc_expr *);
|
||||
try gfc_check_random_seed (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_etime_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_getcwd_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_hostnm_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_kill_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_perror (gfc_expr *);
|
||||
try gfc_check_rename_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_link_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_symlnk_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_sleep_sub (gfc_expr *);
|
||||
try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_system_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_umask_sub (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -256,6 +272,7 @@ void gfc_resolve_besn (gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_btest (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ceiling (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_char (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_chdir (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_cmplx (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_dcmplx (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_conjg (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -281,10 +298,12 @@ void gfc_resolve_getcwd (gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_getgid (gfc_expr *);
|
||||
void gfc_resolve_getpid (gfc_expr *);
|
||||
void gfc_resolve_getuid (gfc_expr *);
|
||||
void gfc_resolve_hostnm (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_iand (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ibclr (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ibits (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ibset (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ierrno (gfc_expr *);
|
||||
void gfc_resolve_ieor (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ichar (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_idnint (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -292,9 +311,11 @@ void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_lbound (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_len (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_len_trim (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_link (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_log (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_log10 (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_logical (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
|
|
@ -314,6 +335,7 @@ void gfc_resolve_not (gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_pack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_product (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_real (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_rename (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_repeat (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_reshape (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *,
|
||||
gfc_expr *);
|
||||
|
|
@ -332,9 +354,12 @@ void gfc_resolve_sqrt (gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_stat (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_srand (gfc_code *);
|
||||
void gfc_resolve_sum (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_symlnk (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_system (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_tan (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_tanh (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_time (gfc_expr *);
|
||||
void gfc_resolve_time8 (gfc_expr *);
|
||||
void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_transpose (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_trim (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -346,17 +371,27 @@ void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
|
||||
|
||||
/* Intrinsic subroutine resolution. */
|
||||
void gfc_resolve_chdir_sub (gfc_code *);
|
||||
void gfc_resolve_cpu_time (gfc_code *);
|
||||
void gfc_resolve_exit (gfc_code *);
|
||||
void gfc_resolve_flush (gfc_code *);
|
||||
void gfc_resolve_fstat_sub (gfc_code *);
|
||||
void gfc_resolve_gerror (gfc_code *);
|
||||
void gfc_resolve_getarg (gfc_code *);
|
||||
void gfc_resolve_getcwd_sub (gfc_code *);
|
||||
void gfc_resolve_getlog (gfc_code *);
|
||||
void gfc_resolve_get_command (gfc_code *);
|
||||
void gfc_resolve_get_command_argument (gfc_code *);
|
||||
void gfc_resolve_get_environment_variable (gfc_code *);
|
||||
void gfc_resolve_hostnm_sub (gfc_code *);
|
||||
void gfc_resolve_kill_sub (gfc_code *);
|
||||
void gfc_resolve_mvbits (gfc_code *);
|
||||
void gfc_resolve_perror (gfc_code *);
|
||||
void gfc_resolve_random_number (gfc_code *);
|
||||
void gfc_resolve_rename_sub (gfc_code *);
|
||||
void gfc_resolve_link_sub (gfc_code *);
|
||||
void gfc_resolve_symlnk_sub (gfc_code *);
|
||||
void gfc_resolve_sleep_sub (gfc_code *);
|
||||
void gfc_resolve_stat_sub (gfc_code *);
|
||||
void gfc_resolve_system_clock (gfc_code *);
|
||||
void gfc_resolve_system_sub (gfc_code *);
|
||||
|
|
|
|||
|
|
@ -252,6 +252,31 @@ gfc_resolve_char (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_chdir (gfc_expr * f, gfc_expr * d ATTRIBUTE_UNUSED)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_default_integer_kind;
|
||||
f->value.function.name = gfc_get_string (PREFIX("chdir_i%d"), f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_chdir_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
if (c->ext.actual->next->expr != NULL)
|
||||
kind = c->ext.actual->next->expr->ts.kind;
|
||||
else
|
||||
kind = gfc_default_integer_kind;
|
||||
|
||||
name = gfc_get_string (PREFIX("chdir_i%d_sub"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_cmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y, gfc_expr * kind)
|
||||
{
|
||||
|
|
@ -532,6 +557,14 @@ gfc_resolve_getuid (gfc_expr * f)
|
|||
f->value.function.name = gfc_get_string (PREFIX("getuid"));
|
||||
}
|
||||
|
||||
void
|
||||
gfc_resolve_hostnm (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = 4;
|
||||
f->value.function.name = gfc_get_string (PREFIX ("hostnm"));
|
||||
}
|
||||
|
||||
void
|
||||
gfc_resolve_iand (gfc_expr * f, gfc_expr * i, gfc_expr * j)
|
||||
{
|
||||
|
|
@ -595,6 +628,15 @@ gfc_resolve_idnint (gfc_expr * f, gfc_expr * a)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_ierrno (gfc_expr * f)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_default_integer_kind;
|
||||
f->value.function.name = gfc_get_string (PREFIX("ierrno_i%d"), f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_ieor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
|
||||
{
|
||||
|
|
@ -669,6 +711,17 @@ gfc_resolve_ishftc (gfc_expr * f, gfc_expr * i, gfc_expr * shift,
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_kill (gfc_expr * f, ATTRIBUTE_UNUSED gfc_expr * p,
|
||||
ATTRIBUTE_UNUSED gfc_expr * s)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_default_integer_kind;
|
||||
|
||||
f->value.function.name = gfc_get_string (PREFIX("kill_i%d"), f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_lbound (gfc_expr * f, gfc_expr * array,
|
||||
gfc_expr * dim)
|
||||
|
|
@ -707,6 +760,16 @@ gfc_resolve_len_trim (gfc_expr * f, gfc_expr * string)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_link (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
|
||||
gfc_expr * p2 ATTRIBUTE_UNUSED)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_default_integer_kind;
|
||||
f->value.function.name = gfc_get_string (PREFIX("link_i%d"), f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_log (gfc_expr * f, gfc_expr * x)
|
||||
{
|
||||
|
|
@ -1018,6 +1081,16 @@ gfc_resolve_real (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_rename (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
|
||||
gfc_expr * p2 ATTRIBUTE_UNUSED)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_default_integer_kind;
|
||||
f->value.function.name = gfc_get_string (PREFIX("rename_i%d"), f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_repeat (gfc_expr * f, gfc_expr * string,
|
||||
gfc_expr * ncopies ATTRIBUTE_UNUSED)
|
||||
|
|
@ -1275,6 +1348,16 @@ gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_symlnk (gfc_expr * f, gfc_expr * p1 ATTRIBUTE_UNUSED,
|
||||
gfc_expr * p2 ATTRIBUTE_UNUSED)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_default_integer_kind;
|
||||
f->value.function.name = gfc_get_string (PREFIX("symlnk_i%d"), f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
/* Resolve the g77 compatibility function SYSTEM. */
|
||||
|
||||
void
|
||||
|
|
@ -1304,6 +1387,24 @@ gfc_resolve_tanh (gfc_expr * f, gfc_expr * x)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_time (gfc_expr * f)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = 4;
|
||||
f->value.function.name = gfc_get_string (PREFIX("time_func"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_time8 (gfc_expr * f)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = 8;
|
||||
f->value.function.name = gfc_get_string (PREFIX("time8_func"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_transfer (gfc_expr * f, gfc_expr * source ATTRIBUTE_UNUSED,
|
||||
gfc_expr * mold, gfc_expr * size)
|
||||
|
|
@ -1490,6 +1591,70 @@ gfc_resolve_random_number (gfc_code * c ATTRIBUTE_UNUSED)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_rename_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
if (c->ext.actual->next->next->expr != NULL)
|
||||
kind = c->ext.actual->next->next->expr->ts.kind;
|
||||
else
|
||||
kind = gfc_default_integer_kind;
|
||||
|
||||
name = gfc_get_string (PREFIX("rename_i%d_sub"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_kill_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
if (c->ext.actual->next->next->expr != NULL)
|
||||
kind = c->ext.actual->next->next->expr->ts.kind;
|
||||
else
|
||||
kind = gfc_default_integer_kind;
|
||||
|
||||
name = gfc_get_string (PREFIX("kill_i%d_sub"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_link_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
if (c->ext.actual->next->next->expr != NULL)
|
||||
kind = c->ext.actual->next->next->expr->ts.kind;
|
||||
else
|
||||
kind = gfc_default_integer_kind;
|
||||
|
||||
name = gfc_get_string (PREFIX("link_i%d_sub"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_symlnk_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
if (c->ext.actual->next->next->expr != NULL)
|
||||
kind = c->ext.actual->next->next->expr->ts.kind;
|
||||
else
|
||||
kind = gfc_default_integer_kind;
|
||||
|
||||
name = gfc_get_string (PREFIX("symlnk_i%d_sub"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
/* G77 compatibility subroutines etime() and dtime(). */
|
||||
|
||||
void
|
||||
|
|
@ -1514,6 +1679,22 @@ gfc_resolve_second_sub (gfc_code * c)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_sleep_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
if (c->ext.actual->expr != NULL)
|
||||
kind = c->ext.actual->expr->ts.kind;
|
||||
else
|
||||
kind = gfc_default_integer_kind;
|
||||
|
||||
name = gfc_get_string (PREFIX("sleep_i%d_sub"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
/* G77 compatibility function srand(). */
|
||||
|
||||
void
|
||||
|
|
@ -1665,6 +1846,43 @@ gfc_resolve_flush (gfc_code * c)
|
|||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_gerror (gfc_code * c)
|
||||
{
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("gerror"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_getlog (gfc_code * c)
|
||||
{
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("getlog"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_hostnm_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
int kind;
|
||||
|
||||
if (c->ext.actual->next->expr != NULL)
|
||||
kind = c->ext.actual->next->expr->ts.kind;
|
||||
else
|
||||
kind = gfc_default_integer_kind;
|
||||
|
||||
name = gfc_get_string (PREFIX("hostnm_i%d_sub"), kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_perror (gfc_code * c)
|
||||
{
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX ("perror_sub"));
|
||||
}
|
||||
|
||||
/* Resolve the STAT and FSTAT intrinsic subroutines. */
|
||||
|
||||
void
|
||||
|
|
|
|||
|
|
@ -2977,6 +2977,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
gfc_conv_intrinsic_bound (se, expr, 1);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_CHDIR:
|
||||
case GFC_ISYM_DOT_PRODUCT:
|
||||
case GFC_ISYM_ETIME:
|
||||
case GFC_ISYM_FNUM:
|
||||
|
|
@ -2985,12 +2986,20 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
case GFC_ISYM_GETGID:
|
||||
case GFC_ISYM_GETPID:
|
||||
case GFC_ISYM_GETUID:
|
||||
case GFC_ISYM_HOSTNM:
|
||||
case GFC_ISYM_KILL:
|
||||
case GFC_ISYM_IERRNO:
|
||||
case GFC_ISYM_IRAND:
|
||||
case GFC_ISYM_LINK:
|
||||
case GFC_ISYM_MATMUL:
|
||||
case GFC_ISYM_RAND:
|
||||
case GFC_ISYM_RENAME:
|
||||
case GFC_ISYM_SECOND:
|
||||
case GFC_ISYM_STAT:
|
||||
case GFC_ISYM_SYMLNK:
|
||||
case GFC_ISYM_SYSTEM:
|
||||
case GFC_ISYM_TIME:
|
||||
case GFC_ISYM_TIME8:
|
||||
case GFC_ISYM_UMASK:
|
||||
case GFC_ISYM_UNLINK:
|
||||
gfc_conv_intrinsic_funcall (se, expr);
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2005-03-22 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* g77_intrinsics_funcs.f: New test.
|
||||
* g77_intrinsics_sub.f: New test.
|
||||
|
||||
2005-03-22 Richard Guenther <rguenth@tat.physik.uni-tuebingen.de>
|
||||
Jan Hubicka <jh@suse.cz>
|
||||
Steven Bosscher <stevenb@suse.de
|
||||
|
|
@ -68,6 +73,7 @@
|
|||
* gcc.c-torture/compile/pr20539-1.c: Likewise.
|
||||
* g++.dg/opt/pr13066-1.C: Likewise.
|
||||
|
||||
>>>>>>> 1.5197
|
||||
2005-03-20 Joseph S. Myers <joseph@codesourcery.com>
|
||||
|
||||
* gcc.dg/bitfld-14.c, gcc.dg/enum3.c: New tests.
|
||||
|
|
|
|||
51
gcc/testsuite/gfortran.dg/g77_intrinsics_funcs.f
Normal file
51
gcc/testsuite/gfortran.dg/g77_intrinsics_funcs.f
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
! {dg-do compile}
|
||||
! Testing g77 intrinsics as subroutines
|
||||
integer*8 i8
|
||||
integer*4 i4
|
||||
integer i
|
||||
character*80 c
|
||||
|
||||
i8 = time ()
|
||||
i4 = time ()
|
||||
i8 = time8 ()
|
||||
i4 = time8 ()
|
||||
|
||||
i8 = hostnm (c)
|
||||
i4 = hostnm (c)
|
||||
i = hostnm (c)
|
||||
|
||||
i8 = ierrno ()
|
||||
i4 = ierrno ()
|
||||
i = ierrno ()
|
||||
|
||||
i8 = kill (i8, i8)
|
||||
i8 = kill (i8, i4)
|
||||
i8 = kill (i4, i8)
|
||||
i8 = kill (i4, i4)
|
||||
i4 = kill (i8, i8)
|
||||
i4 = kill (i8, i4)
|
||||
i4 = kill (i4, i8)
|
||||
i4 = kill (i4, i4)
|
||||
|
||||
i8 = link ('foo', 'bar')
|
||||
i4 = link ('foo', 'bar')
|
||||
i = link ('foo', 'bar')
|
||||
|
||||
i8 = rename ('foo', 'bar')
|
||||
i4 = rename ('foo', 'bar')
|
||||
i = rename ('foo', 'bar')
|
||||
|
||||
i8 = symlnk ('foo', 'bar')
|
||||
i4 = symlnk ('foo', 'bar')
|
||||
i = symlnk ('foo', 'bar')
|
||||
|
||||
! Cleaning our mess
|
||||
call unlink ('bar')
|
||||
|
||||
! This should be the last test, unless you want garbage everywhere in
|
||||
! your filesystem.
|
||||
i8 = chdir ('..')
|
||||
i4 = chdir ('..')
|
||||
i = chdir ('..')
|
||||
|
||||
end
|
||||
82
gcc/testsuite/gfortran.dg/g77_intrinsics_sub.f
Normal file
82
gcc/testsuite/gfortran.dg/g77_intrinsics_sub.f
Normal file
|
|
@ -0,0 +1,82 @@
|
|||
! {dg-do compile}
|
||||
! Testing g77 intrinsics as subroutines
|
||||
integer*8 i8, j8
|
||||
integer*4 i4, j4
|
||||
integer i, j
|
||||
character*80 c
|
||||
|
||||
call gerror (c)
|
||||
call getlog (c)
|
||||
|
||||
call hostnm (c, status = i8)
|
||||
call hostnm (c, i8)
|
||||
call hostnm (c, status = i4)
|
||||
call hostnm (c, i4)
|
||||
call hostnm (c, status = i)
|
||||
call hostnm (c, i)
|
||||
call hostnm (c)
|
||||
|
||||
call kill (i8, i8, status = i8)
|
||||
call kill (i8, i8, i8)
|
||||
call kill (i4, i8, i8)
|
||||
call kill (i8, i4, i8)
|
||||
call kill (i8, i8, i4)
|
||||
call kill (i4, i4, i8)
|
||||
call kill (i4, i8, i4)
|
||||
call kill (i8, i4, i4)
|
||||
call kill (i4, i4, i4)
|
||||
call kill (i, i, i)
|
||||
call kill (i8, i8)
|
||||
call kill (i4, i8)
|
||||
call kill (i8, i4)
|
||||
call kill (i4, i4)
|
||||
call kill (i, i)
|
||||
|
||||
call link ('foo', 'bar', status = i8)
|
||||
call link ('foo', 'bar', status = i4)
|
||||
call link ('foo', 'bar', status = i)
|
||||
call link ('foo', 'bar', i8)
|
||||
call link ('foo', 'bar', i4)
|
||||
call link ('foo', 'bar', i)
|
||||
call link ('foo', 'bar')
|
||||
|
||||
call perror (c)
|
||||
|
||||
call rename ('foo', 'bar', status = i8)
|
||||
call rename ('foo', 'bar', status = i4)
|
||||
call rename ('foo', 'bar', status = i)
|
||||
call rename ('foo', 'bar', i8)
|
||||
call rename ('foo', 'bar', i4)
|
||||
call rename ('foo', 'bar', i)
|
||||
call rename ('foo', 'bar')
|
||||
|
||||
i = 1
|
||||
i4 = 1
|
||||
i8 = 1
|
||||
call sleep (i)
|
||||
call sleep (i4)
|
||||
call sleep (i8)
|
||||
call sleep (-1)
|
||||
|
||||
call symlnk ('foo', 'bar', status = i8)
|
||||
call symlnk ('foo', 'bar', status = i4)
|
||||
call symlnk ('foo', 'bar', status = i)
|
||||
call symlnk ('foo', 'bar', i8)
|
||||
call symlnk ('foo', 'bar', i4)
|
||||
call symlnk ('foo', 'bar', i)
|
||||
call symlnk ('foo', 'bar')
|
||||
|
||||
! Cleaning our mess
|
||||
call unlink ('bar')
|
||||
|
||||
! This should be the last test, unless you want garbage everywhere in
|
||||
! your filesystem.
|
||||
call chdir ('..', status = i8)
|
||||
call chdir ('..', i8)
|
||||
call chdir ('..', status = i4)
|
||||
call chdir ('..', i4)
|
||||
call chdir ('..', status = i)
|
||||
call chdir ('..', i)
|
||||
call chdir ('..')
|
||||
|
||||
end
|
||||
|
|
@ -1,3 +1,18 @@
|
|||
2005-03-22 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* Makefile.am: Added new files.
|
||||
* Makefile.in: Regenerate.
|
||||
* aclocal.m4: Regenerate.
|
||||
* configure.ac: add checks for signal.h headers file, as well as
|
||||
following functions: chdir, strerror, getlogin, gethostname, kill,
|
||||
link, symlink, perror, sleep, time.
|
||||
* configure: Regenerate.
|
||||
* intrinsics/chdir.c, intrinsics/gerror.c, intrinsics/getlog.c,
|
||||
intrinsics/hostnm.c, intrinsics/ierrno.c, intrinsics/kill.c,
|
||||
intrinsics/link.c, intrinsics/perror.c, intrinsics/rename.c,
|
||||
intrinsics/sleep.c, intrinsics/symlnk.c, intrinsics/time.c: Newly
|
||||
implementend g77 intrinsics.
|
||||
|
||||
2005-03-21 Zack Weinberg <zack@codesourcery.com>
|
||||
|
||||
* configure.ac: Do not invoke TL_AC_GCC_VERSION.
|
||||
|
|
|
|||
|
|
@ -47,6 +47,7 @@ intrinsics/abort.c \
|
|||
intrinsics/args.c \
|
||||
intrinsics/bessel.c \
|
||||
intrinsics/c99_functions.c \
|
||||
intrinsics/chdir.c \
|
||||
intrinsics/cpu_time.c \
|
||||
intrinsics/cshift0.c \
|
||||
intrinsics/date_and_time.c \
|
||||
|
|
@ -58,23 +59,34 @@ intrinsics/etime.c \
|
|||
intrinsics/exit.c \
|
||||
intrinsics/flush.c \
|
||||
intrinsics/fnum.c \
|
||||
intrinsics/gerror.c \
|
||||
intrinsics/getcwd.c \
|
||||
intrinsics/getlog.c \
|
||||
intrinsics/getXid.c \
|
||||
intrinsics/hostnm.c \
|
||||
intrinsics/kill.c \
|
||||
intrinsics/ierrno.c \
|
||||
intrinsics/ishftc.c \
|
||||
intrinsics/link.c \
|
||||
intrinsics/mvbits.c \
|
||||
intrinsics/pack_generic.c \
|
||||
intrinsics/perror.c \
|
||||
intrinsics/size.c \
|
||||
intrinsics/sleep.c \
|
||||
intrinsics/spread_generic.c \
|
||||
intrinsics/string_intrinsics.c \
|
||||
intrinsics/system.c \
|
||||
intrinsics/rand.c \
|
||||
intrinsics/random.c \
|
||||
intrinsics/rename.c \
|
||||
intrinsics/reshape_generic.c \
|
||||
intrinsics/reshape_packed.c \
|
||||
intrinsics/selected_int_kind.f90 \
|
||||
intrinsics/selected_real_kind.f90 \
|
||||
intrinsics/stat.c \
|
||||
intrinsics/symlnk.c \
|
||||
intrinsics/system_clock.c \
|
||||
intrinsics/time.c \
|
||||
intrinsics/transpose_generic.c \
|
||||
intrinsics/umask.c \
|
||||
intrinsics/unlink.c \
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
# Makefile.in generated by automake 1.9.3 from Makefile.am.
|
||||
# Makefile.in generated by automake 1.9.4 from Makefile.am.
|
||||
# @configure_input@
|
||||
|
||||
# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
|
||||
|
|
@ -47,9 +47,8 @@ DIST_COMMON = README $(am__configure_deps) $(srcdir)/../config.guess \
|
|||
$(top_srcdir)/configure AUTHORS COPYING ChangeLog INSTALL NEWS
|
||||
subdir = .
|
||||
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
|
||||
am__aclocal_m4_deps = $(top_srcdir)/../config/no-executables.m4 \
|
||||
$(top_srcdir)/acinclude.m4 $(top_srcdir)/../libtool.m4 \
|
||||
$(top_srcdir)/configure.ac
|
||||
am__aclocal_m4_deps = $(top_srcdir)/acinclude.m4 \
|
||||
$(top_srcdir)/../libtool.m4 $(top_srcdir)/configure.ac
|
||||
am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
|
||||
$(ACLOCAL_M4)
|
||||
am__CONFIG_DISTCLEAN_FILES = config.status config.cache config.log \
|
||||
|
|
@ -127,13 +126,15 @@ am__objects_32 = backspace.lo close.lo endfile.lo format.lo inquire.lo \
|
|||
list_read.lo lock.lo open.lo read.lo rewind.lo transfer.lo \
|
||||
unit.lo unix.lo write.lo
|
||||
am__objects_33 = associated.lo abort.lo args.lo bessel.lo \
|
||||
c99_functions.lo cpu_time.lo cshift0.lo date_and_time.lo \
|
||||
env.lo erf.lo eoshift0.lo eoshift2.lo etime.lo exit.lo \
|
||||
flush.lo fnum.lo getcwd.lo getXid.lo ishftc.lo mvbits.lo \
|
||||
pack_generic.lo size.lo spread_generic.lo string_intrinsics.lo \
|
||||
system.lo rand.lo random.lo reshape_generic.lo \
|
||||
reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
|
||||
stat.lo system_clock.lo transpose_generic.lo umask.lo \
|
||||
c99_functions.lo chdir.lo cpu_time.lo cshift0.lo \
|
||||
date_and_time.lo env.lo erf.lo eoshift0.lo eoshift2.lo \
|
||||
etime.lo exit.lo flush.lo fnum.lo gerror.lo getcwd.lo \
|
||||
getlog.lo getXid.lo hostnm.lo kill.lo ierrno.lo ishftc.lo \
|
||||
link.lo mvbits.lo pack_generic.lo perror.lo size.lo sleep.lo \
|
||||
spread_generic.lo string_intrinsics.lo system.lo rand.lo \
|
||||
random.lo rename.lo reshape_generic.lo reshape_packed.lo \
|
||||
selected_int_kind.lo selected_real_kind.lo stat.lo symlnk.lo \
|
||||
system_clock.lo time.lo transpose_generic.lo umask.lo \
|
||||
unlink.lo unpack_generic.lo in_pack_generic.lo \
|
||||
in_unpack_generic.lo normalize.lo
|
||||
am__objects_34 =
|
||||
|
|
@ -326,6 +327,7 @@ intrinsics/abort.c \
|
|||
intrinsics/args.c \
|
||||
intrinsics/bessel.c \
|
||||
intrinsics/c99_functions.c \
|
||||
intrinsics/chdir.c \
|
||||
intrinsics/cpu_time.c \
|
||||
intrinsics/cshift0.c \
|
||||
intrinsics/date_and_time.c \
|
||||
|
|
@ -337,23 +339,34 @@ intrinsics/etime.c \
|
|||
intrinsics/exit.c \
|
||||
intrinsics/flush.c \
|
||||
intrinsics/fnum.c \
|
||||
intrinsics/gerror.c \
|
||||
intrinsics/getcwd.c \
|
||||
intrinsics/getlog.c \
|
||||
intrinsics/getXid.c \
|
||||
intrinsics/hostnm.c \
|
||||
intrinsics/kill.c \
|
||||
intrinsics/ierrno.c \
|
||||
intrinsics/ishftc.c \
|
||||
intrinsics/link.c \
|
||||
intrinsics/mvbits.c \
|
||||
intrinsics/pack_generic.c \
|
||||
intrinsics/perror.c \
|
||||
intrinsics/size.c \
|
||||
intrinsics/sleep.c \
|
||||
intrinsics/spread_generic.c \
|
||||
intrinsics/string_intrinsics.c \
|
||||
intrinsics/system.c \
|
||||
intrinsics/rand.c \
|
||||
intrinsics/random.c \
|
||||
intrinsics/rename.c \
|
||||
intrinsics/reshape_generic.c \
|
||||
intrinsics/reshape_packed.c \
|
||||
intrinsics/selected_int_kind.f90 \
|
||||
intrinsics/selected_real_kind.f90 \
|
||||
intrinsics/stat.c \
|
||||
intrinsics/symlnk.c \
|
||||
intrinsics/system_clock.c \
|
||||
intrinsics/time.c \
|
||||
intrinsics/transpose_generic.c \
|
||||
intrinsics/umask.c \
|
||||
intrinsics/unlink.c \
|
||||
|
|
@ -1210,6 +1223,9 @@ bessel.lo: intrinsics/bessel.c
|
|||
c99_functions.lo: intrinsics/c99_functions.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o c99_functions.lo `test -f 'intrinsics/c99_functions.c' || echo '$(srcdir)/'`intrinsics/c99_functions.c
|
||||
|
||||
chdir.lo: intrinsics/chdir.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o chdir.lo `test -f 'intrinsics/chdir.c' || echo '$(srcdir)/'`intrinsics/chdir.c
|
||||
|
||||
cpu_time.lo: intrinsics/cpu_time.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o cpu_time.lo `test -f 'intrinsics/cpu_time.c' || echo '$(srcdir)/'`intrinsics/cpu_time.c
|
||||
|
||||
|
|
@ -1243,24 +1259,48 @@ flush.lo: intrinsics/flush.c
|
|||
fnum.lo: intrinsics/fnum.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fnum.lo `test -f 'intrinsics/fnum.c' || echo '$(srcdir)/'`intrinsics/fnum.c
|
||||
|
||||
gerror.lo: intrinsics/gerror.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o gerror.lo `test -f 'intrinsics/gerror.c' || echo '$(srcdir)/'`intrinsics/gerror.c
|
||||
|
||||
getcwd.lo: intrinsics/getcwd.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o getcwd.lo `test -f 'intrinsics/getcwd.c' || echo '$(srcdir)/'`intrinsics/getcwd.c
|
||||
|
||||
getlog.lo: intrinsics/getlog.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o getlog.lo `test -f 'intrinsics/getlog.c' || echo '$(srcdir)/'`intrinsics/getlog.c
|
||||
|
||||
getXid.lo: intrinsics/getXid.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o getXid.lo `test -f 'intrinsics/getXid.c' || echo '$(srcdir)/'`intrinsics/getXid.c
|
||||
|
||||
hostnm.lo: intrinsics/hostnm.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o hostnm.lo `test -f 'intrinsics/hostnm.c' || echo '$(srcdir)/'`intrinsics/hostnm.c
|
||||
|
||||
kill.lo: intrinsics/kill.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o kill.lo `test -f 'intrinsics/kill.c' || echo '$(srcdir)/'`intrinsics/kill.c
|
||||
|
||||
ierrno.lo: intrinsics/ierrno.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o ierrno.lo `test -f 'intrinsics/ierrno.c' || echo '$(srcdir)/'`intrinsics/ierrno.c
|
||||
|
||||
ishftc.lo: intrinsics/ishftc.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o ishftc.lo `test -f 'intrinsics/ishftc.c' || echo '$(srcdir)/'`intrinsics/ishftc.c
|
||||
|
||||
link.lo: intrinsics/link.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o link.lo `test -f 'intrinsics/link.c' || echo '$(srcdir)/'`intrinsics/link.c
|
||||
|
||||
mvbits.lo: intrinsics/mvbits.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o mvbits.lo `test -f 'intrinsics/mvbits.c' || echo '$(srcdir)/'`intrinsics/mvbits.c
|
||||
|
||||
pack_generic.lo: intrinsics/pack_generic.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o pack_generic.lo `test -f 'intrinsics/pack_generic.c' || echo '$(srcdir)/'`intrinsics/pack_generic.c
|
||||
|
||||
perror.lo: intrinsics/perror.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o perror.lo `test -f 'intrinsics/perror.c' || echo '$(srcdir)/'`intrinsics/perror.c
|
||||
|
||||
size.lo: intrinsics/size.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o size.lo `test -f 'intrinsics/size.c' || echo '$(srcdir)/'`intrinsics/size.c
|
||||
|
||||
sleep.lo: intrinsics/sleep.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o sleep.lo `test -f 'intrinsics/sleep.c' || echo '$(srcdir)/'`intrinsics/sleep.c
|
||||
|
||||
spread_generic.lo: intrinsics/spread_generic.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o spread_generic.lo `test -f 'intrinsics/spread_generic.c' || echo '$(srcdir)/'`intrinsics/spread_generic.c
|
||||
|
||||
|
|
@ -1276,6 +1316,9 @@ rand.lo: intrinsics/rand.c
|
|||
random.lo: intrinsics/random.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o random.lo `test -f 'intrinsics/random.c' || echo '$(srcdir)/'`intrinsics/random.c
|
||||
|
||||
rename.lo: intrinsics/rename.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o rename.lo `test -f 'intrinsics/rename.c' || echo '$(srcdir)/'`intrinsics/rename.c
|
||||
|
||||
reshape_generic.lo: intrinsics/reshape_generic.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o reshape_generic.lo `test -f 'intrinsics/reshape_generic.c' || echo '$(srcdir)/'`intrinsics/reshape_generic.c
|
||||
|
||||
|
|
@ -1285,9 +1328,15 @@ reshape_packed.lo: intrinsics/reshape_packed.c
|
|||
stat.lo: intrinsics/stat.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o stat.lo `test -f 'intrinsics/stat.c' || echo '$(srcdir)/'`intrinsics/stat.c
|
||||
|
||||
symlnk.lo: intrinsics/symlnk.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o symlnk.lo `test -f 'intrinsics/symlnk.c' || echo '$(srcdir)/'`intrinsics/symlnk.c
|
||||
|
||||
system_clock.lo: intrinsics/system_clock.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o system_clock.lo `test -f 'intrinsics/system_clock.c' || echo '$(srcdir)/'`intrinsics/system_clock.c
|
||||
|
||||
time.lo: intrinsics/time.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o time.lo `test -f 'intrinsics/time.c' || echo '$(srcdir)/'`intrinsics/time.c
|
||||
|
||||
transpose_generic.lo: intrinsics/transpose_generic.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o transpose_generic.lo `test -f 'intrinsics/transpose_generic.c' || echo '$(srcdir)/'`intrinsics/transpose_generic.c
|
||||
|
||||
|
|
@ -1609,7 +1658,7 @@ distclean-tags:
|
|||
distdir: $(DISTFILES)
|
||||
$(am__remove_distdir)
|
||||
mkdir $(distdir)
|
||||
$(mkdir_p) $(distdir)/.. $(distdir)/../config $(distdir)/m4
|
||||
$(mkdir_p) $(distdir)/.. $(distdir)/m4
|
||||
@srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`; \
|
||||
topsrcdirstrip=`echo "$(top_srcdir)" | sed 's|.|.|g'`; \
|
||||
list='$(DISTFILES)'; for file in $$list; do \
|
||||
|
|
|
|||
5
libgfortran/aclocal.m4
vendored
5
libgfortran/aclocal.m4
vendored
|
|
@ -1,4 +1,4 @@
|
|||
# generated automatically by aclocal 1.9.3 -*- Autoconf -*-
|
||||
# generated automatically by aclocal 1.9.4 -*- Autoconf -*-
|
||||
|
||||
# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004
|
||||
# Free Software Foundation, Inc.
|
||||
|
|
@ -40,7 +40,7 @@ AC_DEFUN([AM_AUTOMAKE_VERSION], [am__api_version="1.9"])
|
|||
# Call AM_AUTOMAKE_VERSION so it can be traced.
|
||||
# This function is AC_REQUIREd by AC_INIT_AUTOMAKE.
|
||||
AC_DEFUN([AM_SET_CURRENT_AUTOMAKE_VERSION],
|
||||
[AM_AUTOMAKE_VERSION([1.9.3])])
|
||||
[AM_AUTOMAKE_VERSION([1.9.4])])
|
||||
|
||||
# AM_AUX_DIR_EXPAND
|
||||
|
||||
|
|
@ -817,5 +817,4 @@ AC_SUBST([am__tar])
|
|||
AC_SUBST([am__untar])
|
||||
]) # _AM_PROG_TAR
|
||||
|
||||
m4_include([../config/no-executables.m4])
|
||||
m4_include([acinclude.m4])
|
||||
|
|
|
|||
820
libgfortran/configure
vendored
820
libgfortran/configure
vendored
File diff suppressed because it is too large
Load diff
|
|
@ -144,7 +144,7 @@ AC_TYPE_OFF_T
|
|||
|
||||
# check header files
|
||||
AC_STDC_HEADERS
|
||||
AC_HAVE_HEADERS(stdlib.h stdio.h string.h stddef.h math.h unistd.h)
|
||||
AC_HAVE_HEADERS(stdlib.h stdio.h string.h stddef.h math.h unistd.h signal.h)
|
||||
AC_CHECK_HEADERS(time.h sys/params.h sys/time.h sys/times.h sys/resource.h)
|
||||
AC_CHECK_HEADERS(sys/mman.h sys/types.h sys/stat.h ieeefp.h)
|
||||
AC_CHECK_HEADER([complex.h],[AC_DEFINE([HAVE_COMPLEX_H], [1], [complex.h exists])])
|
||||
|
|
@ -158,6 +158,8 @@ AC_CHECK_LIB([m],[csin],[need_math="no"],[need_math="yes"])
|
|||
|
||||
# Check for library functions.
|
||||
AC_CHECK_FUNCS(getrusage times mkstemp strtof snprintf)
|
||||
AC_CHECK_FUNCS(chdir strerror getlogin gethostname kill link symlink perror)
|
||||
AC_CHECK_FUNCS(sleep time)
|
||||
|
||||
# Check libc for getgid, getpid, getuid
|
||||
AC_CHECK_LIB([c],[getgid],[AC_DEFINE([HAVE_GETGID],[1],[libc includes getgid])])
|
||||
|
|
|
|||
118
libgfortran/intrinsics/chdir.c
Normal file
118
libgfortran/intrinsics/chdir.c
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
/* Implementation of the CHDIR intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
#ifdef HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
|
||||
/* SUBROUTINE CHDIR(DIR, STATUS)
|
||||
CHARACTER(len=*), INTENT(IN) :: DIR
|
||||
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
|
||||
|
||||
#ifdef HAVE_CHDIR
|
||||
extern void chdir_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type);
|
||||
iexport_proto(chdir_i4_sub);
|
||||
|
||||
void
|
||||
chdir_i4_sub (char *dir, GFC_INTEGER_4 *status, gfc_charlen_type dir_len)
|
||||
{
|
||||
int val;
|
||||
char *str;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (dir_len > 0 && dir[dir_len - 1] == ' ')
|
||||
dir_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str = gfc_alloca (dir_len + 1);
|
||||
memcpy (str, dir, dir_len);
|
||||
str[dir_len] = '\0';
|
||||
|
||||
val = chdir (str);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(chdir_i4_sub);
|
||||
|
||||
extern void chdir_i8_sub (char *, GFC_INTEGER_8 *, gfc_charlen_type);
|
||||
iexport_proto(chdir_i8_sub);
|
||||
|
||||
void
|
||||
chdir_i8_sub (char *dir, GFC_INTEGER_8 *status, gfc_charlen_type dir_len)
|
||||
{
|
||||
int val;
|
||||
char *str;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (dir_len > 0 && dir[dir_len - 1] == ' ')
|
||||
dir_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str = gfc_alloca (dir_len + 1);
|
||||
memcpy (str, dir, dir_len);
|
||||
str[dir_len] = '\0';
|
||||
|
||||
val = chdir (str);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(chdir_i8_sub);
|
||||
|
||||
extern GFC_INTEGER_4 chdir_i4 (char *, gfc_charlen_type);
|
||||
export_proto(chdir_i4);
|
||||
|
||||
GFC_INTEGER_4
|
||||
chdir_i4 (char *dir, gfc_charlen_type dir_len)
|
||||
{
|
||||
GFC_INTEGER_4 val;
|
||||
chdir_i4_sub (dir, &val, dir_len);
|
||||
return val;
|
||||
}
|
||||
|
||||
extern GFC_INTEGER_8 chdir_i8 (char *, gfc_charlen_type);
|
||||
export_proto(chdir_i8);
|
||||
|
||||
GFC_INTEGER_8
|
||||
chdir_i8 (char *dir, gfc_charlen_type dir_len)
|
||||
{
|
||||
GFC_INTEGER_8 val;
|
||||
chdir_i8_sub (dir, &val, dir_len);
|
||||
return val;
|
||||
}
|
||||
#endif
|
||||
67
libgfortran/intrinsics/gerror.c
Normal file
67
libgfortran/intrinsics/gerror.c
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
/* Implementation of the GERROR g77 intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#ifdef HAVE_STRING_H
|
||||
#include <string.h>
|
||||
#endif
|
||||
|
||||
|
||||
/* GERROR (MESSAGE), g77 intrinsic for retrieving the system error
|
||||
message corresponding to the last system error (C errno).
|
||||
CHARACTER(len=*), INTENT(OUT) :: MESSAGE */
|
||||
|
||||
#ifdef HAVE_STRERROR
|
||||
void PREFIX(gerror) (char *, gfc_charlen_type);
|
||||
export_proto_np(PREFIX(gerror));
|
||||
|
||||
void
|
||||
PREFIX(gerror) (char * msg, gfc_charlen_type msg_len)
|
||||
{
|
||||
int p_len;
|
||||
char *p;
|
||||
|
||||
memset (msg, ' ', msg_len); /* Blank the string. */
|
||||
|
||||
p = strerror (errno);
|
||||
if (p == NULL)
|
||||
return;
|
||||
|
||||
p_len = strlen (p);
|
||||
if (msg_len < p_len)
|
||||
memcpy (msg, p, msg_len);
|
||||
else
|
||||
memcpy (msg, p, p_len);
|
||||
}
|
||||
#endif
|
||||
65
libgfortran/intrinsics/getlog.c
Normal file
65
libgfortran/intrinsics/getlog.c
Normal file
|
|
@ -0,0 +1,65 @@
|
|||
/* Implementation of the GETLOG g77 intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#ifdef HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
|
||||
|
||||
/* GETLOG (LOGIN), g77 intrinsic for retrieving the login name for the
|
||||
process.
|
||||
CHARACTER(len=*), INTENT(OUT) :: LOGIN */
|
||||
|
||||
#ifdef HAVE_GETLOGIN
|
||||
void PREFIX(getlog) (char *, gfc_charlen_type);
|
||||
export_proto_np(PREFIX(getlog));
|
||||
|
||||
void
|
||||
PREFIX(getlog) (char * login, gfc_charlen_type login_len)
|
||||
{
|
||||
int p_len;
|
||||
char *p;
|
||||
|
||||
memset (login, ' ', login_len); /* Blank the string. */
|
||||
|
||||
p = getlogin ();
|
||||
if (p == NULL)
|
||||
return;
|
||||
|
||||
p_len = strlen (p);
|
||||
if (login_len < p_len)
|
||||
memcpy (login, p, login_len);
|
||||
else
|
||||
memcpy (login, p, p_len);
|
||||
}
|
||||
#endif
|
||||
110
libgfortran/intrinsics/hostnm.c
Normal file
110
libgfortran/intrinsics/hostnm.c
Normal file
|
|
@ -0,0 +1,110 @@
|
|||
/* Implementation of the HOSTNM intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <errno.h>
|
||||
#include <string.h>
|
||||
|
||||
#ifdef HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
/* SUBROUTINE HOSTNM(NAME, STATUS)
|
||||
CHARACTER(len=*), INTENT(OUT) :: NAME
|
||||
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
|
||||
|
||||
#ifdef HAVE_GETHOSTNAME
|
||||
extern void hostnm_i4_sub (char *, GFC_INTEGER_4 *, gfc_charlen_type);
|
||||
iexport_proto(hostnm_i4_sub);
|
||||
|
||||
void
|
||||
hostnm_i4_sub (char *name, GFC_INTEGER_4 *status, gfc_charlen_type name_len)
|
||||
{
|
||||
int val, i;
|
||||
char *p;
|
||||
|
||||
memset (name, ' ', name_len);
|
||||
p = gfc_alloca (name_len + 1);
|
||||
|
||||
val = gethostname (p, name_len);
|
||||
|
||||
if (val == 0)
|
||||
{
|
||||
i = -1;
|
||||
while (i < name_len && p[++i] != '\0')
|
||||
name[i] = p[i];
|
||||
}
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(hostnm_i4_sub);
|
||||
|
||||
extern void hostnm_i8_sub (char *, GFC_INTEGER_8 *, gfc_charlen_type);
|
||||
iexport_proto(hostnm_i8_sub);
|
||||
|
||||
void
|
||||
hostnm_i8_sub (char *name, GFC_INTEGER_8 *status, gfc_charlen_type name_len)
|
||||
{
|
||||
int val, i;
|
||||
char *p;
|
||||
|
||||
memset (name, ' ', name_len);
|
||||
p = gfc_alloca (name_len + 1);
|
||||
|
||||
val = gethostname (p, name_len);
|
||||
|
||||
if (val == 0)
|
||||
{
|
||||
i = -1;
|
||||
while (i < name_len && p[++i] != '\0')
|
||||
name[i] = p[i];
|
||||
}
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(hostnm_i8_sub);
|
||||
|
||||
extern GFC_INTEGER_4 hostnm (char *, gfc_charlen_type);
|
||||
export_proto(hostnm);
|
||||
|
||||
GFC_INTEGER_4
|
||||
hostnm (char *name, gfc_charlen_type name_len)
|
||||
{
|
||||
GFC_INTEGER_4 val;
|
||||
hostnm_i4_sub (name, &val, name_len);
|
||||
return val;
|
||||
}
|
||||
#endif
|
||||
57
libgfortran/intrinsics/ierrno.c
Normal file
57
libgfortran/intrinsics/ierrno.c
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
/* Implementation of the IERRNO intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
|
||||
/* INTEGER FUNCTION IERRNO() */
|
||||
|
||||
extern GFC_INTEGER_4 ierrno_i4 (void);
|
||||
export_proto(ierrno_i4);
|
||||
|
||||
GFC_INTEGER_4
|
||||
ierrno_i4 (void)
|
||||
{
|
||||
return (GFC_INTEGER_4) errno;
|
||||
}
|
||||
|
||||
extern GFC_INTEGER_8 ierrno_i8 (void);
|
||||
export_proto(ierrno_i8);
|
||||
|
||||
GFC_INTEGER_8
|
||||
ierrno_i8 (void)
|
||||
{
|
||||
return (GFC_INTEGER_8) errno;
|
||||
}
|
||||
107
libgfortran/intrinsics/kill.c
Normal file
107
libgfortran/intrinsics/kill.c
Normal file
|
|
@ -0,0 +1,107 @@
|
|||
/* Implementation of the KILL g77 intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#ifdef HAVE_SYS_TYPES_H
|
||||
#include <sys/types.h>
|
||||
#endif
|
||||
|
||||
#ifdef HAVE_SIGNAL_H
|
||||
#include <signal.h>
|
||||
#endif
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
/* SUBROUTINE KILL(PID, SIGNAL, STATUS)
|
||||
INTEGER, INTENT(IN) :: PID, SIGNAL
|
||||
INTEGER(KIND=1), INTENT(OUT), OPTIONAL :: STATUS
|
||||
|
||||
INTEGER(KIND=1) FUNCTION KILL(PID, SIGNAL)
|
||||
INTEGER, INTENT(IN) :: PID, SIGNAL */
|
||||
|
||||
#ifdef HAVE_KILL
|
||||
extern void kill_i4_sub (GFC_INTEGER_4 *, GFC_INTEGER_4 *, GFC_INTEGER_4 *);
|
||||
iexport_proto(kill_i4_sub);
|
||||
|
||||
void
|
||||
kill_i4_sub (GFC_INTEGER_4 *pid, GFC_INTEGER_4 *signal,
|
||||
GFC_INTEGER_4 *status)
|
||||
{
|
||||
int val;
|
||||
|
||||
val = kill (*pid, *signal);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(kill_i4_sub);
|
||||
|
||||
extern void kill_i8_sub (GFC_INTEGER_8 *, GFC_INTEGER_8 *, GFC_INTEGER_8 *);
|
||||
iexport_proto(kill_i8_sub);
|
||||
|
||||
void
|
||||
kill_i8_sub (GFC_INTEGER_8 *pid, GFC_INTEGER_8 *signal,
|
||||
GFC_INTEGER_8 *status)
|
||||
{
|
||||
int val;
|
||||
|
||||
val = kill (*pid, *signal);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(kill_i8_sub);
|
||||
|
||||
extern GFC_INTEGER_4 kill_i4 (GFC_INTEGER_4 *, GFC_INTEGER_4 *);
|
||||
export_proto(kill_i4);
|
||||
|
||||
GFC_INTEGER_4
|
||||
kill_i4 (GFC_INTEGER_4 *pid, GFC_INTEGER_4 *signal)
|
||||
{
|
||||
GFC_INTEGER_4 val;
|
||||
kill_i4_sub (pid, signal, &val);
|
||||
return val;
|
||||
}
|
||||
|
||||
extern GFC_INTEGER_8 kill_i8 (GFC_INTEGER_8 *, GFC_INTEGER_8 *);
|
||||
export_proto(kill_i8);
|
||||
|
||||
GFC_INTEGER_8
|
||||
kill_i8 (GFC_INTEGER_8 *pid, GFC_INTEGER_8 *signal)
|
||||
{
|
||||
GFC_INTEGER_8 val;
|
||||
kill_i8_sub (pid, signal, &val);
|
||||
return val;
|
||||
}
|
||||
#endif
|
||||
138
libgfortran/intrinsics/link.c
Normal file
138
libgfortran/intrinsics/link.c
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
/* Implementation of the LINK intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
#ifdef HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
|
||||
/* SUBROUTINE LINK(PATH1, PATH2, STATUS)
|
||||
CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2
|
||||
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
|
||||
|
||||
#ifdef HAVE_LINK
|
||||
extern void link_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
iexport_proto(link_i4_sub);
|
||||
|
||||
void
|
||||
link_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status,
|
||||
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
|
||||
{
|
||||
int val;
|
||||
char *str1, *str2;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (path1_len > 0 && path1[path1_len - 1] == ' ')
|
||||
path1_len--;
|
||||
while (path2_len > 0 && path2[path2_len - 1] == ' ')
|
||||
path2_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str1 = gfc_alloca (path1_len + 1);
|
||||
memcpy (str1, path1, path1_len);
|
||||
str1[path1_len] = '\0';
|
||||
|
||||
str2 = gfc_alloca (path2_len + 1);
|
||||
memcpy (str2, path2, path2_len);
|
||||
str2[path2_len] = '\0';
|
||||
|
||||
val = link (str1, str2);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(link_i4_sub);
|
||||
|
||||
extern void link_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
iexport_proto(link_i8_sub);
|
||||
|
||||
void
|
||||
link_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status,
|
||||
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
|
||||
{
|
||||
int val;
|
||||
char *str1, *str2;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (path1_len > 0 && path1[path1_len - 1] == ' ')
|
||||
path1_len--;
|
||||
while (path2_len > 0 && path2[path2_len - 1] == ' ')
|
||||
path2_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str1 = gfc_alloca (path1_len + 1);
|
||||
memcpy (str1, path1, path1_len);
|
||||
str1[path1_len] = '\0';
|
||||
|
||||
str2 = gfc_alloca (path2_len + 1);
|
||||
memcpy (str2, path2, path2_len);
|
||||
str2[path2_len] = '\0';
|
||||
|
||||
val = link (str1, str2);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(link_i8_sub);
|
||||
|
||||
extern GFC_INTEGER_4 link_i4 (char *, char *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
export_proto(link_i4);
|
||||
|
||||
GFC_INTEGER_4
|
||||
link_i4 (char *path1, char *path2, gfc_charlen_type path1_len,
|
||||
gfc_charlen_type path2_len)
|
||||
{
|
||||
GFC_INTEGER_4 val;
|
||||
link_i4_sub (path1, path2, &val, path1_len, path2_len);
|
||||
return val;
|
||||
}
|
||||
|
||||
extern GFC_INTEGER_8 link_i8 (char *, char *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
export_proto(link_i8);
|
||||
|
||||
GFC_INTEGER_8
|
||||
link_i8 (char *path1, char *path2, gfc_charlen_type path1_len,
|
||||
gfc_charlen_type path2_len)
|
||||
{
|
||||
GFC_INTEGER_8 val;
|
||||
link_i8_sub (path1, path2, &val, path1_len, path2_len);
|
||||
return val;
|
||||
}
|
||||
#endif
|
||||
64
libgfortran/intrinsics/perror.c
Normal file
64
libgfortran/intrinsics/perror.c
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
/* Implementation of the PERROR intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <stdio.h>
|
||||
#include <errno.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
|
||||
/* SUBROUTINE PERROR(STRING)
|
||||
CHARACTER(len=*), INTENT(IN) :: STRING */
|
||||
|
||||
#ifdef HAVE_PERROR
|
||||
extern void perror_sub (char *, gfc_charlen_type);
|
||||
iexport_proto(perror_sub);
|
||||
|
||||
void
|
||||
perror_sub (char *string, gfc_charlen_type string_len)
|
||||
{
|
||||
char * str;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (string_len > 0 && string[string_len - 1] == ' ')
|
||||
string_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str = gfc_alloca (string_len + 1);
|
||||
memcpy (str, string, string_len);
|
||||
str[string_len] = '\0';
|
||||
|
||||
perror (str);
|
||||
}
|
||||
iexport(perror_sub);
|
||||
#endif
|
||||
132
libgfortran/intrinsics/rename.c
Normal file
132
libgfortran/intrinsics/rename.c
Normal file
|
|
@ -0,0 +1,132 @@
|
|||
/* Implementation of the RENAME intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
/* SUBROUTINE RENAME(PATH1, PATH2, STATUS)
|
||||
CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2
|
||||
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
|
||||
|
||||
extern void rename_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
iexport_proto(rename_i4_sub);
|
||||
|
||||
void
|
||||
rename_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status,
|
||||
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
|
||||
{
|
||||
int val;
|
||||
char *str1, *str2;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (path1_len > 0 && path1[path1_len - 1] == ' ')
|
||||
path1_len--;
|
||||
while (path2_len > 0 && path2[path2_len - 1] == ' ')
|
||||
path2_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str1 = gfc_alloca (path1_len + 1);
|
||||
memcpy (str1, path1, path1_len);
|
||||
str1[path1_len] = '\0';
|
||||
|
||||
str2 = gfc_alloca (path2_len + 1);
|
||||
memcpy (str2, path2, path2_len);
|
||||
str2[path2_len] = '\0';
|
||||
|
||||
val = rename (str1, str2);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(rename_i4_sub);
|
||||
|
||||
extern void rename_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
iexport_proto(rename_i8_sub);
|
||||
|
||||
void
|
||||
rename_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status,
|
||||
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
|
||||
{
|
||||
int val;
|
||||
char *str1, *str2;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (path1_len > 0 && path1[path1_len - 1] == ' ')
|
||||
path1_len--;
|
||||
while (path2_len > 0 && path2[path2_len - 1] == ' ')
|
||||
path2_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str1 = gfc_alloca (path1_len + 1);
|
||||
memcpy (str1, path1, path1_len);
|
||||
str1[path1_len] = '\0';
|
||||
|
||||
str2 = gfc_alloca (path2_len + 1);
|
||||
memcpy (str2, path2, path2_len);
|
||||
str2[path2_len] = '\0';
|
||||
|
||||
val = rename (str1, str2);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(rename_i8_sub);
|
||||
|
||||
extern GFC_INTEGER_4 rename_i4 (char *, char *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
export_proto(rename_i4);
|
||||
|
||||
GFC_INTEGER_4
|
||||
rename_i4 (char *path1, char *path2, gfc_charlen_type path1_len,
|
||||
gfc_charlen_type path2_len)
|
||||
{
|
||||
GFC_INTEGER_4 val;
|
||||
rename_i4_sub (path1, path2, &val, path1_len, path2_len);
|
||||
return val;
|
||||
}
|
||||
|
||||
extern GFC_INTEGER_8 rename_i8 (char *, char *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
export_proto(rename_i8);
|
||||
|
||||
GFC_INTEGER_8
|
||||
rename_i8 (char *path1, char *path2, gfc_charlen_type path1_len,
|
||||
gfc_charlen_type path2_len)
|
||||
{
|
||||
GFC_INTEGER_8 val;
|
||||
rename_i8_sub (path1, path2, &val, path1_len, path2_len);
|
||||
return val;
|
||||
}
|
||||
68
libgfortran/intrinsics/sleep.c
Normal file
68
libgfortran/intrinsics/sleep.c
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
/* Implementation of the SLEEP intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
#ifdef HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
|
||||
/* SUBROUTINE SLEEP(SECONDS)
|
||||
INTEGER, INTENT(IN) :: SECONDS
|
||||
|
||||
A choice had to be made if SECONDS is negative. For g77, this is
|
||||
equivalent to SLEEP(0). */
|
||||
|
||||
#ifdef HAVE_SLEEP
|
||||
extern void sleep_i4_sub (GFC_INTEGER_4 *);
|
||||
iexport_proto(sleep_i4_sub);
|
||||
|
||||
void
|
||||
sleep_i4_sub (GFC_INTEGER_4 *seconds)
|
||||
{
|
||||
sleep (*seconds < 0 ? 0 : (unsigned int) *seconds);
|
||||
}
|
||||
iexport(sleep_i4_sub);
|
||||
|
||||
extern void sleep_i8_sub (GFC_INTEGER_8 *);
|
||||
iexport_proto(sleep_i8_sub);
|
||||
|
||||
void
|
||||
sleep_i8_sub (GFC_INTEGER_8 *seconds)
|
||||
{
|
||||
sleep (*seconds < 0 ? 0 : (unsigned int) *seconds);
|
||||
}
|
||||
iexport(sleep_i8_sub);
|
||||
#endif
|
||||
138
libgfortran/intrinsics/symlnk.c
Normal file
138
libgfortran/intrinsics/symlnk.c
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
/* Implementation of the SYMLNK intrinsic.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <errno.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
#ifdef HAVE_UNISTD_H
|
||||
#include <unistd.h>
|
||||
#endif
|
||||
|
||||
/* SUBROUTINE SYMLNK(PATH1, PATH2, STATUS)
|
||||
CHARACTER(len=*), INTENT(IN) :: PATH1, PATH2
|
||||
INTEGER, INTENT(OUT), OPTIONAL :: STATUS */
|
||||
|
||||
#ifdef HAVE_SYMLINK
|
||||
extern void symlnk_i4_sub (char *, char *, GFC_INTEGER_4 *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
iexport_proto(symlnk_i4_sub);
|
||||
|
||||
void
|
||||
symlnk_i4_sub (char *path1, char *path2, GFC_INTEGER_4 *status,
|
||||
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
|
||||
{
|
||||
int val;
|
||||
char *str1, *str2;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (path1_len > 0 && path1[path1_len - 1] == ' ')
|
||||
path1_len--;
|
||||
while (path2_len > 0 && path2[path2_len - 1] == ' ')
|
||||
path2_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str1 = gfc_alloca (path1_len + 1);
|
||||
memcpy (str1, path1, path1_len);
|
||||
str1[path1_len] = '\0';
|
||||
|
||||
str2 = gfc_alloca (path2_len + 1);
|
||||
memcpy (str2, path2, path2_len);
|
||||
str2[path2_len] = '\0';
|
||||
|
||||
val = symlink (str1, str2);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(symlnk_i4_sub);
|
||||
|
||||
extern void symlnk_i8_sub (char *, char *, GFC_INTEGER_8 *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
iexport_proto(symlnk_i8_sub);
|
||||
|
||||
void
|
||||
symlnk_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status,
|
||||
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
|
||||
{
|
||||
int val;
|
||||
char *str1, *str2;
|
||||
|
||||
/* Trim trailing spaces from paths. */
|
||||
while (path1_len > 0 && path1[path1_len - 1] == ' ')
|
||||
path1_len--;
|
||||
while (path2_len > 0 && path2[path2_len - 1] == ' ')
|
||||
path2_len--;
|
||||
|
||||
/* Make a null terminated copy of the strings. */
|
||||
str1 = gfc_alloca (path1_len + 1);
|
||||
memcpy (str1, path1, path1_len);
|
||||
str1[path1_len] = '\0';
|
||||
|
||||
str2 = gfc_alloca (path2_len + 1);
|
||||
memcpy (str2, path2, path2_len);
|
||||
str2[path2_len] = '\0';
|
||||
|
||||
val = symlink (str1, str2);
|
||||
|
||||
if (status != NULL)
|
||||
*status = (val == 0) ? 0 : errno;
|
||||
}
|
||||
iexport(symlnk_i8_sub);
|
||||
|
||||
extern GFC_INTEGER_4 symlnk_i4 (char *, char *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
export_proto(symlnk_i4);
|
||||
|
||||
GFC_INTEGER_4
|
||||
symlnk_i4 (char *path1, char *path2, gfc_charlen_type path1_len,
|
||||
gfc_charlen_type path2_len)
|
||||
{
|
||||
GFC_INTEGER_4 val;
|
||||
symlnk_i4_sub (path1, path2, &val, path1_len, path2_len);
|
||||
return val;
|
||||
}
|
||||
|
||||
extern GFC_INTEGER_8 symlnk_i8 (char *, char *, gfc_charlen_type,
|
||||
gfc_charlen_type);
|
||||
export_proto(symlnk_i8);
|
||||
|
||||
GFC_INTEGER_8
|
||||
symlnk_i8 (char *path1, char *path2, gfc_charlen_type path1_len,
|
||||
gfc_charlen_type path2_len)
|
||||
{
|
||||
GFC_INTEGER_8 val;
|
||||
symlnk_i8_sub (path1, path2, &val, path1_len, path2_len);
|
||||
return val;
|
||||
}
|
||||
#endif
|
||||
72
libgfortran/intrinsics/time.c
Normal file
72
libgfortran/intrinsics/time.c
Normal file
|
|
@ -0,0 +1,72 @@
|
|||
/* Implementation of the TIME and TIME8 g77 intrinsics.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#ifdef TIME_WITH_SYS_TIME
|
||||
# include <sys/time.h>
|
||||
# include <time.h>
|
||||
#else
|
||||
# if HAVE_SYS_TIME_H
|
||||
# include <sys/time.h>
|
||||
# else
|
||||
# ifdef HAVE_TIME_H
|
||||
# include <time.h>
|
||||
# endif
|
||||
# endif
|
||||
#endif
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
|
||||
/* INTEGER(KIND=4) FUNCTION TIME() */
|
||||
|
||||
#ifdef HAVE_TIME
|
||||
extern GFC_INTEGER_4 time_func (void);
|
||||
export_proto(time_func);
|
||||
|
||||
GFC_INTEGER_4
|
||||
time_func (void)
|
||||
{
|
||||
return (GFC_INTEGER_4) time (NULL);
|
||||
}
|
||||
|
||||
/* INTEGER(KIND=8) FUNCTION TIME8() */
|
||||
|
||||
extern GFC_INTEGER_8 time8_func (void);
|
||||
export_proto(time8_func);
|
||||
|
||||
GFC_INTEGER_8
|
||||
time8_func (void)
|
||||
{
|
||||
return (GFC_INTEGER_8) time (NULL);
|
||||
}
|
||||
#endif
|
||||
Loading…
Add table
Reference in a new issue