diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1aacb2025469a6d4ec30f4a7f53daa47415ee781..8adf0bc9797a71bbfa3b5a77587ecedb9bdec95e 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,17 @@
+2005-11-05 Francois-Xavier Coudert <coudert@clipper.ens.fr>
+
+ * intrinsic.c (add_functions): Add function version of TTYNAM.
+ * intrinsic.h: Add prototypes for gfc_check_ttynam and
+ gfc_resolve_ttynam.
+ * gfortran.h: Add case for GFC_ISYM_TTYNAM.
+ * iresolve.c (gfc_resolve_ttynam): New function.
+ * trans-decl.c (gfc_build_intrinsic_function_decls): Add a tree
+ for function call to library ttynam.
+ * check.c (gfc_check_ttynam): New function.
+ * trans-intrinsic.c (gfc_conv_intrinsic_ttynam): New function.
+ (): Call gfc_conv_intrinsic_ttynam.
+ * trans.h: Add prototype for gfor_fndecl_ttynam.
+
2005-11-04 Steven G. Kargl <kargls@comcast.net>
PR fortran/24636
diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c
index fe96ea4dc9171b9f9ad0ade607dec48c6af54e7b..ec7f6b81828cac8aad381e99f327ae93c7fdbaea 100644
--- a/gcc/fortran/check.c
+++ b/gcc/fortran/check.c
@@ -2182,6 +2182,19 @@ gfc_check_trim (gfc_expr * x)
}
+try
+gfc_check_ttynam (gfc_expr * unit)
+{
+ if (scalar_check (unit, 0) == FAILURE)
+ return FAILURE;
+
+ if (type_check (unit, 0, BT_INTEGER) == FAILURE)
+ return FAILURE;
+
+ return SUCCESS;
+}
+
+
/* Common check function for the half a dozen intrinsics that have a
single real argument. */
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 46c5bd2186fcbe6cc38a1229c4a3d3e9b9f90934..daea7ce30f28d4d688b367bfdde7adb25f14adc2 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -413,6 +413,7 @@ enum gfc_generic_isym_id
GFC_ISYM_TRANSFER,
GFC_ISYM_TRANSPOSE,
GFC_ISYM_TRIM,
+ GFC_ISYM_TTYNAM,
GFC_ISYM_UBOUND,
GFC_ISYM_UMASK,
GFC_ISYM_UNLINK,
diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c
index a577ed9f9d79689827f8fe7f3241de27c3c62efd..96ba02b2545f52fbd630d3369dedc4bab1c51139 100644
--- a/gcc/fortran/intrinsic.c
+++ b/gcc/fortran/intrinsic.c
@@ -2084,6 +2084,12 @@ add_functions (void)
make_generic ("trim", GFC_ISYM_TRIM, GFC_STD_F95);
+ add_sym_1 ("ttynam", 0, 1, BT_CHARACTER, 0, GFC_STD_GNU,
+ gfc_check_ttynam, NULL, gfc_resolve_ttynam,
+ ut, BT_INTEGER, di, REQUIRED);
+
+ make_generic ("ttynam", GFC_ISYM_TTYNAM, GFC_STD_GNU);
+
add_sym_2 ("ubound", 0, 1, BT_INTEGER, di, GFC_STD_F95,
gfc_check_ubound, gfc_simplify_ubound, gfc_resolve_ubound,
ar, BT_REAL, dr, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL);
diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h
index 51334b4336abcab8a5bef56d065420a87f675667..ab378bf7d8b65c9a34b9024e3ad303181536006a 100644
--- a/gcc/fortran/intrinsic.h
+++ b/gcc/fortran/intrinsic.h
@@ -120,6 +120,7 @@ try gfc_check_symlnk (gfc_expr *, gfc_expr *);
try gfc_check_transfer (gfc_expr *, gfc_expr *, gfc_expr *);
try gfc_check_transpose (gfc_expr *);
try gfc_check_trim (gfc_expr *);
+try gfc_check_ttynam (gfc_expr *);
try gfc_check_ubound (gfc_expr *, gfc_expr *);
try gfc_check_umask (gfc_expr *);
try gfc_check_unlink (gfc_expr *);
@@ -386,6 +387,7 @@ void gfc_resolve_time8 (gfc_expr *);
void gfc_resolve_transfer (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_transpose (gfc_expr *, gfc_expr *);
void gfc_resolve_trim (gfc_expr *, gfc_expr *);
+void gfc_resolve_ttynam (gfc_expr *, gfc_expr *);
void gfc_resolve_ubound (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_umask (gfc_expr *, gfc_expr *);
void gfc_resolve_unlink (gfc_expr *, gfc_expr *);
diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c
index 47a494dd0fb98d2f17605221efbeb4521e94962c..4973eb43e0da26c4818277cd8ac267e6a55da3e0 100644
--- a/gcc/fortran/iresolve.c
+++ b/gcc/fortran/iresolve.c
@@ -1722,6 +1722,28 @@ gfc_resolve_unlink (gfc_expr * f, gfc_expr * n ATTRIBUTE_UNUSED)
f->value.function.name = gfc_get_string (PREFIX("unlink"));
}
+
+void
+gfc_resolve_ttynam (gfc_expr * f, gfc_expr * unit)
+{
+ gfc_typespec ts;
+
+ f->ts.type = BT_CHARACTER;
+ f->ts.kind = gfc_default_character_kind;
+
+ 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);
+ }
+
+ f->value.function.name = gfc_get_string (PREFIX("ttynam"));
+}
+
+
void
gfc_resolve_unpack (gfc_expr * f, gfc_expr * vector, gfc_expr * mask,
gfc_expr * field ATTRIBUTE_UNUSED)
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index dce409557efc98a8258906085e4ab73e3914f60f..6b349a854a6d8970f314e7897f40ca69f6e8b8e8 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -87,6 +87,7 @@ tree gfor_fndecl_select_string;
tree gfor_fndecl_runtime_error;
tree gfor_fndecl_set_fpe;
tree gfor_fndecl_set_std;
+tree gfor_fndecl_ttynam;
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
tree gfor_fndecl_associated;
@@ -1780,6 +1781,7 @@ gfc_build_intrinsic_function_decls (void)
tree gfc_complex8_type_node = gfc_get_complex_type (8);
tree gfc_complex10_type_node = gfc_get_complex_type (10);
tree gfc_complex16_type_node = gfc_get_complex_type (16);
+ tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
/* String functions. */
gfor_fndecl_copy_string =
@@ -1849,6 +1851,14 @@ gfc_build_intrinsic_function_decls (void)
pchar_type_node,
gfc_int4_type_node);
+ gfor_fndecl_ttynam =
+ gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
+ void_type_node,
+ 3,
+ pchar_type_node,
+ gfc_charlen_type_node,
+ gfc_c_int_type_node);
+
gfor_fndecl_adjustl =
gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
void_type_node,
diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c
index b81b543a2710cc68581cb5e1569b4ac248157283..8a1fa0c4729c24a5ae8f5e8a4c5012b2909ad3dc 100644
--- a/gcc/fortran/trans-intrinsic.c
+++ b/gcc/fortran/trans-intrinsic.c
@@ -1037,6 +1037,44 @@ gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
}
+/* Return a character string containing the tty name. */
+
+static void
+gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
+{
+ tree var;
+ tree len;
+ tree tmp;
+ tree arglist;
+ tree type;
+ tree cond;
+ tree gfc_int4_type_node = gfc_get_int_type (4);
+
+ type = build_pointer_type (gfc_character1_type_node);
+ var = gfc_create_var (type, "pstr");
+ len = gfc_create_var (gfc_int4_type_node, "len");
+
+ tmp = gfc_conv_intrinsic_function_args (se, expr);
+ arglist = gfc_chainon_list (NULL_TREE, gfc_build_addr_expr (NULL, var));
+ arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
+ arglist = chainon (arglist, tmp);
+
+ tmp = gfc_build_function_call (gfor_fndecl_ttynam, arglist);
+ gfc_add_expr_to_block (&se->pre, tmp);
+
+ /* Free the temporary afterwards, if necessary. */
+ cond = build2 (GT_EXPR, boolean_type_node, len,
+ build_int_cst (TREE_TYPE (len), 0));
+ arglist = gfc_chainon_list (NULL_TREE, var);
+ tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
+ tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
+ gfc_add_expr_to_block (&se->post, tmp);
+
+ se->expr = var;
+ se->string_length = len;
+}
+
+
/* Get the minimum/maximum value of all the parameters.
minmax (a1, a2, a3, ...)
{
@@ -3073,6 +3111,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_transfer (se, expr);
break;
+ case GFC_ISYM_TTYNAM:
+ gfc_conv_intrinsic_ttynam (se, expr);
+ break;
+
case GFC_ISYM_UBOUND:
gfc_conv_intrinsic_bound (se, expr, 1);
break;
diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index 16d0a37ed3fa77f068dc1eff619c9ca1a8ee0a4a..30731a63714b4021fee90c3788a1806940ff130f 100644
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -457,6 +457,7 @@ extern GTY(()) tree gfor_fndecl_select_string;
extern GTY(()) tree gfor_fndecl_runtime_error;
extern GTY(()) tree gfor_fndecl_set_fpe;
extern GTY(()) tree gfor_fndecl_set_std;
+extern GTY(()) tree gfor_fndecl_ttynam;
extern GTY(()) tree gfor_fndecl_in_pack;
extern GTY(()) tree gfor_fndecl_in_unpack;
extern GTY(()) tree gfor_fndecl_associated;
diff --git a/libgfortran/ChangeLog b/libgfortran/ChangeLog
index bb8e3323d1a6b9bb6c6f573afaf6b0e99f28dbe9..0459b6ba9e6fd0f7383ebdd9e714f7766db3247a 100644
--- a/libgfortran/ChangeLog
+++ b/libgfortran/ChangeLog
@@ -1,3 +1,7 @@
+2005-11-05 Francois-Xavier Coudert <coudert@clipper.ens.fr>
+
+ * intrinsics/tty.c (ttynam): New function.
+
2005-11-04 Steven G. Kargl <kargls@comcast.net>
PR fortran/24636
diff --git a/libgfortran/intrinsics/tty.c b/libgfortran/intrinsics/tty.c
index 3a3d2bdb98c7a4b7a8401280f88efe96c5c0fda8..f4bfecd935317c9e7e7cbb372ada0bfc816cc7cc 100644
--- a/libgfortran/intrinsics/tty.c
+++ b/libgfortran/intrinsics/tty.c
@@ -31,6 +31,7 @@ Boston, MA 02110-1301, USA. */
#include "config.h"
#include "libgfortran.h"
#include "../io/io.h"
+
#include <string.h>
/* LOGICAL FUNCTION ISATTY(UNIT)
@@ -95,3 +96,28 @@ ttynam_sub (int *unit, char * name, gfc_charlen_type name_len)
}
}
}
+
+
+extern void ttynam (char **, gfc_charlen_type *, int);
+export_proto(ttynam);
+
+void
+ttynam (char ** name, gfc_charlen_type * name_len, int unit)
+{
+ gfc_unit *u;
+
+ u = find_unit (unit);
+ if (u != NULL)
+ {
+ *name = stream_ttyname (u->s);
+ if (*name != NULL)
+ {
+ *name_len = strlen (*name);
+ *name = strdup (*name);
+ return;
+ }
+ }
+
+ *name_len = 0;
+ *name = NULL;
+}