procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

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

Browse source 
* 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
This commit is contained in:
Francois-Xavier Coudert 2005-11-05 09:34:07 +01:00 • committed by François-Xavier Coudert
parent 5a522c1580
commit 25fc05eb62
11 changed files with 141 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
gcc/fortran/ChangeLog
View file

@ -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

13
gcc/fortran/check.c
View file

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

1
gcc/fortran/gfortran.h
View file

@ -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,

6
gcc/fortran/intrinsic.c
View file

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

2
gcc/fortran/intrinsic.h
View file

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

22
gcc/fortran/iresolve.c
View file

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

10
gcc/fortran/trans-decl.c
View file

@ -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,

42
gcc/fortran/trans-intrinsic.c
View file

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

1
gcc/fortran/trans.h
View file

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

4
libgfortran/ChangeLog
View file

@ -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

26
libgfortran/intrinsics/tty.c
View file

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