From patchwork Fri Nov 20 00:58:36 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Steve Kargl X-Patchwork-Id: 546758 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id CBC8C14030D for ; Fri, 20 Nov 2015 11:58:57 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=FyV1cYVt; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type :content-transfer-encoding; q=dns; s=default; b=AH9Zus2Zkuc6IgHl sjLCzMrNJfnOYjr4NeSu6W1Ua7nWS05e9iT8Biz35dgm4TgTyTCeeCQiVM9us9iC fYkhh98R/RV1D7i33m03wLlVMhqnCBVTFJCqrJ2qLJX9i8O+Mt3zvtJyfD7ij+lk uuLBJ+r1SDhHssFIi3vH1TnqY9Q= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:subject:message-id:mime-version:content-type :content-transfer-encoding; s=default; bh=Bm3/ZnNkaZ8B9MY2QH4H30 uOIJ0=; b=FyV1cYVtjjdC5nGGfcqy0frPaPoTHGLEmznqt20/nGYwl9GrgbM9nV iRHMN5ie7ORLPUADWOjwTlpcrQnw/bGQ+vps4zP+60R4NJ6014vv7gLQPn0hPnS6 c2hBlPhhU7IWBphZgKnVaeK6EsTyiGnV2gpCgBBJOapcE/nArQzjk= Received: (qmail 33019 invoked by alias); 20 Nov 2015 00:58:41 -0000 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 Received: (qmail 32995 invoked by uid 89); 20 Nov 2015 00:58:40 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.3 required=5.0 tests=AWL, BAYES_20, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY, RP_MATCHES_RCVD autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: troutmask.apl.washington.edu Received: from troutmask.apl.washington.edu (HELO troutmask.apl.washington.edu) (128.95.76.21) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Fri, 20 Nov 2015 00:58:39 +0000 Received: from troutmask.apl.washington.edu (localhost [127.0.0.1]) by troutmask.apl.washington.edu (8.15.2/8.15.2) with ESMTPS id tAK0wbmZ053806 (version=TLSv1.2 cipher=DHE-RSA-AES256-GCM-SHA384 bits=256 verify=NO); Thu, 19 Nov 2015 16:58:37 -0800 (PST) (envelope-from sgk@troutmask.apl.washington.edu) Received: (from sgk@localhost) by troutmask.apl.washington.edu (8.15.2/8.15.2/Submit) id tAK0wanJ053805; Thu, 19 Nov 2015 16:58:36 -0800 (PST) (envelope-from sgk) Date: Thu, 19 Nov 2015 16:58:36 -0800 From: Steve Kargl To: fortran@gcc.gnu.org, gcc-patches@gcc.gnu.org Subject: [PATCH] (Partial) Implementation of simplificaiton of CSHIFT Message-ID: <20151120005836.GA53763@troutmask.apl.washington.edu> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.24 (2015-08-30) The attached patch provides a partial implementation for the simplification for CSHIFT. It is partial in that it only applies to rank 1 arrays. For arrays with rank > 1, gfc_simplify_cshift will issue an error. Here, the intent is that hopefully someone that knows what they are doing with supply a patch for rank > 1. The meat of the patch for rank = 1 may not be the most efficient. It copies the array elements from 'a' to 'result' in the circularly shifted order. It inefficiently always starts with the first element in 'a' to find the candidate element for next 'result' element. cr = gfc_constructor_first (result->value.constructor); for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr)) { j = (i + shft) % sz; ca = gfc_constructor_first (a->value.constructor); while (j-- > 0) ca = gfc_constructor_next (ca); cr->expr = gfc_copy_expr (ca->expr); } As the values are storied in a splay tree, there may be a more efficient way to split the splay and recombine it into a new. Anyway, I would like to commit the attached patch. Built and tested on x86_64-*-freebsd? 2015-11-19 Steven G. Kargl * intrinsic.h: Prototype for gfc_simplify_cshift * intrinsic.c (add_functions): Use gfc_simplify_cshift. * simplify.c (gfc_simplify_cshift): Implement simplification of CSHIFT. (gfc_simplify_spread): Remove a FIXME and add error condition. 2015-11-19 Steven G. Kargl * gfortran.dg/simplify_cshift_1.f90: New test. Index: gcc/fortran/intrinsic.c =================================================================== --- gcc/fortran/intrinsic.c (revision 230585) +++ gcc/fortran/intrinsic.c (working copy) @@ -1659,9 +1659,11 @@ add_functions (void) make_generic ("count", GFC_ISYM_COUNT, GFC_STD_F95); - add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, BT_REAL, dr, GFC_STD_F95, - gfc_check_cshift, NULL, gfc_resolve_cshift, - ar, BT_REAL, dr, REQUIRED, sh, BT_INTEGER, di, REQUIRED, + add_sym_3 ("cshift", GFC_ISYM_CSHIFT, CLASS_TRANSFORMATIONAL, ACTUAL_NO, + BT_REAL, dr, GFC_STD_F95, + gfc_check_cshift, gfc_simplify_cshift, gfc_resolve_cshift, + ar, BT_REAL, dr, REQUIRED, + sh, BT_INTEGER, di, REQUIRED, dm, BT_INTEGER, ii, OPTIONAL); make_generic ("cshift", GFC_ISYM_CSHIFT, GFC_STD_F95); Index: gcc/fortran/intrinsic.h =================================================================== --- gcc/fortran/intrinsic.h (revision 230585) +++ gcc/fortran/intrinsic.h (working copy) @@ -271,6 +271,7 @@ gfc_expr *gfc_simplify_conjg (gfc_expr * gfc_expr *gfc_simplify_cos (gfc_expr *); gfc_expr *gfc_simplify_cosh (gfc_expr *); gfc_expr *gfc_simplify_count (gfc_expr *, gfc_expr *, gfc_expr *); +gfc_expr *gfc_simplify_cshift (gfc_expr *, gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dcmplx (gfc_expr *, gfc_expr *); gfc_expr *gfc_simplify_dble (gfc_expr *); gfc_expr *gfc_simplify_digits (gfc_expr *); Index: gcc/fortran/simplify.c =================================================================== --- gcc/fortran/simplify.c (revision 230585) +++ gcc/fortran/simplify.c (working copy) @@ -1789,6 +1789,88 @@ gfc_simplify_count (gfc_expr *mask, gfc_ gfc_expr * +gfc_simplify_cshift (gfc_expr *array, gfc_expr *shift, gfc_expr *dim) +{ + gfc_expr *a; + + a = gfc_copy_expr (array); + + switch (a->expr_type) + { + case EXPR_VARIABLE: + case EXPR_ARRAY: + gfc_simplify_expr (a, 0); + if (!is_constant_array_expr (a)) + { + gfc_free_expr (a); + return NULL; + } + break; + default: + gcc_unreachable (); + } + + if (a->rank == 1) + { + gfc_constructor *ca, *cr; + gfc_expr *result; + mpz_t size; + int i, j, shft, sz; + + if (!gfc_is_constant_expr (shift)) + return NULL; + + shft = mpz_get_si (shift->value.integer); + + /* Special case: rank 1 array with no shift! */ + if (shft == 0) + return a; + + /* Case (i): If ARRAY has rank one, element i of the result is + ARRAY (1 + MODULO (i + SHIFT ­ 1, SIZE (ARRAY))). */ + + result = gfc_copy_expr (a); + mpz_init (size); + gfc_array_size (a, &size); + sz = mpz_get_si (size); + mpz_clear (size); + shft = shft < 0 ? 1 - shft : shft; + cr = gfc_constructor_first (result->value.constructor); + for (i = 0; i < sz; i++, cr = gfc_constructor_next (cr)) + { + j = (i + shft) % sz; + ca = gfc_constructor_first (a->value.constructor); + while (j-- > 0) + ca = gfc_constructor_next (ca); + cr->expr = gfc_copy_expr (ca->expr); + } + + gfc_free_expr (a); + return result; + } + else + { + int dm; + + if (dim) + { + if (!gfc_is_constant_expr (dim)) + return NULL; + + dm = mpz_get_si (dim->value.integer); + } + else + dm = 1; + + gfc_error ("Simplification of CSHIFT with an array with rank > 1 " + "no yet support"); + } + + return NULL; +} + + +gfc_expr * gfc_simplify_dcmplx (gfc_expr *x, gfc_expr *y) { return simplify_cmplx ("DCMPLX", x, y, gfc_default_double_kind); @@ -6089,10 +6171,11 @@ gfc_simplify_spread (gfc_expr *source, g } } else - /* FIXME: Returning here avoids a regression in array_simplify_1.f90. - Replace NULL with gcc_unreachable() after implementing - gfc_simplify_cshift(). */ - return NULL; + { + gfc_error ("Simplification of SPREAD at %L not yet implemented", + &source->where); + return &gfc_bad_expr; + } if (source->ts.type == BT_CHARACTER) result->ts.u.cl = source->ts.u.cl; Index: gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 =================================================================== --- gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 (nonexistent) +++ gcc/testsuite/gfortran.dg/simplify_cshift_1.f90 (working copy) @@ -0,0 +1,38 @@ +! { dg-do compile } +program foo + + implicit none + + type t + integer i + end type t + + type(t), parameter :: d(5) = [t(1), t(2), t(3), t(4), t(5)] + type(t) e(5), q(5) + + integer, parameter :: a(5) = [1, 2, 3, 4, 5] + integer i, b(5), c(5), v(5) + + c = [1, 2, 3, 4, 5] + + b = cshift(a, -2) + v = cshift(c, -2) + if (any(b /= v)) call abort + + b = cshift(a, 2) + v = cshift(c,2) + if (any(b /= v)) call abort + + b = cshift([1, 2, 3, 4, 5], 0) + if (any(b /= a)) call abort + b = cshift(2*a, 0) + if (any(b /= 2*a)) call abort + + e = [t(1), t(2), t(3), t(4), t(5)] + e = cshift(e, 3) + q = cshift(d, 3) + do i = 1, 5 + if (e(i)%i /= q(i)%i) call abort + end do + +end program foo