+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
}
+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)
{
GFC_ISYM_INT,
GFC_ISYM_IOR,
GFC_ISYM_IRAND,
+ GFC_ISYM_ISATTY,
GFC_ISYM_ISHFT,
GFC_ISYM_ISHFTC,
GFC_ISYM_KILL,
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);
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);
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 *);
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 *);
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 *);
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 *);
}
+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)
{
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
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:
+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
intrinsics/system_clock.c \
intrinsics/time.c \
intrinsics/transpose_generic.c \
+intrinsics/tty.c \
intrinsics/umask.c \
intrinsics/unlink.c \
intrinsics/unpack_generic.c \
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 \
intrinsics/system_clock.c \
intrinsics/time.c \
intrinsics/transpose_generic.c \
+intrinsics/tty.c \
intrinsics/umask.c \
intrinsics/unlink.c \
intrinsics/unpack_generic.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
--- /dev/null
+/* 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++);
+ }
+ }
+}
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);
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.
projects / gcc.git / commitdiff