intrinsic.c (add_functions): Add function version of TTYNAM.

	* 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.

	* intrinsics/tty.c (ttynam): New function.

From-SVN: r106522

gcc/fortran/ChangeLog

+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

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.  */
 

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,

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);

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 *);

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)

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,

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;

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;

libgfortran/ChangeLog

+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

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;
+}