OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

intrinsic.h (gfc_resolve_rank): New prototype. 

2012-06-18  Tobias Burnus  <burnus@net-b.de>

        * intrinsic.h (gfc_resolve_rank): New prototype.
        * intrinsic.c (add_functions): Use gfc_resolve_rank.
        * iresolve.c (add_functions): New function.
        * trans-intrinsic.c (gfc_conv_intrinsic_rank): New function.
        (gfc_conv_intrinsic_function): Call it.

From-SVN: r188751
This commit is contained in:
Tobias Burnus 2012-06-18 20:37:16 +02:00 committed by Tobias Burnus
parent 478ad83d94
commit 32e7b05d82
5 changed files with 49 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
gcc/fortran/ChangeLog
View File

@ -1,3 +1,11 @@
2012-06-18 Tobias Burnus <burnus@net-b.de>
* intrinsic.h (gfc_resolve_rank): New prototype.
* intrinsic.c (add_functions): Use gfc_resolve_rank.
* iresolve.c (add_functions): New function.
* trans-intrinsic.c (gfc_conv_intrinsic_rank): New function.
(gfc_conv_intrinsic_function): Call it.
2012-06-18 Tobias Burnus <burnus@net-b.de>
PR fortran/53692

2
gcc/fortran/intrinsic.c
View File

@ -2434,7 +2434,7 @@ add_functions (void)
make_generic ("range", GFC_ISYM_RANGE, GFC_STD_F95);
add_sym_1 ("rank", GFC_ISYM_RANK, CLASS_INQUIRY, ACTUAL_NO, BT_INTEGER, di,
GFC_STD_F2008_TS, gfc_check_rank, gfc_simplify_rank, NULL,
GFC_STD_F2008_TS, gfc_check_rank, gfc_simplify_rank, gfc_resolve_rank,
a, BT_REAL, dr, REQUIRED);
make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2008_TS);

1
gcc/fortran/intrinsic.h
View File

@ -486,6 +486,7 @@ void gfc_resolve_long (gfc_expr *, gfc_expr *);
void gfc_resolve_ior (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_iparity (gfc_expr *, gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_isatty (gfc_expr *, gfc_expr *);
void gfc_resolve_rank (gfc_expr *, gfc_expr *);
void gfc_resolve_rshift (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_lshift (gfc_expr *, gfc_expr *, gfc_expr *);
void gfc_resolve_ishft (gfc_expr *, gfc_expr *, gfc_expr *);

9
gcc/fortran/iresolve.c
View File

@ -2005,6 +2005,15 @@ gfc_resolve_product (gfc_expr *f, gfc_expr *array, gfc_expr *dim,
}
void
gfc_resolve_rank (gfc_expr *f, gfc_expr *array ATTRIBUTE_UNUSED)
{
f->ts.type = BT_INTEGER;
f->ts.kind = gfc_default_integer_kind;
f->value.function.name = gfc_get_string ("__rank");
}
void
gfc_resolve_real (gfc_expr *f, gfc_expr *a, gfc_expr *kind)
{

30
gcc/fortran/trans-intrinsic.c
View File

@ -1316,6 +1316,32 @@ trans_num_images (gfc_se * se)
}
static void
gfc_conv_intrinsic_rank (gfc_se *se, gfc_expr *expr)
{
gfc_se argse;
gfc_ss *ss;
tree dtype, tmp;
ss = gfc_walk_expr (expr->value.function.actual->expr);
gcc_assert (ss != gfc_ss_terminator);
gfc_init_se (&argse, NULL);
argse.data_not_needed = 1;
argse.want_pointer = 1;
gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
gfc_add_block_to_block (&se->pre, &argse.pre);
gfc_add_block_to_block (&se->post, &argse.post);
argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
argse.expr = build_fold_indirect_ref_loc (input_location, argse.expr);
dtype = gfc_conv_descriptor_dtype (argse.expr);
tmp = build_int_cst (TREE_TYPE (dtype), GFC_DTYPE_RANK_MASK);
tmp = fold_build2_loc (input_location, BIT_AND_EXPR, TREE_TYPE (dtype),
dtype, tmp);
se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind), tmp);
}
/* Evaluate a single upper or lower bound. */
/* TODO: bound intrinsic generates way too much unnecessary code. */
@ -6710,6 +6736,10 @@ gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
break;
case GFC_ISYM_RANK:
gfc_conv_intrinsic_rank (se, expr);
break;
case GFC_ISYM_RRSPACING:
gfc_conv_intrinsic_rrspacing (se, expr);
break;