mirror of git://gcc.gnu.org/git/gcc.git
fget.c: New file.
* intrinsics/fget.c: New file. * intrinsics/ftell.c: New file. * io/unix.c (stream_offset): New function. * io/io.h: Add prototype for stream_offset. * Makefile.am: Add intrinsics/fget.c and intrinsics/ftell.c. * Makefile.in: Regenerate. * intrinsic.c (add_functions): Add COMPLEX, FTELL, FGETC, FGET, FPUTC, FPUT, AND, XOR and OR intrinsic functions. (add_subroutines): Add FGETC, FGET, FPUTC, FPUT and FTELL intrinsic subroutines. * gfortran.h: Add GFC_ISYM_AND, GFC_ISYM_COMPLEX, GFC_ISYM_FGET, GFC_ISYM_FGETC, GFC_ISYM_FPUT, GFC_ISYM_FPUTC, GFC_ISYM_FTELL, GFC_ISYM_OR, GFC_ISYM_XOR. * iresolve.c (gfc_resolve_and, gfc_resolve_complex, gfc_resolve_or, gfc_resolve_fgetc, gfc_resolve_fget, gfc_resolve_fputc, gfc_resolve_fput, gfc_resolve_ftell, gfc_resolve_xor, gfc_resolve_fgetc_sub, gfc_resolve_fget_sub, gfc_resolve_fputc_sub, gfc_resolve_fput_sub, gfc_resolve_ftell_sub): New functions. * check.c (gfc_check_complex, gfc_check_fgetputc_sub, gfc_check_fgetputc, gfc_check_fgetput_sub, gfc_check_fgetput, gfc_check_ftell, gfc_check_ftell_sub, gfc_check_and): New functions. * simplify.c (gfc_simplify_and, gfc_simplify_complex, gfc_simplify_or, gfc_simplify_xor): New functions. * trans-intrinsic.c (gfc_conv_intrinsic_function): Add cases for GFC_ISYM_AND, GFC_ISYM_COMPLEX, GFC_ISYM_FGET, GFC_ISYM_FGETC, GFC_ISYM_FPUT, GFC_ISYM_FPUTC, GFC_ISYM_FTELL, GFC_ISYM_OR and GFC_ISYM_XOR. * intrinsic.h: Add prototypes for all functions added to iresolve.c, simplify.c and check.c. * gfortran.dg/complex_intrinsic_1.f90: New test. * gfortran.dg/complex_intrinsic_2.f90: New test. * gfortran.dg/fgetc_1.f90: New test. * gfortran.dg/fgetc_2.f90: New test. * gfortran.dg/fgetc_3.f90: New test. * gfortran.dg/ftell_1.f90: New test. * gfortran.dg/ftell_2.f90: New test. * gfortran.dg/gnu_logical_1.F: New test. * gfortran.dg/gnu_logical_2.f90: New test. From-SVN: r106859
This commit is contained in:
Francois-Xavier Coudert
François-Xavier Coudert
parent
a8bd670c5a
commit
5d723e5434
|
|
@ -1,3 +1,30 @@
|
|||
2005-11-13 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* intrinsic.c (add_functions): Add COMPLEX, FTELL, FGETC, FGET,
|
||||
FPUTC, FPUT, AND, XOR and OR intrinsic functions.
|
||||
(add_subroutines): Add FGETC, FGET, FPUTC, FPUT and FTELL intrinsic
|
||||
subroutines.
|
||||
* gfortran.h: Add GFC_ISYM_AND, GFC_ISYM_COMPLEX, GFC_ISYM_FGET,
|
||||
GFC_ISYM_FGETC, GFC_ISYM_FPUT, GFC_ISYM_FPUTC, GFC_ISYM_FTELL,
|
||||
GFC_ISYM_OR, GFC_ISYM_XOR.
|
||||
* iresolve.c (gfc_resolve_and, gfc_resolve_complex,
|
||||
gfc_resolve_or, gfc_resolve_fgetc, gfc_resolve_fget,
|
||||
gfc_resolve_fputc, gfc_resolve_fput, gfc_resolve_ftell,
|
||||
gfc_resolve_xor, gfc_resolve_fgetc_sub, gfc_resolve_fget_sub,
|
||||
gfc_resolve_fputc_sub, gfc_resolve_fput_sub, gfc_resolve_ftell_sub):
|
||||
New functions.
|
||||
* check.c (gfc_check_complex, gfc_check_fgetputc_sub,
|
||||
gfc_check_fgetputc, gfc_check_fgetput_sub, gfc_check_fgetput,
|
||||
gfc_check_ftell, gfc_check_ftell_sub, gfc_check_and): New functions.
|
||||
* simplify.c (gfc_simplify_and, gfc_simplify_complex, gfc_simplify_or,
|
||||
gfc_simplify_xor): New functions.
|
||||
* trans-intrinsic.c (gfc_conv_intrinsic_function): Add cases for
|
||||
GFC_ISYM_AND, GFC_ISYM_COMPLEX, GFC_ISYM_FGET, GFC_ISYM_FGETC,
|
||||
GFC_ISYM_FPUT, GFC_ISYM_FPUTC, GFC_ISYM_FTELL, GFC_ISYM_OR and
|
||||
GFC_ISYM_XOR.
|
||||
* intrinsic.h: Add prototypes for all functions added to iresolve.c,
|
||||
simplify.c and check.c.
|
||||
|
||||
2005-11-10 Paul Thomas <pault@gcc.gnu.org>
|
||||
Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
|
|
|
|||
|
|
@ -631,6 +631,33 @@ gfc_check_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * kind)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_complex (gfc_expr * x, gfc_expr * y)
|
||||
{
|
||||
if (x->ts.type != BT_INTEGER && x->ts.type != BT_REAL)
|
||||
{
|
||||
gfc_error (
|
||||
"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
|
||||
gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &x->where);
|
||||
return FAILURE;
|
||||
}
|
||||
if (scalar_check (x, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (y->ts.type != BT_INTEGER && y->ts.type != BT_REAL)
|
||||
{
|
||||
gfc_error (
|
||||
"'%s' argument of '%s' intrinsic at %L must be INTEGER or REAL",
|
||||
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &y->where);
|
||||
return FAILURE;
|
||||
}
|
||||
if (scalar_check (y, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_count (gfc_expr * mask, gfc_expr * dim)
|
||||
{
|
||||
|
|
@ -2003,6 +2030,64 @@ gfc_check_spread (gfc_expr * source, gfc_expr * dim, gfc_expr * ncopies)
|
|||
}
|
||||
|
||||
|
||||
/* Functions for checking FGETC, FPUTC, FGET and FPUT (subroutines and
|
||||
functions). */
|
||||
try
|
||||
gfc_check_fgetputc_sub (gfc_expr * unit, gfc_expr * c, gfc_expr * status)
|
||||
{
|
||||
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (unit, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (c, 1, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (status == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (type_check (status, 2, BT_INTEGER) == FAILURE
|
||||
|| kind_value_check (status, 2, gfc_default_integer_kind) == FAILURE
|
||||
|| scalar_check (status, 2) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_fgetputc (gfc_expr * unit, gfc_expr * c)
|
||||
{
|
||||
return gfc_check_fgetputc_sub (unit, c, NULL);
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_fgetput_sub (gfc_expr * c, gfc_expr * status)
|
||||
{
|
||||
if (type_check (c, 0, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (status == NULL)
|
||||
return SUCCESS;
|
||||
|
||||
if (type_check (status, 1, BT_INTEGER) == FAILURE
|
||||
|| kind_value_check (status, 1, gfc_default_integer_kind) == FAILURE
|
||||
|| scalar_check (status, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_fgetput (gfc_expr * c)
|
||||
{
|
||||
return gfc_check_fgetput_sub (c, NULL);
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_fstat (gfc_expr * unit, gfc_expr * array)
|
||||
{
|
||||
|
|
@ -2053,6 +2138,38 @@ gfc_check_fstat_sub (gfc_expr * unit, gfc_expr * array, gfc_expr * status)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_ftell (gfc_expr * unit)
|
||||
{
|
||||
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (unit, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_ftell_sub (gfc_expr * unit, gfc_expr * offset)
|
||||
{
|
||||
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (unit, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (offset, 1, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (offset, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_stat (gfc_expr * name, gfc_expr * array)
|
||||
{
|
||||
|
|
@ -2922,3 +3039,42 @@ gfc_check_system_sub (gfc_expr * cmd, gfc_expr * status)
|
|||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
/* This is used for the GNU intrinsics AND, OR and XOR. */
|
||||
try
|
||||
gfc_check_and (gfc_expr * i, gfc_expr * j)
|
||||
{
|
||||
if (i->ts.type != BT_INTEGER && i->ts.type != BT_LOGICAL)
|
||||
{
|
||||
gfc_error (
|
||||
"'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
|
||||
gfc_current_intrinsic_arg[0], gfc_current_intrinsic, &i->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (j->ts.type != BT_INTEGER && j->ts.type != BT_LOGICAL)
|
||||
{
|
||||
gfc_error (
|
||||
"'%s' argument of '%s' intrinsic at %L must be INTEGER or LOGICAL",
|
||||
gfc_current_intrinsic_arg[1], gfc_current_intrinsic, &j->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (i->ts.type != j->ts.type)
|
||||
{
|
||||
gfc_error ("'%s' and '%s' arguments of '%s' intrinsic at %L must "
|
||||
"have the same type", gfc_current_intrinsic_arg[0],
|
||||
gfc_current_intrinsic_arg[1], gfc_current_intrinsic,
|
||||
&j->where);
|
||||
return FAILURE;
|
||||
}
|
||||
|
||||
if (scalar_check (i, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (j, 1) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -291,6 +291,7 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_ALL,
|
||||
GFC_ISYM_ALLOCATED,
|
||||
GFC_ISYM_ANINT,
|
||||
GFC_ISYM_AND,
|
||||
GFC_ISYM_ANY,
|
||||
GFC_ISYM_ASIN,
|
||||
GFC_ISYM_ASINH,
|
||||
|
|
@ -310,6 +311,7 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_CHDIR,
|
||||
GFC_ISYM_CMPLX,
|
||||
GFC_ISYM_COMMAND_ARGUMENT_COUNT,
|
||||
GFC_ISYM_COMPLEX,
|
||||
GFC_ISYM_CONJG,
|
||||
GFC_ISYM_COS,
|
||||
GFC_ISYM_COSH,
|
||||
|
|
@ -327,10 +329,15 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_EXP,
|
||||
GFC_ISYM_EXPONENT,
|
||||
GFC_ISYM_FDATE,
|
||||
GFC_ISYM_FGET,
|
||||
GFC_ISYM_FGETC,
|
||||
GFC_ISYM_FLOOR,
|
||||
GFC_ISYM_FNUM,
|
||||
GFC_ISYM_FPUT,
|
||||
GFC_ISYM_FPUTC,
|
||||
GFC_ISYM_FRACTION,
|
||||
GFC_ISYM_FSTAT,
|
||||
GFC_ISYM_FTELL,
|
||||
GFC_ISYM_GETCWD,
|
||||
GFC_ISYM_GETGID,
|
||||
GFC_ISYM_GETPID,
|
||||
|
|
@ -379,6 +386,7 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_NEAREST,
|
||||
GFC_ISYM_NINT,
|
||||
GFC_ISYM_NOT,
|
||||
GFC_ISYM_OR,
|
||||
GFC_ISYM_PACK,
|
||||
GFC_ISYM_PRESENT,
|
||||
GFC_ISYM_PRODUCT,
|
||||
|
|
@ -421,6 +429,7 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_UNLINK,
|
||||
GFC_ISYM_UNPACK,
|
||||
GFC_ISYM_VERIFY,
|
||||
GFC_ISYM_XOR,
|
||||
GFC_ISYM_CONVERSION
|
||||
};
|
||||
typedef enum gfc_generic_isym_id gfc_generic_isym_id;
|
||||
|
|
|
|||
|
|
@ -1152,6 +1152,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("cmplx", GFC_ISYM_CMPLX, GFC_STD_F77);
|
||||
|
||||
add_sym_2 ("complex", 1, 1, BT_COMPLEX, dz, GFC_STD_GNU,
|
||||
gfc_check_complex, gfc_simplify_complex, gfc_resolve_complex,
|
||||
x, BT_UNKNOWN, dr, REQUIRED, y, BT_UNKNOWN, dr, REQUIRED);
|
||||
|
||||
make_generic ("complex", GFC_ISYM_COMPLEX, GFC_STD_GNU);
|
||||
|
||||
/* Making dcmplx a specific of cmplx causes cmplx to return a double
|
||||
complex instead of the default complex. */
|
||||
|
||||
|
|
@ -1365,6 +1371,36 @@ add_functions (void)
|
|||
|
||||
make_generic ("fstat", GFC_ISYM_FSTAT, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("ftell", 0, 1, BT_INTEGER, ii, GFC_STD_GNU,
|
||||
gfc_check_ftell, NULL, gfc_resolve_ftell,
|
||||
ut, BT_INTEGER, di, REQUIRED);
|
||||
|
||||
make_generic ("ftell", GFC_ISYM_FTELL, GFC_STD_GNU);
|
||||
|
||||
add_sym_2 ("fgetc", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
gfc_check_fgetputc, NULL, gfc_resolve_fgetc,
|
||||
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("fgetc", GFC_ISYM_FGETC, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("fget", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
gfc_check_fgetput, NULL, gfc_resolve_fget,
|
||||
c, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("fget", GFC_ISYM_FGET, GFC_STD_GNU);
|
||||
|
||||
add_sym_2 ("fputc", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
gfc_check_fgetputc, NULL, gfc_resolve_fputc,
|
||||
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("fputc", GFC_ISYM_FPUTC, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("fput", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
gfc_check_fgetput, NULL, gfc_resolve_fput,
|
||||
c, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
make_generic ("fput", GFC_ISYM_FPUT, GFC_STD_GNU);
|
||||
|
||||
/* Unix IDs (g77 compatibility) */
|
||||
add_sym_1 ("getcwd", 0, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
NULL, NULL, gfc_resolve_getcwd,
|
||||
|
|
@ -1411,6 +1447,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("iand", GFC_ISYM_IAND, GFC_STD_F95);
|
||||
|
||||
add_sym_2 ("and", 1, 0, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_and, gfc_simplify_and, gfc_resolve_and,
|
||||
i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
|
||||
|
||||
make_generic ("and", GFC_ISYM_AND, GFC_STD_GNU);
|
||||
|
||||
add_sym_0 ("iargc", 1, 1, BT_INTEGER, di, GFC_STD_GNU,
|
||||
NULL, NULL, NULL);
|
||||
|
||||
|
|
@ -1453,6 +1495,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("ieor", GFC_ISYM_IEOR, GFC_STD_F95);
|
||||
|
||||
add_sym_2 ("xor", 1, 0, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_and, gfc_simplify_xor, gfc_resolve_xor,
|
||||
i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
|
||||
|
||||
make_generic ("xor", GFC_ISYM_XOR, GFC_STD_GNU);
|
||||
|
||||
add_sym_0 ("ierrno", 1, 0, BT_INTEGER, di, GFC_STD_GNU,
|
||||
NULL, NULL, gfc_resolve_ierrno);
|
||||
|
||||
|
|
@ -1485,6 +1533,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("ior", GFC_ISYM_IOR, GFC_STD_F95);
|
||||
|
||||
add_sym_2 ("or", 1, 0, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_and, gfc_simplify_or, gfc_resolve_or,
|
||||
i, BT_UNKNOWN, 0, REQUIRED, j, BT_UNKNOWN, 0, REQUIRED);
|
||||
|
||||
make_generic ("or", GFC_ISYM_OR, GFC_STD_GNU);
|
||||
|
||||
/* The following function is for G77 compatibility. */
|
||||
add_sym_1 ("irand", 0, 1, BT_INTEGER, 4, GFC_STD_GNU,
|
||||
gfc_check_irand, NULL, NULL,
|
||||
|
|
@ -2158,7 +2212,7 @@ add_subroutines (void)
|
|||
*com = "command", *length = "length", *st = "status",
|
||||
*val = "value", *num = "number", *name = "name",
|
||||
*trim_name = "trim_name", *ut = "unit", *han = "handler",
|
||||
*sec = "seconds", *res = "result";
|
||||
*sec = "seconds", *res = "result", *of = "offset";
|
||||
|
||||
int di, dr, dc, dl, ii;
|
||||
|
||||
|
|
@ -2278,13 +2332,35 @@ add_subroutines (void)
|
|||
|
||||
make_noreturn();
|
||||
|
||||
add_sym_3s ("fgetc", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_fgetputc_sub, NULL, gfc_resolve_fgetc_sub,
|
||||
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
|
||||
st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_2s ("fget", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_fgetput_sub, NULL, gfc_resolve_fget_sub,
|
||||
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_1s ("flush", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_flush, NULL, gfc_resolve_flush,
|
||||
c, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_3s ("fputc", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_fgetputc_sub, NULL, gfc_resolve_fputc_sub,
|
||||
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED,
|
||||
st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_2s ("fput", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_fgetput_sub, NULL, gfc_resolve_fput_sub,
|
||||
c, BT_CHARACTER, dc, REQUIRED, st, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_1s ("free", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU, gfc_check_free,
|
||||
NULL, gfc_resolve_free, c, BT_INTEGER, ii, REQUIRED);
|
||||
|
||||
add_sym_2s ("ftell", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_ftell_sub, NULL, gfc_resolve_ftell_sub,
|
||||
ut, BT_INTEGER, di, REQUIRED, of, BT_INTEGER, ii, REQUIRED);
|
||||
|
||||
add_sym_2s ("hostnm", 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);
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@ 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_complex (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_count (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_cshift (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ctime (gfc_expr *);
|
||||
|
|
@ -51,7 +52,10 @@ try gfc_check_digits (gfc_expr *);
|
|||
try gfc_check_dot_product (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_eoshift (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_etime (gfc_expr *);
|
||||
try gfc_check_fgetputc (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_fgetput (gfc_expr *);
|
||||
try gfc_check_fstat (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ftell (gfc_expr *);
|
||||
try gfc_check_fn_c (gfc_expr *);
|
||||
try gfc_check_fn_r (gfc_expr *);
|
||||
try gfc_check_fn_rc (gfc_expr *);
|
||||
|
|
@ -61,6 +65,7 @@ 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 *);
|
||||
try gfc_check_and (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ibclr (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ibits (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ibset (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -138,10 +143,10 @@ try gfc_check_ctime_sub (gfc_expr *, 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_fdate_sub (gfc_expr *);
|
||||
try gfc_check_flush (gfc_expr *);
|
||||
try gfc_check_free (gfc_expr *);
|
||||
try gfc_check_fstat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_fdate_sub (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 *,
|
||||
|
|
@ -149,6 +154,9 @@ try gfc_check_mvbits (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_fgetputc_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_fgetput_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ftell_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 *);
|
||||
|
|
@ -177,6 +185,7 @@ gfc_expr *gfc_simplify_aint (gfc_expr *, gfc_expr *);
|
|||
gfc_expr *gfc_simplify_dint (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_anint (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_dnint (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_and (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_asin (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_asinh (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_atan (gfc_expr *);
|
||||
|
|
@ -187,6 +196,7 @@ gfc_expr *gfc_simplify_btest (gfc_expr *, gfc_expr *);
|
|||
gfc_expr *gfc_simplify_ceiling (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_char (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_cmplx (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_complex (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_conjg (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_cos (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_cosh (gfc_expr *);
|
||||
|
|
@ -240,6 +250,7 @@ gfc_expr *gfc_simplify_nint (gfc_expr *, gfc_expr *);
|
|||
gfc_expr *gfc_simplify_null (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_idnint (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_not (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_or (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_precision (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_radix (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_range (gfc_expr *);
|
||||
|
|
@ -268,6 +279,7 @@ gfc_expr *gfc_simplify_tiny (gfc_expr *);
|
|||
gfc_expr *gfc_simplify_trim (gfc_expr *);
|
||||
gfc_expr *gfc_simplify_ubound (gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_verify (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
gfc_expr *gfc_simplify_xor (gfc_expr *, gfc_expr *);
|
||||
|
||||
/* Constant conversion simplification. */
|
||||
gfc_expr *gfc_convert_constant (gfc_expr *, bt, int);
|
||||
|
|
@ -283,6 +295,7 @@ void gfc_resolve_dint (gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_all (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_anint (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_dnint (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_and (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_any (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_asin (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_asinh (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -296,6 +309,7 @@ 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_complex (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_conjg (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_cos (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_cosh (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -316,6 +330,11 @@ void gfc_resolve_floor (gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_fnum (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_fraction (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_fstat (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ftell (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_fgetc (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_fget (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_fputc (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_fput (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_g77_math1 (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_getcwd (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_getgid (gfc_expr *);
|
||||
|
|
@ -358,6 +377,7 @@ void gfc_resolve_modulo (gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_nearest (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_nint (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_not (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_or (gfc_expr *, 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 *);
|
||||
|
|
@ -398,6 +418,7 @@ void gfc_resolve_umask (gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_unlink (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_unpack (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_verify (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_xor (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
|
||||
|
||||
/* Intrinsic subroutine resolution. */
|
||||
|
|
@ -406,10 +427,15 @@ void gfc_resolve_chdir_sub (gfc_code *);
|
|||
void gfc_resolve_cpu_time (gfc_code *);
|
||||
void gfc_resolve_ctime_sub (gfc_code *);
|
||||
void gfc_resolve_exit (gfc_code *);
|
||||
void gfc_resolve_fdate_sub (gfc_code *);
|
||||
void gfc_resolve_flush (gfc_code *);
|
||||
void gfc_resolve_free (gfc_code *);
|
||||
void gfc_resolve_fstat_sub (gfc_code *);
|
||||
void gfc_resolve_fdate_sub (gfc_code *);
|
||||
void gfc_resolve_ftell_sub (gfc_code *);
|
||||
void gfc_resolve_fgetc_sub (gfc_code *);
|
||||
void gfc_resolve_fget_sub (gfc_code *);
|
||||
void gfc_resolve_fputc_sub (gfc_code *);
|
||||
void gfc_resolve_fput_sub (gfc_code *);
|
||||
void gfc_resolve_gerror (gfc_code *);
|
||||
void gfc_resolve_getarg (gfc_code *);
|
||||
void gfc_resolve_getcwd_sub (gfc_code *);
|
||||
|
|
|
|||
|
|
@ -117,6 +117,26 @@ gfc_resolve_aimag (gfc_expr * f, gfc_expr * x)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_and (gfc_expr * f, gfc_expr * i, gfc_expr * j)
|
||||
{
|
||||
f->ts.type = i->ts.type;
|
||||
f->ts.kind = gfc_kind_max (i,j);
|
||||
|
||||
if (i->ts.kind != j->ts.kind)
|
||||
{
|
||||
if (i->ts.kind == gfc_kind_max (i,j))
|
||||
gfc_convert_type(j, &i->ts, 2);
|
||||
else
|
||||
gfc_convert_type(i, &j->ts, 2);
|
||||
}
|
||||
|
||||
f->value.function.name = gfc_get_string ("__and_%c%d",
|
||||
gfc_type_letter (i->ts.type),
|
||||
f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_aint (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
|
||||
{
|
||||
|
|
@ -356,6 +376,36 @@ gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y)
|
|||
gfc_resolve_cmplx (f, x, y, gfc_int_expr (gfc_default_double_kind));
|
||||
}
|
||||
|
||||
void
|
||||
gfc_resolve_complex (gfc_expr * f, gfc_expr * x, gfc_expr * y)
|
||||
{
|
||||
int kind;
|
||||
|
||||
if (x->ts.type == BT_INTEGER)
|
||||
{
|
||||
if (y->ts.type == BT_INTEGER)
|
||||
kind = gfc_default_real_kind;
|
||||
else
|
||||
kind = y->ts.kind;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (y->ts.type == BT_REAL)
|
||||
kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
|
||||
else
|
||||
kind = x->ts.kind;
|
||||
}
|
||||
|
||||
f->ts.type = BT_COMPLEX;
|
||||
f->ts.kind = kind;
|
||||
|
||||
f->value.function.name =
|
||||
gfc_get_string ("__cmplx1_%d_%c%d_%c%d", f->ts.kind,
|
||||
gfc_type_letter (x->ts.type), x->ts.kind,
|
||||
gfc_type_letter (y->ts.type), y->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_conjg (gfc_expr * f, gfc_expr * x)
|
||||
{
|
||||
|
|
@ -1177,6 +1227,26 @@ gfc_resolve_not (gfc_expr * f, gfc_expr * i)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_or (gfc_expr * f, gfc_expr * i, gfc_expr * j)
|
||||
{
|
||||
f->ts.type = i->ts.type;
|
||||
f->ts.kind = gfc_kind_max (i,j);
|
||||
|
||||
if (i->ts.kind != j->ts.kind)
|
||||
{
|
||||
if (i->ts.kind == gfc_kind_max (i,j))
|
||||
gfc_convert_type(j, &i->ts, 2);
|
||||
else
|
||||
gfc_convert_type(i, &j->ts, 2);
|
||||
}
|
||||
|
||||
f->value.function.name = gfc_get_string ("__or_%c%d",
|
||||
gfc_type_letter (i->ts.type),
|
||||
f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_pack (gfc_expr * f, gfc_expr * array, gfc_expr * mask,
|
||||
gfc_expr * vector ATTRIBUTE_UNUSED)
|
||||
|
|
@ -1553,6 +1623,84 @@ gfc_resolve_fstat (gfc_expr * f, gfc_expr * n, gfc_expr * a ATTRIBUTE_UNUSED)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_fgetc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
|
||||
{
|
||||
gfc_typespec ts;
|
||||
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_c_int_kind;
|
||||
if (u->ts.kind != gfc_c_int_kind)
|
||||
{
|
||||
ts.type = BT_INTEGER;
|
||||
ts.kind = gfc_c_int_kind;
|
||||
ts.derived = NULL;
|
||||
ts.cl = NULL;
|
||||
gfc_convert_type (u, &ts, 2);
|
||||
}
|
||||
|
||||
f->value.function.name = gfc_get_string (PREFIX("fgetc"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_fget (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_c_int_kind;
|
||||
f->value.function.name = gfc_get_string (PREFIX("fget"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_fputc (gfc_expr * f, gfc_expr * u, gfc_expr * c ATTRIBUTE_UNUSED)
|
||||
{
|
||||
gfc_typespec ts;
|
||||
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_c_int_kind;
|
||||
if (u->ts.kind != gfc_c_int_kind)
|
||||
{
|
||||
ts.type = BT_INTEGER;
|
||||
ts.kind = gfc_c_int_kind;
|
||||
ts.derived = NULL;
|
||||
ts.cl = NULL;
|
||||
gfc_convert_type (u, &ts, 2);
|
||||
}
|
||||
|
||||
f->value.function.name = gfc_get_string (PREFIX("fputc"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_fput (gfc_expr * f, gfc_expr * c ATTRIBUTE_UNUSED)
|
||||
{
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_c_int_kind;
|
||||
f->value.function.name = gfc_get_string (PREFIX("fput"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_ftell (gfc_expr * f, gfc_expr * u)
|
||||
{
|
||||
gfc_typespec ts;
|
||||
|
||||
f->ts.type = BT_INTEGER;
|
||||
f->ts.kind = gfc_index_integer_kind;
|
||||
if (u->ts.kind != gfc_c_int_kind)
|
||||
{
|
||||
ts.type = BT_INTEGER;
|
||||
ts.kind = gfc_c_int_kind;
|
||||
ts.derived = NULL;
|
||||
ts.cl = NULL;
|
||||
gfc_convert_type (u, &ts, 2);
|
||||
}
|
||||
|
||||
f->value.function.name = gfc_get_string (PREFIX("ftell"));
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_sum (gfc_expr * f, gfc_expr * array, gfc_expr * dim,
|
||||
gfc_expr * mask)
|
||||
|
|
@ -1799,6 +1947,26 @@ gfc_resolve_verify (gfc_expr * f, gfc_expr * string,
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_xor (gfc_expr * f, gfc_expr * i, gfc_expr * j)
|
||||
{
|
||||
f->ts.type = i->ts.type;
|
||||
f->ts.kind = gfc_kind_max (i,j);
|
||||
|
||||
if (i->ts.kind != j->ts.kind)
|
||||
{
|
||||
if (i->ts.kind == gfc_kind_max (i,j))
|
||||
gfc_convert_type(j, &i->ts, 2);
|
||||
else
|
||||
gfc_convert_type(i, &j->ts, 2);
|
||||
}
|
||||
|
||||
f->value.function.name = gfc_get_string ("__xor_%c%d",
|
||||
gfc_type_letter (i->ts.type),
|
||||
f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
/* Intrinsic subroutine resolution. */
|
||||
|
||||
void
|
||||
|
|
@ -2265,6 +2433,119 @@ gfc_resolve_fstat_sub (gfc_code * c)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_fgetc_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
gfc_typespec ts;
|
||||
gfc_expr *u, *st;
|
||||
|
||||
u = c->ext.actual->expr;
|
||||
st = c->ext.actual->next->next->expr;
|
||||
|
||||
if (u->ts.kind != gfc_c_int_kind)
|
||||
{
|
||||
ts.type = BT_INTEGER;
|
||||
ts.kind = gfc_c_int_kind;
|
||||
ts.derived = NULL;
|
||||
ts.cl = NULL;
|
||||
gfc_convert_type (u, &ts, 2);
|
||||
}
|
||||
|
||||
if (st != NULL)
|
||||
name = gfc_get_string (PREFIX("fgetc_i%d_sub"), st->ts.kind);
|
||||
else
|
||||
name = gfc_get_string (PREFIX("fgetc_i%d_sub"), gfc_default_integer_kind);
|
||||
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_fget_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
gfc_expr *st;
|
||||
|
||||
st = c->ext.actual->next->expr;
|
||||
if (st != NULL)
|
||||
name = gfc_get_string (PREFIX("fget_i%d_sub"), st->ts.kind);
|
||||
else
|
||||
name = gfc_get_string (PREFIX("fget_i%d_sub"), gfc_default_integer_kind);
|
||||
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_fputc_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
gfc_typespec ts;
|
||||
gfc_expr *u, *st;
|
||||
|
||||
u = c->ext.actual->expr;
|
||||
st = c->ext.actual->next->next->expr;
|
||||
|
||||
if (u->ts.kind != gfc_c_int_kind)
|
||||
{
|
||||
ts.type = BT_INTEGER;
|
||||
ts.kind = gfc_c_int_kind;
|
||||
ts.derived = NULL;
|
||||
ts.cl = NULL;
|
||||
gfc_convert_type (u, &ts, 2);
|
||||
}
|
||||
|
||||
if (st != NULL)
|
||||
name = gfc_get_string (PREFIX("fputc_i%d_sub"), st->ts.kind);
|
||||
else
|
||||
name = gfc_get_string (PREFIX("fputc_i%d_sub"), gfc_default_integer_kind);
|
||||
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_fput_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
gfc_expr *st;
|
||||
|
||||
st = c->ext.actual->next->expr;
|
||||
if (st != NULL)
|
||||
name = gfc_get_string (PREFIX("fput_i%d_sub"), st->ts.kind);
|
||||
else
|
||||
name = gfc_get_string (PREFIX("fput_i%d_sub"), gfc_default_integer_kind);
|
||||
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_ftell_sub (gfc_code * c)
|
||||
{
|
||||
const char *name;
|
||||
gfc_expr *unit;
|
||||
gfc_expr *offset;
|
||||
gfc_typespec ts;
|
||||
|
||||
unit = c->ext.actual->expr;
|
||||
offset = c->ext.actual->next->expr;
|
||||
|
||||
if (unit->ts.kind != gfc_c_int_kind)
|
||||
{
|
||||
ts.type = BT_INTEGER;
|
||||
ts.kind = gfc_c_int_kind;
|
||||
ts.derived = NULL;
|
||||
ts.cl = NULL;
|
||||
gfc_convert_type (unit, &ts, 2);
|
||||
}
|
||||
|
||||
name = gfc_get_string (PREFIX("ftell_i%d_sub"), offset->ts.kind);
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_ttynam_sub (gfc_code * c)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -449,6 +449,31 @@ gfc_simplify_anint (gfc_expr * e, gfc_expr * k)
|
|||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_and (gfc_expr * x, gfc_expr * y)
|
||||
{
|
||||
gfc_expr *result;
|
||||
int kind;
|
||||
|
||||
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
||||
return NULL;
|
||||
|
||||
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
|
||||
if (x->ts.type == BT_INTEGER)
|
||||
{
|
||||
result = gfc_constant_result (BT_INTEGER, kind, &x->where);
|
||||
mpz_and (result->value.integer, x->value.integer, y->value.integer);
|
||||
}
|
||||
else /* BT_LOGICAL */
|
||||
{
|
||||
result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
|
||||
result->value.logical = x->value.logical && y->value.logical;
|
||||
}
|
||||
|
||||
return range_check (result, "AND");
|
||||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_dnint (gfc_expr * e)
|
||||
{
|
||||
|
|
@ -723,6 +748,34 @@ gfc_simplify_cmplx (gfc_expr * x, gfc_expr * y, gfc_expr * k)
|
|||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_complex (gfc_expr * x, gfc_expr * y)
|
||||
{
|
||||
int kind;
|
||||
|
||||
if (x->expr_type != EXPR_CONSTANT
|
||||
|| (y != NULL && y->expr_type != EXPR_CONSTANT))
|
||||
return NULL;
|
||||
|
||||
if (x->ts.type == BT_INTEGER)
|
||||
{
|
||||
if (y->ts.type == BT_INTEGER)
|
||||
kind = gfc_default_real_kind;
|
||||
else
|
||||
kind = y->ts.kind;
|
||||
}
|
||||
else
|
||||
{
|
||||
if (y->ts.type == BT_REAL)
|
||||
kind = (x->ts.kind > y->ts.kind) ? x->ts.kind : y->ts.kind;
|
||||
else
|
||||
kind = x->ts.kind;
|
||||
}
|
||||
|
||||
return simplify_cmplx ("COMPLEX", x, y, kind);
|
||||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_conjg (gfc_expr * e)
|
||||
{
|
||||
|
|
@ -2479,6 +2532,31 @@ gfc_simplify_null (gfc_expr * mold)
|
|||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_or (gfc_expr * x, gfc_expr * y)
|
||||
{
|
||||
gfc_expr *result;
|
||||
int kind;
|
||||
|
||||
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
||||
return NULL;
|
||||
|
||||
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
|
||||
if (x->ts.type == BT_INTEGER)
|
||||
{
|
||||
result = gfc_constant_result (BT_INTEGER, kind, &x->where);
|
||||
mpz_ior (result->value.integer, x->value.integer, y->value.integer);
|
||||
}
|
||||
else /* BT_LOGICAL */
|
||||
{
|
||||
result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
|
||||
result->value.logical = x->value.logical || y->value.logical;
|
||||
}
|
||||
|
||||
return range_check (result, "OR");
|
||||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_precision (gfc_expr * e)
|
||||
{
|
||||
|
|
@ -3706,6 +3784,34 @@ gfc_simplify_verify (gfc_expr * s, gfc_expr * set, gfc_expr * b)
|
|||
return result;
|
||||
}
|
||||
|
||||
|
||||
gfc_expr *
|
||||
gfc_simplify_xor (gfc_expr * x, gfc_expr * y)
|
||||
{
|
||||
gfc_expr *result;
|
||||
int kind;
|
||||
|
||||
if (x->expr_type != EXPR_CONSTANT || y->expr_type != EXPR_CONSTANT)
|
||||
return NULL;
|
||||
|
||||
kind = x->ts.kind > y->ts.kind ? x->ts.kind : y->ts.kind;
|
||||
if (x->ts.type == BT_INTEGER)
|
||||
{
|
||||
result = gfc_constant_result (BT_INTEGER, kind, &x->where);
|
||||
mpz_xor (result->value.integer, x->value.integer, y->value.integer);
|
||||
}
|
||||
else /* BT_LOGICAL */
|
||||
{
|
||||
result = gfc_constant_result (BT_LOGICAL, kind, &x->where);
|
||||
result->value.logical = (x->value.logical && ! y->value.logical)
|
||||
|| (! x->value.logical && y->value.logical);
|
||||
}
|
||||
|
||||
return range_check (result, "XOR");
|
||||
}
|
||||
|
||||
|
||||
|
||||
/****************** Constant simplification *****************/
|
||||
|
||||
/* Master function to convert one constant to another. While this is
|
||||
|
|
|
|||
|
|
@ -2983,6 +2983,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_AND:
|
||||
gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_ANY:
|
||||
gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
|
||||
break;
|
||||
|
|
@ -3037,6 +3041,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
gfc_conv_intrinsic_iargc (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_COMPLEX:
|
||||
gfc_conv_intrinsic_cmplx (se, expr, 1);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_CONJG:
|
||||
gfc_conv_intrinsic_conjg (se, expr);
|
||||
break;
|
||||
|
|
@ -3167,6 +3175,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
gfc_conv_intrinsic_not (se, expr);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_OR:
|
||||
gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_PRESENT:
|
||||
gfc_conv_intrinsic_present (se, expr);
|
||||
break;
|
||||
|
|
@ -3199,6 +3211,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
gfc_conv_intrinsic_bound (se, expr, 1);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_XOR:
|
||||
gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
|
||||
break;
|
||||
|
||||
case GFC_ISYM_LOC:
|
||||
gfc_conv_intrinsic_loc (se, expr);
|
||||
break;
|
||||
|
|
@ -3206,8 +3222,13 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
case GFC_ISYM_CHDIR:
|
||||
case GFC_ISYM_DOT_PRODUCT:
|
||||
case GFC_ISYM_ETIME:
|
||||
case GFC_ISYM_FGET:
|
||||
case GFC_ISYM_FGETC:
|
||||
case GFC_ISYM_FNUM:
|
||||
case GFC_ISYM_FPUT:
|
||||
case GFC_ISYM_FPUTC:
|
||||
case GFC_ISYM_FSTAT:
|
||||
case GFC_ISYM_FTELL:
|
||||
case GFC_ISYM_GETCWD:
|
||||
case GFC_ISYM_GETGID:
|
||||
case GFC_ISYM_GETPID:
|
||||
|
|
|
|||
|
|
@ -1,3 +1,15 @@
|
|||
2005-11-13 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* gfortran.dg/complex_intrinsic_1.f90: New test.
|
||||
* gfortran.dg/complex_intrinsic_2.f90: New test.
|
||||
* gfortran.dg/fgetc_1.f90: New test.
|
||||
* gfortran.dg/fgetc_2.f90: New test.
|
||||
* gfortran.dg/fgetc_3.f90: New test.
|
||||
* gfortran.dg/ftell_1.f90: New test.
|
||||
* gfortran.dg/ftell_2.f90: New test.
|
||||
* gfortran.dg/gnu_logical_1.F: New test.
|
||||
* gfortran.dg/gnu_logical_2.f90: New test.
|
||||
|
||||
2005-11-13 Andrew Pinski <pinskia@physics.uc.edu>
|
||||
|
||||
PR middle-end/24820
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
! Testcase for the COMPLEX intrinsic
|
||||
! { dg-do run }
|
||||
if (complex(1_1, -1_2) /= complex(1.0_4, -1.0_8)) call abort
|
||||
if (complex(1_4, -1.0) /= complex(1.0_4, -1_8)) call abort
|
||||
end
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Testcase for the COMPLEX intrinsic
|
||||
! { dg-do compile }
|
||||
complex c
|
||||
c = complex(.true.,1.0) ! { dg-error "must be INTEGER or REAL" }
|
||||
c = complex(1) ! { dg-error "Missing actual argument" }
|
||||
c = complex(1,c) ! { dg-error "must be INTEGER or REAL" }
|
||||
end
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! Testcase for the FGETC and FPUTC intrinsics
|
||||
! { dg-do run }
|
||||
character(len=5) s
|
||||
integer st
|
||||
|
||||
s = "12345"
|
||||
open(10,status="scratch")
|
||||
write(10,"(A)") "abcde"
|
||||
rewind(10)
|
||||
call fgetc(10,s,st)
|
||||
if ((st /= 0) .or. (s /= "a ")) call abort
|
||||
call fgetc(10,s,st)
|
||||
close(10)
|
||||
|
||||
open(10,status="scratch")
|
||||
s = "12345"
|
||||
call fputc(10,s,st)
|
||||
if (st /= 0) call abort
|
||||
call fputc(10,"2",st)
|
||||
if (st /= 0) call abort
|
||||
call fputc(10,"3 ",st)
|
||||
if (st /= 0) call abort
|
||||
rewind(10)
|
||||
call fgetc(10,s)
|
||||
if (s(1:1) /= "1") call abort
|
||||
call fgetc(10,s)
|
||||
if (s(1:1) /= "2") call abort
|
||||
call fgetc(10,s,st)
|
||||
if ((s(1:1) /= "3") .or. (st /= 0)) call abort
|
||||
call fgetc(10,s,st)
|
||||
if (st /= -1) call abort
|
||||
close (10)
|
||||
|
||||
! FGETC and FPUTC on units not opened should not work
|
||||
call fgetc(12,s,st)
|
||||
if (st /= -1) call abort
|
||||
call fputc(12,s,st)
|
||||
if (st /= -1) call abort
|
||||
end
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
! Testcase for the FGETC and FPUTC intrinsics
|
||||
! { dg-do run }
|
||||
character(len=5) s
|
||||
integer st
|
||||
|
||||
s = "12345"
|
||||
open(10,status="scratch")
|
||||
write(10,"(A)") "abcde"
|
||||
rewind(10)
|
||||
st = fgetc(10,s)
|
||||
if ((st /= 0) .or. (s /= "a ")) call abort
|
||||
st = fgetc(10,s)
|
||||
close(10)
|
||||
|
||||
open(10,status="scratch")
|
||||
s = "12345"
|
||||
st = fputc(10,s)
|
||||
if (st /= 0) call abort
|
||||
st = fputc(10,"2")
|
||||
if (st /= 0) call abort
|
||||
st = fputc(10,"3 ")
|
||||
if (st /= 0) call abort
|
||||
rewind(10)
|
||||
st = fgetc(10,s)
|
||||
if (s(1:1) /= "1") call abort
|
||||
st = fgetc(10,s)
|
||||
if (s(1:1) /= "2") call abort
|
||||
st = fgetc(10,s)
|
||||
if ((s(1:1) /= "3") .or. (st /= 0)) call abort
|
||||
st = fgetc(10,s)
|
||||
if (st /= -1) call abort
|
||||
close (10)
|
||||
|
||||
! FGETC and FPUTC on units not opened should not work
|
||||
st = fgetc(12,s)
|
||||
if (st /= -1) call abort
|
||||
st = fputc(12,s)
|
||||
if (st /= -1) call abort
|
||||
end
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
! Testcase for the FGETC and FPUTC intrinsics
|
||||
! { dg-do compile }
|
||||
character(len=5) s
|
||||
integer st
|
||||
|
||||
s = "12345"
|
||||
open(status="scratch")
|
||||
write(*,"(A)") "abcde"
|
||||
rewind(10)
|
||||
st = fget(s)
|
||||
if ((st /= 0) .or. (s /= "a ")) call abort
|
||||
st = fget(s)
|
||||
close(10)
|
||||
|
||||
open(status="scratch")
|
||||
s = "12345"
|
||||
st = fput(s)
|
||||
if (st /= 0) call abort
|
||||
st = fput("2")
|
||||
if (st /= 0) call abort
|
||||
st = fput("3 ")
|
||||
if (st /= 0) call abort
|
||||
rewind(10)
|
||||
st = fget(s)
|
||||
if (s(1:1) /= "1") call abort
|
||||
st = fget(s)
|
||||
if (s(1:1) /= "2") call abort
|
||||
st = fget(s)
|
||||
if ((s(1:1) /= "3") .or. (st /= 0)) call abort
|
||||
st = fget(s)
|
||||
if (st /= -1) call abort
|
||||
close (10)
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,13 @@
|
|||
! { dg-do run }
|
||||
integer*8 o
|
||||
|
||||
open (10, status="scratch")
|
||||
call ftell (10, o)
|
||||
if (o /= 0) call abort
|
||||
write (10,"(A)") "1234567"
|
||||
call ftell (10, o)
|
||||
if (o /= 8) call abort
|
||||
close (10)
|
||||
call ftell (10, o)
|
||||
if (o /= -1) call abort
|
||||
end
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
! { dg-do run }
|
||||
open (10, status="scratch")
|
||||
if (ftell(10) /= 0) call abort
|
||||
write (10,"(A)") "1234567"
|
||||
if (ftell(10) /= 8) call abort
|
||||
close (10)
|
||||
if (ftell(10) /= -1) call abort
|
||||
end
|
||||
|
|
@ -0,0 +1,91 @@
|
|||
! Testcases for the AND, OR and XOR functions (GNU intrinsics).
|
||||
! { dg-do run }
|
||||
! { dg-options "-ffixed-line-length-none" }
|
||||
integer*1 i1, j1
|
||||
integer*2 i2, j2
|
||||
integer*4 i4, j4
|
||||
integer*8 i8, j8
|
||||
logical*1 l1, k1
|
||||
logical*2 l2, k2
|
||||
logical*4 l4, k4
|
||||
logical*8 l8, k8
|
||||
|
||||
#define TEST_INTEGER(u,ukind,v,vkind) \
|
||||
ukind = u;\
|
||||
vkind = v;\
|
||||
if (iand(u,v) /= and(ukind, vkind)) call abort;\
|
||||
if (iand(u,v) /= and(vkind, ukind)) call abort;\
|
||||
if (ieor(u,v) /= xor(ukind, vkind)) call abort;\
|
||||
if (ieor(u,v) /= xor(vkind, ukind)) call abort;\
|
||||
if (ior(u,v) /= or(ukind, vkind)) call abort;\
|
||||
if (ior(u,v) /= or(vkind, ukind)) call abort
|
||||
|
||||
TEST_INTEGER(19,i1,6,j1)
|
||||
TEST_INTEGER(19,i1,6,j2)
|
||||
TEST_INTEGER(19,i1,6,j4)
|
||||
TEST_INTEGER(19,i1,6,j8)
|
||||
|
||||
TEST_INTEGER(19,i2,6,j1)
|
||||
TEST_INTEGER(19,i2,6,j2)
|
||||
TEST_INTEGER(19,i2,6,j4)
|
||||
TEST_INTEGER(19,i2,6,j8)
|
||||
|
||||
TEST_INTEGER(19,i4,6,j1)
|
||||
TEST_INTEGER(19,i4,6,j2)
|
||||
TEST_INTEGER(19,i4,6,j4)
|
||||
TEST_INTEGER(19,i4,6,j8)
|
||||
|
||||
TEST_INTEGER(19,i8,6,j1)
|
||||
TEST_INTEGER(19,i8,6,j2)
|
||||
TEST_INTEGER(19,i8,6,j4)
|
||||
TEST_INTEGER(19,i8,6,j8)
|
||||
|
||||
|
||||
|
||||
#define TEST_LOGICAL(u,ukind,v,vkind) \
|
||||
ukind = u;\
|
||||
vkind = v;\
|
||||
if ((u .and. v) .neqv. and(ukind, vkind)) call abort;\
|
||||
if ((u .and. v) .neqv. and(vkind, ukind)) call abort;\
|
||||
if (((u .and. .not. v) .or. (.not. u .and. v)) .neqv. xor(ukind, vkind)) call abort;\
|
||||
if (((u .and. .not. v) .or. (.not. u .and. v)) .neqv. xor(vkind, ukind)) call abort;\
|
||||
if ((u .or. v) .neqv. or(ukind, vkind)) call abort;\
|
||||
if ((u .or. v) .neqv. or(vkind, ukind)) call abort
|
||||
|
||||
TEST_LOGICAL(.true.,l1,.false.,k1)
|
||||
TEST_LOGICAL(.true.,l1,.true.,k1)
|
||||
TEST_LOGICAL(.true.,l1,.false.,k2)
|
||||
TEST_LOGICAL(.true.,l1,.true.,k2)
|
||||
TEST_LOGICAL(.true.,l1,.false.,k4)
|
||||
TEST_LOGICAL(.true.,l1,.true.,k4)
|
||||
TEST_LOGICAL(.true.,l1,.false.,k8)
|
||||
TEST_LOGICAL(.true.,l1,.true.,k8)
|
||||
|
||||
TEST_LOGICAL(.true.,l2,.false.,k1)
|
||||
TEST_LOGICAL(.true.,l2,.true.,k1)
|
||||
TEST_LOGICAL(.true.,l2,.false.,k2)
|
||||
TEST_LOGICAL(.true.,l2,.true.,k2)
|
||||
TEST_LOGICAL(.true.,l2,.false.,k4)
|
||||
TEST_LOGICAL(.true.,l2,.true.,k4)
|
||||
TEST_LOGICAL(.true.,l2,.false.,k8)
|
||||
TEST_LOGICAL(.true.,l2,.true.,k8)
|
||||
|
||||
TEST_LOGICAL(.true.,l4,.false.,k1)
|
||||
TEST_LOGICAL(.true.,l4,.true.,k1)
|
||||
TEST_LOGICAL(.true.,l4,.false.,k2)
|
||||
TEST_LOGICAL(.true.,l4,.true.,k2)
|
||||
TEST_LOGICAL(.true.,l4,.false.,k4)
|
||||
TEST_LOGICAL(.true.,l4,.true.,k4)
|
||||
TEST_LOGICAL(.true.,l4,.false.,k8)
|
||||
TEST_LOGICAL(.true.,l4,.true.,k8)
|
||||
|
||||
TEST_LOGICAL(.true.,l8,.false.,k1)
|
||||
TEST_LOGICAL(.true.,l8,.true.,k1)
|
||||
TEST_LOGICAL(.true.,l8,.false.,k2)
|
||||
TEST_LOGICAL(.true.,l8,.true.,k2)
|
||||
TEST_LOGICAL(.true.,l8,.false.,k4)
|
||||
TEST_LOGICAL(.true.,l8,.true.,k4)
|
||||
TEST_LOGICAL(.true.,l8,.false.,k8)
|
||||
TEST_LOGICAL(.true.,l8,.true.,k8)
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
! Testcases for the AND, OR and XOR functions (GNU intrinsics).
|
||||
! { dg-do compile }
|
||||
integer i
|
||||
logical l
|
||||
real r
|
||||
complex c
|
||||
|
||||
print *, and(i,i)
|
||||
print *, and(l,l)
|
||||
print *, and(i,r) ! { dg-error "must be INTEGER or LOGICAL" }
|
||||
print *, and(c,l) ! { dg-error "must be INTEGER or LOGICAL" }
|
||||
print *, and(i,l) ! { dg-error "must have the same type" }
|
||||
print *, and(l,i) ! { dg-error "must have the same type" }
|
||||
|
||||
print *, or(i,i)
|
||||
print *, or(l,l)
|
||||
print *, or(i,r) ! { dg-error "must be INTEGER or LOGICAL" }
|
||||
print *, or(c,l) ! { dg-error "must be INTEGER or LOGICAL" }
|
||||
print *, or(i,l) ! { dg-error "must have the same type" }
|
||||
print *, or(l,i) ! { dg-error "must have the same type" }
|
||||
|
||||
print *, xor(i,i)
|
||||
print *, xor(l,l)
|
||||
print *, xor(i,r) ! { dg-error "must be INTEGER or LOGICAL" }
|
||||
print *, xor(c,l) ! { dg-error "must be INTEGER or LOGICAL" }
|
||||
print *, xor(i,l) ! { dg-error "must have the same type" }
|
||||
print *, xor(l,i) ! { dg-error "must have the same type" }
|
||||
|
||||
end
|
||||
|
|
@ -1,3 +1,12 @@
|
|||
2005-11-13 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* intrinsics/fget.c: New file.
|
||||
* intrinsics/ftell.c: New file.
|
||||
* io/unix.c (stream_offset): New function.
|
||||
* io/io.h: Add prototype for stream_offset.
|
||||
* Makefile.am: Add intrinsics/fget.c and intrinsics/ftell.c.
|
||||
* Makefile.in: Regenerate.
|
||||
|
||||
2005-11-12 Steven G. Kargl <kargls@comcast.net>
|
||||
|
||||
PR libgfortran/24787
|
||||
|
|
|
|||
|
|
@ -53,8 +53,10 @@ intrinsics/eoshift0.c \
|
|||
intrinsics/eoshift2.c \
|
||||
intrinsics/etime.c \
|
||||
intrinsics/exit.c \
|
||||
intrinsics/fget.c \
|
||||
intrinsics/flush.c \
|
||||
intrinsics/fnum.c \
|
||||
intrinsics/ftell.c \
|
||||
intrinsics/gerror.c \
|
||||
intrinsics/getcwd.c \
|
||||
intrinsics/getlog.c \
|
||||
|
|
|
|||
|
|
@ -167,16 +167,16 @@ am__objects_32 = close.lo file_pos.lo format.lo inquire.lo \
|
|||
am__objects_33 = associated.lo abort.lo args.lo bessel.lo \
|
||||
c99_functions.lo chdir.lo cpu_time.lo cshift0.lo ctime.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 hyper.lo hostnm.lo kill.lo ierrno.lo \
|
||||
ishftc.lo link.lo malloc.lo mvbits.lo pack_generic.lo \
|
||||
perror.lo signal.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 tty.lo umask.lo unlink.lo \
|
||||
unpack_generic.lo in_pack_generic.lo in_unpack_generic.lo \
|
||||
normalize.lo
|
||||
etime.lo exit.lo fget.lo flush.lo fnum.lo ftell.lo gerror.lo \
|
||||
getcwd.lo getlog.lo getXid.lo hyper.lo hostnm.lo kill.lo \
|
||||
ierrno.lo ishftc.lo link.lo malloc.lo mvbits.lo \
|
||||
pack_generic.lo perror.lo signal.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 tty.lo umask.lo \
|
||||
unlink.lo unpack_generic.lo in_pack_generic.lo \
|
||||
in_unpack_generic.lo normalize.lo
|
||||
am__objects_34 =
|
||||
am__objects_35 = _abs_c4.lo _abs_c8.lo _abs_c10.lo _abs_c16.lo \
|
||||
_abs_i4.lo _abs_i8.lo _abs_i16.lo _abs_r4.lo _abs_r8.lo \
|
||||
|
|
@ -394,8 +394,10 @@ intrinsics/eoshift0.c \
|
|||
intrinsics/eoshift2.c \
|
||||
intrinsics/etime.c \
|
||||
intrinsics/exit.c \
|
||||
intrinsics/fget.c \
|
||||
intrinsics/flush.c \
|
||||
intrinsics/fnum.c \
|
||||
intrinsics/ftell.c \
|
||||
intrinsics/gerror.c \
|
||||
intrinsics/getcwd.c \
|
||||
intrinsics/getlog.c \
|
||||
|
|
@ -2264,12 +2266,18 @@ etime.lo: intrinsics/etime.c
|
|||
exit.lo: intrinsics/exit.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o exit.lo `test -f 'intrinsics/exit.c' || echo '$(srcdir)/'`intrinsics/exit.c
|
||||
|
||||
fget.lo: intrinsics/fget.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o fget.lo `test -f 'intrinsics/fget.c' || echo '$(srcdir)/'`intrinsics/fget.c
|
||||
|
||||
flush.lo: intrinsics/flush.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o flush.lo `test -f 'intrinsics/flush.c' || echo '$(srcdir)/'`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
|
||||
|
||||
ftell.lo: intrinsics/ftell.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o ftell.lo `test -f 'intrinsics/ftell.c' || echo '$(srcdir)/'`intrinsics/ftell.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
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,173 @@
|
|||
/* Implementation of the FGET, FGETC, FPUT and FPUTC 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., 51 Franklin Street, Fifth Floor,
|
||||
Boston, MA 02110-1301, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <string.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
static const int five = 5;
|
||||
static const int six = 6;
|
||||
|
||||
extern int PREFIX(fgetc) (const int *, char *, gfc_charlen_type);
|
||||
export_proto_np(PREFIX(fgetc));
|
||||
|
||||
int
|
||||
PREFIX(fgetc) (const int * unit, char * c, gfc_charlen_type c_len)
|
||||
{
|
||||
int ret;
|
||||
size_t s;
|
||||
gfc_unit * u = find_unit (*unit);
|
||||
|
||||
if (u == NULL)
|
||||
return -1;
|
||||
|
||||
s = 1;
|
||||
memset (c, ' ', c_len);
|
||||
ret = sread (u->s, c, &s);
|
||||
|
||||
if (ret != 0)
|
||||
return ret;
|
||||
|
||||
if (s != 1)
|
||||
return -1;
|
||||
else
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
#define FGETC_SUB(kind) \
|
||||
extern void fgetc_i ## kind ## _sub \
|
||||
(const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
|
||||
export_proto(fgetc_i ## kind ## _sub); \
|
||||
void fgetc_i ## kind ## _sub \
|
||||
(const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
|
||||
{ if (st != NULL) \
|
||||
*st = PREFIX(fgetc) (unit, c, c_len); \
|
||||
else \
|
||||
PREFIX(fgetc) (unit, c, c_len); }
|
||||
|
||||
FGETC_SUB(1)
|
||||
FGETC_SUB(2)
|
||||
FGETC_SUB(4)
|
||||
FGETC_SUB(8)
|
||||
|
||||
|
||||
extern int PREFIX(fget) (char *, gfc_charlen_type);
|
||||
export_proto_np(PREFIX(fget));
|
||||
|
||||
int
|
||||
PREFIX(fget) (char * c, gfc_charlen_type c_len)
|
||||
{
|
||||
return PREFIX(fgetc) (&five, c, c_len);
|
||||
}
|
||||
|
||||
|
||||
#define FGET_SUB(kind) \
|
||||
extern void fget_i ## kind ## _sub \
|
||||
(char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
|
||||
export_proto(fget_i ## kind ## _sub); \
|
||||
void fget_i ## kind ## _sub \
|
||||
(char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
|
||||
{ if (st != NULL) \
|
||||
*st = PREFIX(fgetc) (&five, c, c_len); \
|
||||
else \
|
||||
PREFIX(fgetc) (&five, c, c_len); }
|
||||
|
||||
FGET_SUB(1)
|
||||
FGET_SUB(2)
|
||||
FGET_SUB(4)
|
||||
FGET_SUB(8)
|
||||
|
||||
|
||||
|
||||
extern int PREFIX(fputc) (const int *, char *, gfc_charlen_type);
|
||||
export_proto_np(PREFIX(fputc));
|
||||
|
||||
int
|
||||
PREFIX(fputc) (const int * unit, char * c,
|
||||
gfc_charlen_type c_len __attribute__((unused)))
|
||||
{
|
||||
size_t s;
|
||||
gfc_unit * u = find_unit (*unit);
|
||||
|
||||
if (u == NULL)
|
||||
return -1;
|
||||
|
||||
s = 1;
|
||||
return swrite (u->s, c, &s);
|
||||
}
|
||||
|
||||
|
||||
#define FPUTC_SUB(kind) \
|
||||
extern void fputc_i ## kind ## _sub \
|
||||
(const int *, char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
|
||||
export_proto(fputc_i ## kind ## _sub); \
|
||||
void fputc_i ## kind ## _sub \
|
||||
(const int * unit, char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
|
||||
{ if (st != NULL) \
|
||||
*st = PREFIX(fputc) (unit, c, c_len); \
|
||||
else \
|
||||
PREFIX(fputc) (unit, c, c_len); }
|
||||
|
||||
FPUTC_SUB(1)
|
||||
FPUTC_SUB(2)
|
||||
FPUTC_SUB(4)
|
||||
FPUTC_SUB(8)
|
||||
|
||||
|
||||
extern int PREFIX(fput) (char *, gfc_charlen_type);
|
||||
export_proto_np(PREFIX(fput));
|
||||
|
||||
int
|
||||
PREFIX(fput) (char * c, gfc_charlen_type c_len)
|
||||
{
|
||||
return PREFIX(fputc) (&six, c, c_len);
|
||||
}
|
||||
|
||||
|
||||
#define FPUT_SUB(kind) \
|
||||
extern void fput_i ## kind ## _sub \
|
||||
(char *, GFC_INTEGER_ ## kind *, gfc_charlen_type); \
|
||||
export_proto(fput_i ## kind ## _sub); \
|
||||
void fput_i ## kind ## _sub \
|
||||
(char * c, GFC_INTEGER_ ## kind * st, gfc_charlen_type c_len) \
|
||||
{ if (st != NULL) \
|
||||
*st = PREFIX(fputc) (&six, c, c_len); \
|
||||
else \
|
||||
PREFIX(fputc) (&six, c, c_len); }
|
||||
|
||||
FPUT_SUB(1)
|
||||
FPUT_SUB(2)
|
||||
FPUT_SUB(4)
|
||||
FPUT_SUB(8)
|
||||
|
||||
|
|
@ -0,0 +1,67 @@
|
|||
/* Implementation of the FTELL 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., 51 Franklin Street, Fifth Floor,
|
||||
Boston, MA 02110-1301, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
|
||||
#include <string.h>
|
||||
|
||||
#include "../io/io.h"
|
||||
|
||||
extern size_t PREFIX(ftell) (int *);
|
||||
export_proto_np(PREFIX(ftell));
|
||||
|
||||
size_t
|
||||
PREFIX(ftell) (int * unit)
|
||||
{
|
||||
gfc_unit * u = find_unit (*unit);
|
||||
if (u == NULL)
|
||||
return ((size_t) -1);
|
||||
else
|
||||
return ((size_t) stream_offset (u->s));
|
||||
}
|
||||
|
||||
#define FTELL_SUB(kind) \
|
||||
extern void ftell_i ## kind ## _sub (int *, GFC_INTEGER_ ## kind *); \
|
||||
export_proto(ftell_i ## kind ## _sub); \
|
||||
void \
|
||||
ftell_i ## kind ## _sub (int * unit, GFC_INTEGER_ ## kind * offset) \
|
||||
{ \
|
||||
gfc_unit * u = find_unit (*unit); \
|
||||
if (u == NULL) \
|
||||
*offset = -1; \
|
||||
else \
|
||||
*offset = stream_offset (u->s); \
|
||||
}
|
||||
|
||||
FTELL_SUB(1)
|
||||
FTELL_SUB(2)
|
||||
FTELL_SUB(4)
|
||||
FTELL_SUB(8)
|
||||
|
|
@ -520,6 +520,9 @@ internal_proto(stream_isatty);
|
|||
extern char * stream_ttyname (stream *);
|
||||
internal_proto(stream_ttyname);
|
||||
|
||||
extern gfc_offset stream_offset (stream *s);
|
||||
internal_proto(stream_offset);
|
||||
|
||||
extern int unit_to_fd (int);
|
||||
internal_proto(unit_to_fd);
|
||||
|
||||
|
|
|
|||
|
|
@ -1640,6 +1640,12 @@ stream_ttyname (stream *s)
|
|||
#endif
|
||||
}
|
||||
|
||||
gfc_offset
|
||||
stream_offset (stream *s)
|
||||
{
|
||||
return (((unix_stream *) s)->logical_offset);
|
||||
}
|
||||
|
||||
|
||||
/* How files are stored: This is an operating-system specific issue,
|
||||
and therefore belongs here. There are three cases to consider.
|
||||
|
|
|
|||
Loading…
Reference in New Issue