diff options
author | Francois-Xavier Coudert <coudert@clipper.ens.fr> | 2005-11-13 10:33:19 +0100 |
---|---|---|
committer | François-Xavier Coudert <fxcoudert@gcc.gnu.org> | 2005-11-13 09:33:19 +0000 |
commit | 5d723e5434e83d9de5271f6d1c24a694826450a8 (patch) | |
tree | e0ec7b23d7872520a826e03806116b99255edffd | |
parent | a8bd670c5a5021e73a7727d585ac2bd806046295 (diff) | |
download | gcc-5d723e5434e83d9de5271f6d1c24a694826450a8.zip gcc-5d723e5434e83d9de5271f6d1c24a694826450a8.tar.gz gcc-5d723e5434e83d9de5271f6d1c24a694826450a8.tar.bz2 |
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
25 files changed, 1260 insertions, 13 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 305f91a..0a24084 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -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> diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index bf81e9f..bc757ff 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -632,6 +632,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) { if (logical_array_check (mask, 0) == FAILURE) @@ -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) { @@ -2054,6 +2139,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) { if (type_check (name, 0, BT_CHARACTER) == FAILURE) @@ -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; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 5626cc9..a0d0e8c 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -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; diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index eedbaa7..7963eec 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 70bf866..880f418 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 22aeda8..de3c271 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -118,6 +118,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) { gfc_typespec ts; @@ -357,6 +377,36 @@ gfc_resolve_dcmplx (gfc_expr * f, gfc_expr * x, gfc_expr * y) } 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) { f->ts = x->ts; @@ -1178,6 +1228,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) { @@ -1554,6 +1624,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 @@ -2266,6 +2434,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) { gfc_typespec ts; diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 7c9a6dc..b6931f1 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -450,6 +450,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) { gfc_expr *result; @@ -724,6 +749,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) { gfc_expr *result; @@ -2480,6 +2533,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) { gfc_expr *result; @@ -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 diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 02a0151..ea9c2e3 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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: diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 805aa20..ae3265f 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -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 diff --git a/gcc/testsuite/gfortran.dg/complex_intrinsic_1.f90 b/gcc/testsuite/gfortran.dg/complex_intrinsic_1.f90 new file mode 100644 index 0000000..3c29915 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/complex_intrinsic_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/complex_intrinsic_2.f90 b/gcc/testsuite/gfortran.dg/complex_intrinsic_2.f90 new file mode 100644 index 0000000..1327e4a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/complex_intrinsic_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/fgetc_1.f90 b/gcc/testsuite/gfortran.dg/fgetc_1.f90 new file mode 100644 index 0000000..966e15a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/fgetc_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/fgetc_2.f90 b/gcc/testsuite/gfortran.dg/fgetc_2.f90 new file mode 100644 index 0000000..6dd12c4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/fgetc_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/fgetc_3.f90 b/gcc/testsuite/gfortran.dg/fgetc_3.f90 new file mode 100644 index 0000000..3706b67a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/fgetc_3.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/ftell_1.f90 b/gcc/testsuite/gfortran.dg/ftell_1.f90 new file mode 100644 index 0000000..bd154f1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ftell_1.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/ftell_2.f90 b/gcc/testsuite/gfortran.dg/ftell_2.f90 new file mode 100644 index 0000000..1dda1fb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/ftell_2.f90 @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gnu_logical_1.F b/gcc/testsuite/gfortran.dg/gnu_logical_1.F new file mode 100644 index 0000000..3b6d607 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gnu_logical_1.F @@ -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 diff --git a/gcc/testsuite/gfortran.dg/gnu_logical_2.f90 b/gcc/testsuite/gfortran.dg/gnu_logical_2.f90 new file mode 100644 index 0000000..4ff70fa --- /dev/null +++ b/gcc/testsuite/gfortran.dg/gnu_logical_2.f90 @@ -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 diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog index 793d440..022ae4f 100644 --- a/libgfortran/ChangeLog +++ b/libgfortran/ChangeLog @@ -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 diff --git a/libgfortran/Makefile.am b/libgfortran/Makefile.am index e3f2b57..4fdb4b3 100644 --- a/libgfortran/Makefile.am +++ b/libgfortran/Makefile.am @@ -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 \ diff --git a/libgfortran/Makefile.in b/libgfortran/Makefile.in index 38530d2..a8a37f5 100644 --- a/libgfortran/Makefile.in +++ b/libgfortran/Makefile.in @@ -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 diff --git a/libgfortran/intrinsics/fget.c b/libgfortran/intrinsics/fget.c new file mode 100644 index 0000000..8eb96e3 --- /dev/null +++ b/libgfortran/intrinsics/fget.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) + diff --git a/libgfortran/intrinsics/ftell.c b/libgfortran/intrinsics/ftell.c new file mode 100644 index 0000000..16cf275 --- /dev/null +++ b/libgfortran/intrinsics/ftell.c @@ -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) diff --git a/libgfortran/io/io.h b/libgfortran/io/io.h index fa3335d..e262677 100644 --- a/libgfortran/io/io.h +++ b/libgfortran/io/io.h @@ -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); diff --git a/libgfortran/io/unix.c b/libgfortran/io/unix.c index 0fe8c4b..2f08aad 100644 --- a/libgfortran/io/unix.c +++ b/libgfortran/io/unix.c @@ -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. |