From patchwork Sun May 22 16:40:47 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Tobias Burnus X-Patchwork-Id: 96759 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id D2992B6FB8 for ; Mon, 23 May 2011 02:41:09 +1000 (EST) Received: (qmail 21628 invoked by alias); 22 May 2011 16:41:07 -0000 Received: (qmail 21605 invoked by uid 22791); 22 May 2011 16:41:05 -0000 X-SWARE-Spam-Status: No, hits=-1.0 required=5.0 tests=AWL, BAYES_00, KAM_STOCKGEN, RCVD_IN_DNSWL_NONE X-Spam-Check-By: sourceware.org Received: from mx01.qsc.de (HELO mx01.qsc.de) (213.148.129.14) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Sun, 22 May 2011 16:40:49 +0000 Received: from [192.168.178.22] (port-92-204-35-67.dynamic.qsc.de [92.204.35.67]) by mx01.qsc.de (Postfix) with ESMTP id BE13A3CEE3; Sun, 22 May 2011 18:40:47 +0200 (CEST) Message-ID: <4DD93C8F.3030905@net-b.de> Date: Sun, 22 May 2011 18:40:47 +0200 From: Tobias Burnus User-Agent: Mozilla/5.0 (X11; U; Linux x86_64; de; rv:1.9.2.14) Gecko/20110221 SUSE/3.1.8 Thunderbird/3.1.8 MIME-Version: 1.0 To: gcc patches , gfortran Subject: [Patch, Fortran] Add RANK intrinsic of TR 29113 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This patch adds the rank intrinsic of the TR 29113 draft. It is a bit boring until gfortran supports DIMENSION(..) ;-) Build and regtested on x86-64-linux. OK for the trunk? Tobias PS: The current draft of TR 29113 is available at http://j3-fortran.org/pipermail/interop-tr/2011-May/000710.html (version of Monday, 16 May) 2011-05-22 Tobias Burnus PR fortran/48820 * gfortran.h (gfc_isym_id): Add GFC_ISYM_RANK. * intrinsic.c (add_functions): Add rank intrinsic. (gfc_check_intrinsic_standard): Handle GFC_STD_F2008_TR. * intrinsic.h (gfc_simplify_rank, gfc_check_rank): Add prototypes. * simplify.c (gfc_simplify_rank): New function. * intrinsic.texi (RANK): Add description for rank intrinsic. * check.c (gfc_check_rank): New function. 2011-05-22 Tobias Burnus PR fortran/48820 * gfortran.dg/rank_3.f90: New. * gfortran.dg/rank_4.f90: New. diff --git a/gcc/fortran/check.c b/gcc/fortran/check.c index 8641142..01651cb 100644 --- a/gcc/fortran/check.c +++ b/gcc/fortran/check.c @@ -2830,6 +2830,33 @@ gfc_check_range (gfc_expr *x) } +gfc_try +gfc_check_rank (gfc_expr *a ATTRIBUTE_UNUSED) +{ + /* Any data object is allowed; a "data object" is a "constant (4.1.3), + variable (6), or subobject of a constant (2.4.3.2.3)" (F2008, 1.3.45). */ + + bool is_variable = true; + + /* Functions returning pointers are regarded as variable, cf. F2008, R602. */ + if (a->expr_type == EXPR_FUNCTION) + is_variable = a->value.function.esym + ? a->value.function.esym->result->attr.pointer + : a->symtree->n.sym->result->attr.pointer; + + if (a->expr_type == EXPR_OP || a->expr_type == EXPR_NULL + || a->expr_type == EXPR_COMPCALL|| a->expr_type == EXPR_PPC + || !is_variable) + { + gfc_error ("The argument of the RANK intrinsic at %L must be a data " + "object", &a->where); + return FAILURE; + } + + return SUCCESS; +} + + /* real, float, sngl. */ gfc_try gfc_check_real (gfc_expr *a, gfc_expr *kind) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 3b4967d..1f3be2d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -472,6 +472,7 @@ enum gfc_isym_id GFC_ISYM_RANDOM_NUMBER, GFC_ISYM_RANDOM_SEED, GFC_ISYM_RANGE, + GFC_ISYM_RANK, GFC_ISYM_REAL, GFC_ISYM_RENAME, GFC_ISYM_REPEAT, diff --git a/gcc/fortran/intrinsic.c b/gcc/fortran/intrinsic.c index c0eeb6d..6151db7 100644 --- a/gcc/fortran/intrinsic.c +++ b/gcc/fortran/intrinsic.c @@ -2433,6 +2433,11 @@ 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_TR, gfc_check_rank, gfc_simplify_rank, NULL, + a, BT_REAL, dr, REQUIRED); + make_generic ("rank", GFC_ISYM_RANK, GFC_STD_F2008_TR); + add_sym_2 ("real", GFC_ISYM_REAL, CLASS_ELEMENTAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F77, gfc_check_real, gfc_simplify_real, gfc_resolve_real, a, BT_UNKNOWN, dr, REQUIRED, kind, BT_INTEGER, di, OPTIONAL); @@ -3972,6 +3977,10 @@ gfc_check_intrinsic_standard (const gfc_intrinsic_sym* isym, symstd_msg = "new in Fortran 2008"; break; + case GFC_STD_F2008_TR: + symstd_msg = "new in TR 29113"; + break; + case GFC_STD_GNU: symstd_msg = "a GNU Fortran extension"; break; diff --git a/gcc/fortran/intrinsic.h b/gcc/fortran/intrinsic.h index 033bae0..88ce008 100644 --- a/gcc/fortran/intrinsic.h +++ b/gcc/fortran/intrinsic.h @@ -122,6 +122,7 @@ gfc_try gfc_check_product_sum (gfc_actual_arglist *); gfc_try gfc_check_radix (gfc_expr *); gfc_try gfc_check_rand (gfc_expr *); gfc_try gfc_check_range (gfc_expr *); +gfc_try gfc_check_rank (gfc_expr *); gfc_try gfc_check_real (gfc_expr *, gfc_expr *); gfc_try gfc_check_rename (gfc_expr *, gfc_expr *); gfc_try gfc_check_repeat (gfc_expr *, gfc_expr *); @@ -345,6 +346,7 @@ gfc_expr *gfc_simplify_precision (gfc_expr *); gfc_expr *gfc_simplify_product (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_radix (gfc_expr *); gfc_expr *gfc_simplify_range (gfc_expr *); +gfc_expr *gfc_simplify_rank (gfc_expr *); gfc_expr *gfc_simplify_real (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_realpart (gfc_expr *); gfc_expr *gfc_simplify_repeat (gfc_expr *, gfc_expr *); diff --git a/gcc/fortran/intrinsic.texi b/gcc/fortran/intrinsic.texi index 804b31f..2ea4fc5 100644 --- a/gcc/fortran/intrinsic.texi +++ b/gcc/fortran/intrinsic.texi @@ -236,6 +236,7 @@ Some basic guidelines for editing this document: * @code{RANDOM_SEED}: RANDOM_SEED, Initialize a pseudo-random number sequence * @code{RAND}: RAND, Real pseudo-random number * @code{RANGE}: RANGE, Decimal exponent range +* @code{RANK} : RANK, Rank of a data object * @code{RAN}: RAN, Real pseudo-random number * @code{REAL}: REAL, Convert to real type * @code{RENAME}: RENAME, Rename a file @@ -10115,6 +10116,47 @@ See @code{PRECISION} for an example. +@node RANK +@section @code{RANK} --- Rank of a data object +@fnindex RANK +@cindex rank + +@table @asis +@item @emph{Description}: +@code{RANK(A)} returns the rank of a scalar or array data object. + +@item @emph{Standard}: +Technical Report (TR) 29113 + +@item @emph{Class}: +Inquiry function + +@item @emph{Syntax}: +@code{RESULT = RANGE(A)} + +@item @emph{Arguments}: +@multitable @columnfractions .15 .70 +@item @var{A} @tab can be of any type +@end multitable + +@item @emph{Return value}: +The return value is of type @code{INTEGER} and of the default integer +kind. For arrays, their rank is returned; for scalars zero is returned. + +@item @emph{Example}: +@smallexample +program test_rank + integer :: a + real, allocatable :: b(:,:) + + print *, rank(a), rank(b) ! Prints: 0 3 +end program test_rank +@end smallexample + +@end table + + + @node REAL @section @code{REAL} --- Convert to real type @fnindex REAL diff --git a/gcc/fortran/simplify.c b/gcc/fortran/simplify.c index 4c91563..79b383a 100644 --- a/gcc/fortran/simplify.c +++ b/gcc/fortran/simplify.c @@ -4822,6 +4822,13 @@ gfc_simplify_range (gfc_expr *e) gfc_expr * +gfc_simplify_rank (gfc_expr *e) +{ + return gfc_get_int_expr (gfc_default_integer_kind, &e->where, e->rank); +} + + +gfc_expr * gfc_simplify_real (gfc_expr *e, gfc_expr *k) { gfc_expr *result = NULL; --- /dev/null 2011-05-21 08:12:20.995893248 +0200 +++ gcc/gcc/testsuite/gfortran.dg/rank_3.f90 2011-05-22 17:22:36.000000000 +0200 @@ -0,0 +1,7 @@ +! { dg-do compile } +! { dg-options "-std=f2008" } +! +! PR fortran/48820 +! +intrinsic :: rank ! { dg-error "new in TR 29113" } +end --- /dev/null 2011-05-21 08:12:20.995893248 +0200 +++ gcc/gcc/testsuite/gfortran.dg/rank_4.f90 2011-05-22 17:46:48.000000000 +0200 @@ -0,0 +1,19 @@ +! { dg-do compile } +! { dg-options "-std=f2008tr -fdump-tree-original" } +! +! PR fortran/48820 +! + +program test_rank + implicit none + intrinsic :: rank + + integer :: a + real, allocatable :: b(:,:) + + if (rank(a) /= 0) call not_existing() + if (rank (b) /= 2) call not_existing() +end program test_rank + +! { dg-final { scan-tree-dump-times "not_existing" 0 "original" } } +! { dg-final { cleanup-tree-dump "original" } }