This is the mail archive of the
gcc-patches@gcc.gnu.org
mailing list for the GCC project.
[gfortran] add ISATTY and TTYNAM intrinsics
- From: FX Coudert <fxcoudert at gmail dot com>
- To: patch <gcc-patches at gcc dot gnu dot org>, gfortran <fortran at gcc dot gnu dot org>
- Cc: howarth at bromo dot msbb dot uc dot edu
- Date: Sun, 07 Aug 2005 19:25:28 +0200
- Subject: [gfortran] add ISATTY and TTYNAM intrinsics
Attached patch (with testcase and ChangeLog entries) adds g77 ISATTY and
TTYNAM intrinsics to gfortran.
Built and regtested on i686-linux. OK for mainline and 4.0?
FX
:ADDPATCH fortran:
2005-08-07 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-07 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.
? libgfortran/intrinsics/tty.c
Index: gcc/fortran/check.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/check.c,v
retrieving revision 1.32
diff -u -3 -p -r1.32 check.c
--- gcc/fortran/check.c 25 Jun 2005 00:40:33 -0000 1.32
+++ gcc/fortran/check.c 7 Aug 2005 17:04:35 -0000
@@ -2574,6 +2574,38 @@ gfc_check_hostnm_sub (gfc_expr * name, g
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)
{
if (type_check (string, 0, BT_CHARACTER) == FAILURE)
Index: gcc/fortran/gfortran.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/gfortran.h,v
retrieving revision 1.76
diff -u -3 -p -r1.76 gfortran.h
--- gcc/fortran/gfortran.h 14 Jul 2005 10:12:16 -0000 1.76
+++ gcc/fortran/gfortran.h 7 Aug 2005 17:04:35 -0000
@@ -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,
Index: gcc/fortran/intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.c,v
retrieving revision 1.52
diff -u -3 -p -r1.52 intrinsic.c
--- gcc/fortran/intrinsic.c 7 Jul 2005 07:54:42 -0000 1.52
+++ gcc/fortran/intrinsic.c 7 Aug 2005 17:04:35 -0000
@@ -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);
@@ -2246,6 +2252,10 @@ add_subroutines (void)
gfc_check_system_clock, NULL, gfc_resolve_system_clock,
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,
Index: gcc/fortran/intrinsic.h
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/intrinsic.h,v
retrieving revision 1.31
diff -u -3 -p -r1.31 intrinsic.h
--- gcc/fortran/intrinsic.h 25 Jun 2005 00:40:35 -0000 1.31
+++ gcc/fortran/intrinsic.h 7 Aug 2005 17:04:35 -0000
@@ -70,6 +70,7 @@ try gfc_check_index (gfc_expr *, gfc_exp
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 *, gf
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_
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 *);
Index: gcc/fortran/iresolve.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/iresolve.c,v
retrieving revision 1.36
diff -u -3 -p -r1.36 iresolve.c
--- gcc/fortran/iresolve.c 25 Jun 2005 00:40:35 -0000 1.36
+++ gcc/fortran/iresolve.c 7 Aug 2005 17:04:35 -0000
@@ -712,6 +712,26 @@ gfc_resolve_int (gfc_expr * f, gfc_expr
void
+gfc_resolve_isatty (gfc_expr * f, gfc_expr * u)
+{
+ gfc_typespec ts;
+
+ f->ts.type = BT_LOGICAL;
+ f->ts.kind = gfc_default_logical_kind;
+ if (u->ts.kind != f->ts.kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_default_integer_kind;
+ ts.derived = NULL;
+ ts.cl = NULL;
+ gfc_convert_type (u, &ts, 2);
+ }
+
+ f->value.function.name = gfc_get_string (PREFIX("isatty_i%d"), f->ts.kind);
+}
+
+
+void
gfc_resolve_ishft (gfc_expr * f, gfc_expr * i, gfc_expr * shift)
{
f->ts = i->ts;
@@ -1938,6 +1958,26 @@ gfc_resolve_fstat_sub (gfc_code * c)
name = gfc_get_string (PREFIX("fstat_i%d_sub"), ts->kind);
c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
}
+
+
+void
+gfc_resolve_ttynam_sub (gfc_code * c)
+{
+ const char *name;
+ gfc_typespec ts;
+
+ if (c->ext.actual->expr->ts.kind != gfc_default_integer_kind)
+ {
+ ts.type = BT_INTEGER;
+ ts.kind = gfc_default_integer_kind;
+ ts.derived = NULL;
+ ts.cl = NULL;
+ gfc_convert_type (c->ext.actual->expr, &ts, 2);
+ }
+ name = gfc_get_string (PREFIX("ttynam_i%d_sub"), gfc_default_integer_kind);
+ c->resolved_sym = gfc_get_intrinsic_sub_symbol (name);
+}
+
/* Resolve the UMASK intrinsic subroutine. */
Index: gcc/fortran/trans-intrinsic.c
===================================================================
RCS file: /cvsroot/gcc/gcc/gcc/fortran/trans-intrinsic.c,v
retrieving revision 1.52
diff -u -3 -p -r1.52 trans-intrinsic.c
--- gcc/fortran/trans-intrinsic.c 25 Jun 2005 00:40:36 -0000 1.52
+++ gcc/fortran/trans-intrinsic.c 7 Aug 2005 17:04:35 -0000
@@ -2996,6 +2996,7 @@ gfc_conv_intrinsic_function (gfc_se * se
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:
Index: libgfortran/Makefile.am
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/Makefile.am,v
retrieving revision 1.38
diff -u -3 -p -r1.38 Makefile.am
--- libgfortran/Makefile.am 24 Jun 2005 23:07:13 -0000 1.38
+++ libgfortran/Makefile.am 7 Aug 2005 17:04:38 -0000
@@ -87,6 +87,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 \
Index: libgfortran/io/io.h
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/io.h,v
retrieving revision 1.23
diff -u -3 -p -r1.23 io.h
--- libgfortran/io/io.h 6 Aug 2005 22:57:46 -0000 1.23
+++ libgfortran/io/io.h 7 Aug 2005 17:04:38 -0000
@@ -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);
Index: libgfortran/io/unix.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/unix.c,v
retrieving revision 1.32
diff -u -3 -p -r1.32 unix.c
--- libgfortran/io/unix.c 6 Aug 2005 22:57:46 -0000 1.32
+++ libgfortran/io/unix.c 7 Aug 2005 17:04:38 -0000
@@ -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.
/* 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_i4 (GFC_INTEGER_4 *);
export_proto(isatty_i4);
GFC_LOGICAL_4
isatty_i4 (GFC_INTEGER_4 *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_i8 (GFC_INTEGER_8 *);
export_proto(isatty_i8);
GFC_LOGICAL_8
isatty_i8 (GFC_INTEGER_8 *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_i4_sub (GFC_INTEGER_4 *, char *, gfc_charlen_type);
export_proto(ttynam_i4_sub);
void
ttynam_i4_sub (GFC_INTEGER_4 *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++);
}
}
}
extern void ttynam_i8_sub (GFC_INTEGER_8 *, char *, gfc_charlen_type);
export_proto(ttynam_i8_sub);
void
ttynam_i8_sub (GFC_INTEGER_8 *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++);
}
}
}
! { dg-do run }
! This file tests the use of TTYNAM and ISATTY intrinsics
integer(kind=1) i1
integer(kind=2) i2
integer(kind=4) i4
integer(kind=8) i8
logical(kind=1) l1
logical(kind=2) l2
logical(kind=4) l4
logical(kind=8) l8
character(len=20) c
l1 = isatty(i1); l1 = isatty(i2); l1 = isatty(i4); l1 = isatty(i8)
l2 = isatty(i1); l1 = isatty(i2); l2 = isatty(i4); l2 = isatty(i8)
l4 = isatty(i1); l1 = isatty(i2); l4 = isatty(i4); l4 = isatty(i8)
l8 = isatty(i1); l1 = isatty(i2); l8 = isatty(i4); l8 = isatty(i8)
call ttynam (i1,c)
call ttynam (i2,c)
call ttynam (i4,c)
call ttynam (i8,c)
end