check.c (gfc_check_ttynam_sub, [...]): Add check functions for new intrinsics TTYNAM and ISATTY.
* check.c (gfc_check_ttynam_sub, gfc_check_isatty): Add check functions for new intrinsics TTYNAM and ISATTY. * intrinsic.c (add_functions, add_subroutines): Add new intrinsics. * intrinsic.h: Add prototypes for new check and resolve functions. * iresolve.c (gfc_resolve_isatty, gfc_resolve_ttynam_sub): New resolve functions for intrinsics TTYNAM and ISATTY. * gfortran.h (gfc_generic_isym_id): Add symbol for ISATTY. * trans-intrinsic.c: Add case for GFC_ISYM_ISATTY. * Makefile.am: Add file intrinsics/tty.c to Makefile process. * Makefile.in: Regenerate. * io/io.h: Prototypes for new functions stream_isatty and stream_ttyname. * io/unix (stream_isatty, stream_ttyname): New functions to call isatty() and ttyname() on a given unit. * intrinsics/tty.c: New file to implement g77 intrinsics TTYNAM and ISATTY. From-SVN: r102915
This commit is contained in:
François-Xavier Coudert
parent
0ed414a4f6
commit
ae8b87895f
|
|
@ -1,3 +1,16 @@
|
|||
2005-08-09 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
* check.c (gfc_check_ttynam_sub, gfc_check_isatty): Add check
|
||||
functions for new intrinsics TTYNAM and ISATTY.
|
||||
* intrinsic.c (add_functions, add_subroutines): Add new
|
||||
intrinsics.
|
||||
* intrinsic.h: Add prototypes for new check and resolve
|
||||
functions.
|
||||
* iresolve.c (gfc_resolve_isatty, gfc_resolve_ttynam_sub): New
|
||||
resolve functions for intrinsics TTYNAM and ISATTY.
|
||||
* gfortran.h (gfc_generic_isym_id): Add symbol for ISATTY.
|
||||
* trans-intrinsic.c: Add case for GFC_ISYM_ISATTY.
|
||||
|
||||
2005-08-09 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
* scanner.c (preprocessor_line): Don't write beyond the end of flag
|
||||
|
|
|
|||
|
|
@ -2573,6 +2573,38 @@ gfc_check_hostnm_sub (gfc_expr * name, gfc_expr * status)
|
|||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_ttynam_sub (gfc_expr * unit, gfc_expr * name)
|
||||
{
|
||||
if (scalar_check (unit, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (name, 1, BT_CHARACTER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_isatty (gfc_expr * unit)
|
||||
{
|
||||
if (unit == NULL)
|
||||
return FAILURE;
|
||||
|
||||
if (type_check (unit, 0, BT_INTEGER) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
if (scalar_check (unit, 0) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
return SUCCESS;
|
||||
}
|
||||
|
||||
|
||||
try
|
||||
gfc_check_perror (gfc_expr * string)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -335,6 +335,7 @@ enum gfc_generic_isym_id
|
|||
GFC_ISYM_INT,
|
||||
GFC_ISYM_IOR,
|
||||
GFC_ISYM_IRAND,
|
||||
GFC_ISYM_ISATTY,
|
||||
GFC_ISYM_ISHFT,
|
||||
GFC_ISYM_ISHFTC,
|
||||
GFC_ISYM_KILL,
|
||||
|
|
|
|||
|
|
@ -1468,6 +1468,12 @@ add_functions (void)
|
|||
|
||||
make_generic ("irand", GFC_ISYM_IRAND, GFC_STD_GNU);
|
||||
|
||||
add_sym_1 ("isatty", 0, 0, BT_LOGICAL, dl, GFC_STD_GNU,
|
||||
gfc_check_isatty, NULL, gfc_resolve_isatty,
|
||||
ut, BT_INTEGER, di, REQUIRED);
|
||||
|
||||
make_generic ("isatty", GFC_ISYM_ISATTY, GFC_STD_GNU);
|
||||
|
||||
add_sym_2 ("ishft", 1, 1, BT_INTEGER, di, GFC_STD_F95,
|
||||
gfc_check_ishft, gfc_simplify_ishft, gfc_resolve_ishft,
|
||||
i, BT_INTEGER, di, REQUIRED, sh, BT_INTEGER, di, REQUIRED);
|
||||
|
|
@ -2247,6 +2253,10 @@ add_subroutines (void)
|
|||
c, BT_INTEGER, di, OPTIONAL, cr, BT_INTEGER, di, OPTIONAL,
|
||||
cm, BT_INTEGER, di, OPTIONAL);
|
||||
|
||||
add_sym_2s ("ttynam", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_ttynam_sub, NULL, gfc_resolve_ttynam_sub,
|
||||
ut, BT_INTEGER, di, REQUIRED, c, BT_CHARACTER, dc, REQUIRED);
|
||||
|
||||
add_sym_2s ("umask", 0, 1, BT_UNKNOWN, 0, GFC_STD_GNU,
|
||||
gfc_check_umask_sub, NULL, gfc_resolve_umask_sub,
|
||||
val, BT_INTEGER, di, REQUIRED, num, BT_INTEGER, di, OPTIONAL);
|
||||
|
|
|
|||
|
|
@ -70,6 +70,7 @@ try gfc_check_index (gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
try gfc_check_int (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ior (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_irand (gfc_expr *);
|
||||
try gfc_check_isatty (gfc_expr *);
|
||||
try gfc_check_ishft (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ishftc (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_kill (gfc_expr *, gfc_expr *);
|
||||
|
|
@ -148,6 +149,7 @@ try gfc_check_symlnk_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
|||
try gfc_check_sleep_sub (gfc_expr *);
|
||||
try gfc_check_stat_sub (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
try gfc_check_system_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_ttynam_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_umask_sub (gfc_expr *, gfc_expr *);
|
||||
try gfc_check_unlink_sub (gfc_expr *, gfc_expr *);
|
||||
|
||||
|
|
@ -316,6 +318,7 @@ void gfc_resolve_ichar (gfc_expr *, gfc_expr *);
|
|||
void gfc_resolve_idnint (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_int (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_isatty (gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_ishftc (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
void gfc_resolve_kill (gfc_expr *, gfc_expr *, gfc_expr *);
|
||||
|
|
@ -402,6 +405,7 @@ void gfc_resolve_sleep_sub (gfc_code *);
|
|||
void gfc_resolve_stat_sub (gfc_code *);
|
||||
void gfc_resolve_system_clock (gfc_code *);
|
||||
void gfc_resolve_system_sub (gfc_code *);
|
||||
void gfc_resolve_ttynam_sub (gfc_code *);
|
||||
void gfc_resolve_umask_sub (gfc_code *);
|
||||
void gfc_resolve_unlink_sub (gfc_code *);
|
||||
|
||||
|
|
|
|||
|
|
@ -711,6 +711,26 @@ gfc_resolve_int (gfc_expr * f, gfc_expr * a, gfc_expr * kind)
|
|||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
|
||||
{
|
||||
gfc_typespec ts;
|
||||
|
||||
f->ts.type = BT_LOGICAL;
|
||||
f->ts.kind = gfc_default_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("isatty_l%d"), f->ts.kind);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
|
||||
{
|
||||
|
|
@ -1939,6 +1959,25 @@ gfc_resolve_fstat_sub (gfc_code * c)
|
|||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
|
||||
}
|
||||
|
||||
|
||||
void
|
||||
gfc_resolve_ttynam_sub (gfc_code * c)
|
||||
{
|
||||
gfc_typespec ts;
|
||||
|
||||
if (c->ext.actual->expr->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 (c->ext.actual->expr, &ts, 2);
|
||||
}
|
||||
|
||||
c->resolved_sym = gfc_get_intrinsic_sub_symbol (PREFIX("ttynam_sub"));
|
||||
}
|
||||
|
||||
|
||||
/* Resolve the UMASK intrinsic subroutine. */
|
||||
|
||||
void
|
||||
|
|
|
|||
|
|
@ -2996,6 +2996,7 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
|
|||
case GFC_ISYM_KILL:
|
||||
case GFC_ISYM_IERRNO:
|
||||
case GFC_ISYM_IRAND:
|
||||
case GFC_ISYM_ISATTY:
|
||||
case GFC_ISYM_LINK:
|
||||
case GFC_ISYM_MATMUL:
|
||||
case GFC_ISYM_RAND:
|
||||
|
|
|
|||
|
|
@ -1,9 +1,19 @@
|
|||
2005-08-09 Francois-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
* Makefile.am: Add file intrinsics/tty.c to Makefile process.
|
||||
* Makefile.in: Regenerate.
|
||||
* io/io.h: Prototypes for new functions stream_isatty and
|
||||
stream_ttyname.
|
||||
* io/unix (stream_isatty, stream_ttyname): New functions to call
|
||||
isatty() and ttyname() on a given unit.
|
||||
* intrinsics/tty.c: New file to implement g77 intrinsics TTYNAM
|
||||
and ISATTY.
|
||||
|
||||
2005-08-08 Jerry DeLisle <jvdelisle@verizon.net>
|
||||
|
||||
PR libfortran/23154
|
||||
* io/transfer.c (data_transfer_init): Initialize
|
||||
current_unit->bytes_left for a read.
|
||||
|
||||
PR libfortran/23154
|
||||
* io/transfer.c (data_transfer_init): Initialize
|
||||
current_unit->bytes_left for a read.
|
||||
|
||||
2005-08-07 Janne Blomqvist <jblomqvi@cc.hut.fi>
|
||||
|
||||
PR fortran/22390
|
||||
|
|
|
|||
|
|
@ -85,6 +85,7 @@ intrinsics/symlnk.c \
|
|||
intrinsics/system_clock.c \
|
||||
intrinsics/time.c \
|
||||
intrinsics/transpose_generic.c \
|
||||
intrinsics/tty.c \
|
||||
intrinsics/umask.c \
|
||||
intrinsics/unlink.c \
|
||||
intrinsics/unpack_generic.c \
|
||||
|
|
|
|||
|
|
@ -140,7 +140,7 @@ am__objects_33 = associated.lo abort.lo args.lo bessel.lo \
|
|||
rand.lo random.lo rename.lo reshape_generic.lo \
|
||||
reshape_packed.lo selected_int_kind.lo selected_real_kind.lo \
|
||||
stat.lo symlnk.lo system_clock.lo time.lo transpose_generic.lo \
|
||||
umask.lo unlink.lo unpack_generic.lo in_pack_generic.lo \
|
||||
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_i4.lo _abs_i8.lo \
|
||||
|
|
@ -379,6 +379,7 @@ intrinsics/symlnk.c \
|
|||
intrinsics/system_clock.c \
|
||||
intrinsics/time.c \
|
||||
intrinsics/transpose_generic.c \
|
||||
intrinsics/tty.c \
|
||||
intrinsics/umask.c \
|
||||
intrinsics/unlink.c \
|
||||
intrinsics/unpack_generic.c \
|
||||
|
|
@ -1385,6 +1386,9 @@ time.lo: intrinsics/time.c
|
|||
transpose_generic.lo: intrinsics/transpose_generic.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o transpose_generic.lo `test -f 'intrinsics/transpose_generic.c' || echo '$(srcdir)/'`intrinsics/transpose_generic.c
|
||||
|
||||
tty.lo: intrinsics/tty.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o tty.lo `test -f 'intrinsics/tty.c' || echo '$(srcdir)/'`intrinsics/tty.c
|
||||
|
||||
umask.lo: intrinsics/umask.c
|
||||
$(LIBTOOL) --mode=compile $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS) -c -o umask.lo `test -f 'intrinsics/umask.c' || echo '$(srcdir)/'`intrinsics/umask.c
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,97 @@
|
|||
/* Implementation of the ISATTY and TTYNAM g77 intrinsics.
|
||||
Copyright (C) 2005 Free Software Foundation, Inc.
|
||||
Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
|
||||
|
||||
This file is part of the GNU Fortran 95 runtime library (libgfortran).
|
||||
|
||||
Libgfortran is free software; you can redistribute it and/or
|
||||
modify it under the terms of the GNU General Public
|
||||
License as published by the Free Software Foundation; either
|
||||
version 2 of the License, or (at your option) any later version.
|
||||
|
||||
In addition to the permissions in the GNU General Public License, the
|
||||
Free Software Foundation gives you unlimited permission to link the
|
||||
compiled version of this file into combinations with other programs,
|
||||
and to distribute those combinations without any restriction coming
|
||||
from the use of this file. (The General Public License restrictions
|
||||
do apply in other respects; for example, they cover modification of
|
||||
the file, and distribution when not linked into a combine
|
||||
executable.)
|
||||
|
||||
Libgfortran is distributed in the hope that it will be useful,
|
||||
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
GNU General Public License for more details.
|
||||
|
||||
You should have received a copy of the GNU General Public
|
||||
License along with libgfortran; see the file COPYING. If not,
|
||||
write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
|
||||
Boston, MA 02111-1307, USA. */
|
||||
|
||||
#include "config.h"
|
||||
#include "libgfortran.h"
|
||||
#include "../io/io.h"
|
||||
#include <string.h>
|
||||
|
||||
/* LOGICAL FUNCTION ISATTY(UNIT)
|
||||
INTEGER, INTENT(IN) :: UNIT */
|
||||
|
||||
extern GFC_LOGICAL_4 isatty_l4 (int *);
|
||||
export_proto(isatty_l4);
|
||||
|
||||
GFC_LOGICAL_4
|
||||
isatty_l4 (int *unit)
|
||||
{
|
||||
gfc_unit *u;
|
||||
|
||||
u = find_unit (*unit);
|
||||
if (u != NULL)
|
||||
return (GFC_LOGICAL_4) stream_isatty (u->s);
|
||||
else
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
extern GFC_LOGICAL_8 isatty_l8 (int *);
|
||||
export_proto(isatty_l8);
|
||||
|
||||
GFC_LOGICAL_8
|
||||
isatty_l8 (int *unit)
|
||||
{
|
||||
gfc_unit *u;
|
||||
|
||||
u = find_unit (*unit);
|
||||
if (u != NULL)
|
||||
return (GFC_LOGICAL_8) stream_isatty (u->s);
|
||||
else
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* SUBROUTINE TTYNAM(UNIT,NAME)
|
||||
INTEGER,SCALAR,INTENT(IN) :: UNIT
|
||||
CHARACTER,SCALAR,INTENT(OUT) :: NAME */
|
||||
|
||||
extern void ttynam_sub (int *, char *, gfc_charlen_type);
|
||||
export_proto(ttynam_sub);
|
||||
|
||||
void
|
||||
ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
|
||||
{
|
||||
gfc_unit *u;
|
||||
char * n;
|
||||
int i;
|
||||
|
||||
memset (name, ' ', name_len);
|
||||
u = find_unit (*unit);
|
||||
if (u != NULL)
|
||||
{
|
||||
n = stream_ttyname (u->s);
|
||||
if (n != NULL)
|
||||
{
|
||||
i = 0;
|
||||
while (*n && i < name_len)
|
||||
name[i++] = *(n++);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
|
@ -496,6 +496,12 @@ internal_proto(empty_internal_buffer);
|
|||
extern try flush (stream *);
|
||||
internal_proto(flush);
|
||||
|
||||
extern int stream_isatty (stream *);
|
||||
internal_proto(stream_isatty);
|
||||
|
||||
extern char * stream_ttyname (stream *);
|
||||
internal_proto(stream_ttyname);
|
||||
|
||||
extern int unit_to_fd (int);
|
||||
internal_proto(unit_to_fd);
|
||||
|
||||
|
|
|
|||
|
|
@ -1536,6 +1536,18 @@ flush (stream *s)
|
|||
return fd_flush( (unix_stream *) s);
|
||||
}
|
||||
|
||||
int
|
||||
stream_isatty (stream *s)
|
||||
{
|
||||
return isatty (((unix_stream *) s)->fd);
|
||||
}
|
||||
|
||||
char *
|
||||
stream_ttyname (stream *s)
|
||||
{
|
||||
return ttyname (((unix_stream *) s)->fd);
|
||||
}
|
||||
|
||||
|
||||
/* 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