aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--gcc/fortran/ChangeLog14
-rw-r--r--gcc/fortran/check.c13
-rw-r--r--gcc/fortran/gfortran.h1
-rw-r--r--gcc/fortran/intrinsic.c6
-rw-r--r--gcc/fortran/intrinsic.h2
-rw-r--r--gcc/fortran/iresolve.c22
-rw-r--r--gcc/fortran/trans-decl.c10
-rw-r--r--gcc/fortran/trans-intrinsic.c42
-rw-r--r--gcc/fortran/trans.h1
-rw-r--r--libgfortran/ChangeLog4
-rw-r--r--libgfortran/intrinsics/tty.c26
11 files changed, 141 insertions, 0 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index 1aacb202546..8adf0bc9797 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 fe96ea4dc91..ec7f6b81828 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 46c5bd2186f..daea7ce30f2 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 a577ed9f9d7..96ba02b2545 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 51334b4336a..ab378bf7d8b 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 47a494dd0fb..4973eb43e0d 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 dce409557ef..6b349a854a6 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 b81b543a271..8a1fa0c4729 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 16d0a37ed3f..30731a63714 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 bb8e3323d1a..0459b6ba9e6 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 3a3d2bdb98c..f4bfecd9353 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;
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-06 12:54:41 +0000