From 32e7b05d82d19fa9eefd489a18cd924e7d5ceb39 Mon Sep 17 00:00:00 2001 From: Tobias Burnus Date: Mon, 18 Jun 2012 20:37:16 +0200 Subject: [PATCH] intrinsic.h (gfc_resolve_rank): New prototype. 2012-06-18 Tobias Burnus * 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 --- gcc/fortran/ChangeLog | 8 ++++++++ gcc/fortran/intrinsic.c | 2 +- gcc/fortran/intrinsic.h | 1 + gcc/fortran/iresolve.c | 9 +++++++++ gcc/fortran/trans-intrinsic.c | 30 ++++++++++++++++++++++++++++++ 5 files changed, 49 insertions(+), 1 deletion(-) diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index a89e197f954..ef2dc36166b 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,11 @@ +2012-06-18 Tobias Burnus + + * 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 PR fortran/53692 diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index 38bcb273fdd..88d4636bd71 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -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); diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index bfc2455cfd2..2635ba6d3da 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -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 *); diff --git a/gcc/fortran/iresolve.c b/gcc/fortran/iresolve.c index 9d94e3b9107..2a494550bbc 100644 --- a/gcc/fortran/iresolve.c +++ b/gcc/fortran/iresolve.c @@ -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) { diff --git a/gcc/fortran/trans-intrinsic.c b/gcc/fortran/trans-intrinsic.c index 8cce42744bf..c74e81a011e 100644 --- a/gcc/fortran/trans-intrinsic.c +++ b/gcc/fortran/trans-intrinsic.c @@ -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; -- 2.30.2