From patchwork Thu Sep 7 10:09:34 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 810952 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-461677-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="l1IkEe8a"; dkim-atps=neutral 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 3xnx5h4ZhJz9s8J for ; Thu, 7 Sep 2017 20:10:00 +1000 (AEST) 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:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=fUjGkq1oOAwwWm27fnmp60ZZKoJc/ekaXWNfxp+JX0Oip/AfY4 GXjzNWGocmlSFfTm6VnMBKMqBhiIfiVjjG0kdpTP0xCebsHwHjtqgs8I/y+4W72y d4QU0gSz+FtODoGfF8XZFAEmhDkzYjRMPMMPVdHyanpsm4nUedZDM2++8= 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:cc:subject:message-id:mime-version:content-type; s= default; bh=MiswakWA61Fs6v/Uu8VB6ltzBa0=; b=l1IkEe8a3A3iiwTn5+0+ Xd0eP4VtAkUQRLLJNyoAqPrS8y2V+0xEiW55K0FFLnIYwWDBg3xENWaOKVyQQyyG 9oH7j8Wfk73jIKaYjJVHyJxFm0NdjSGBx5m5SSsMLjKe3yO0nAQEGe22czMYFdkM c31OWNodOaajf/6MIZ3HuUk= Received: (qmail 129534 invoked by alias); 7 Sep 2017 10:09:38 -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 129349 invoked by uid 89); 7 Sep 2017 10:09:37 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.1 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=sem, Degree, 2806 X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 07 Sep 2017 10:09:35 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 24F7E561B2; Thu, 7 Sep 2017 06:09:34 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id oDQcL8WeSogw; Thu, 7 Sep 2017 06:09:34 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 132DE561AC; Thu, 7 Sep 2017 06:09:34 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 107384FC; Thu, 7 Sep 2017 06:09:34 -0400 (EDT) Date: Thu, 7 Sep 2017 06:09:34 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Proper handling of dimension information in a type conversion. Message-ID: <20170907100934.GA69580@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch implements the proper handling of dimension information on type conversions. Given a conversion T (Expr), where the expression has type TE, the following cases arise: a) If TE has dimension information, the dimensions of the conversion are those of TE. b) If TE has no dimension information, dimensions of conversion are those of T. c) If T and TE belong to different dimension systems, they must have identical dimensions, unless T is the root type of its system, in which case dimensions are those of TE, and the conversion can be seen as a "view conversion" that preserves the dimensions of its argument. d) If T is a non-dimensioned type, such a Standard.Float, the conversion has no dimension information. The following must compile quietly: gcc -c main.adb gcc -c -gnatd.F main.adb --- with Units; use Units; procedure main with SPARK_Mode is subtype Servo_Angle_Type is Units.Angle_Type range -40.0 * Degree .. 40.0 * Degree; function Sat_Servo_Angle is new Saturated_Cast (Servo_Angle_Type); begin null; end main; --- with Ada.Numerics; package units with SPARK_Mode is type Unit_Type is new Float with Dimension_System => ((Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Theta"), (Unit_Name => Radian, Unit_Symbol => "Rad", Dim_Symbol => "A")), Default_Value => 0.0; -- required for matrices subtype Angle_Type is Unit_Type with Dimension => (Symbol => "Rad", Radian => 1, others => 0); Degree : constant Angle_Type := Angle_Type (2.0 * Ada.Numerics.Pi / 360.0); generic type T is digits <>; function Saturated_Cast (val : Float) return T with Inline; -- convert a float into a more specific float type, and trim -- to the value range end units; --- package body units with SPARK_Mode is function Saturated_Cast (val : Float) return T is ret : T; begin if val >= Float (T'Last) then ret := T'Last; elsif val <= Float (T'First) then ret := T'First; else ret := T (val); end if; return ret; end Saturated_Cast; end units; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-07 Ed Schonberg * sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure to handle properly various cases of type conversions where the target type and/or the expression carry dimension information. (Dimension_System_Root); If a subtype carries dimension information, obtain the source parent type that carries the Dimension aspect. Index: sem_dim.adb =================================================================== --- sem_dim.adb (revision 251836) +++ sem_dim.adb (working copy) @@ -35,6 +35,7 @@ with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -280,6 +281,14 @@ -- both the identifier and the parent type of N are not dimensionless, -- return an error. + procedure Analyze_Dimension_Type_Conversion (N : Node_Id); + -- Type conversions handle conversions between literals and dimensioned + -- types, from dimensioned types to their base type, and between different + -- dimensioned systems. Dimensions of the conversion are obtained either + -- from those of the expression, or from the target type, and dimensional + -- consistency must be checked when converting between values belonging + -- to different dimensioned systems. + procedure Analyze_Dimension_Unary_Op (N : Node_Id); -- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and -- Abs operators, propagate the dimensions from the operand to N. @@ -301,6 +310,11 @@ -- dimension" if Description_Needed. if N is dimensionless, return "'[']", -- or "is dimensionless" if Description_Needed. + function Dimension_System_Root (T : Entity_Id) return Entity_Id; + -- Given a type that has dimension information, return the type that is the + -- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned + -- type, i.e. a standard numeric type, return Empty. + procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id); -- Issue a warning on the given numeric literal N to indicate that the -- compiler made the assumption that the literal is not dimensionless @@ -1191,13 +1205,7 @@ Analyze_Dimension_Subtype_Declaration (N); when N_Type_Conversion => - if In_Instance - and then Exists (Dimensions_Of (Expression (N))) - then - Set_Dimensions (N, Dimensions_Of (Expression (N))); - else - Analyze_Dimension_Has_Etype (N); - end if; + Analyze_Dimension_Type_Conversion (N); when N_Unary_Op => Analyze_Dimension_Unary_Op (N); @@ -1384,26 +1392,6 @@ return Dimensions_Of (Etype (N)); end if; - -- A type conversion may have been inserted to rewrite other - -- expressions, e.g. function returns. Dimensions are those of - -- the target type, unless this is a conversion in an instance, - -- in which case the proper dimensions are those of the operand, - - elsif Nkind (N) = N_Type_Conversion then - if In_Instance - and then Is_Generic_Actual_Type (Etype (Expression (N))) - then - return Dimensions_Of (Etype (Expression (N))); - - elsif In_Instance - and then Exists (Dimensions_Of (Expression (N))) - then - return Dimensions_Of (Expression (N)); - - else - return Dimensions_Of (Etype (N)); - end if; - -- Otherwise return the default dimensions else @@ -2339,6 +2327,56 @@ end if; end Analyze_Dimension_Subtype_Declaration; + --------------------------------------- + -- Analyze_Dimension_Type_Conversion -- + --------------------------------------- + + procedure Analyze_Dimension_Type_Conversion (N : Node_Id) is + Expr_Root : constant Entity_Id := + Dimension_System_Root (Etype (Expression (N))); + Target_Root : constant Entity_Id := + Dimension_System_Root (Etype (N)); + + begin + -- If the expression has dimensions and the target type has dimensions, + -- the conversion has the dimensions of the expression. Consistency is + -- checked below. Converting to a non-dimensioned type such as Float + -- ignores the dimensions of the expression. + + if Exists (Dimensions_Of (Expression (N))) + and then Present (Target_Root) + then + Set_Dimensions (N, Dimensions_Of (Expression (N))); + + -- Otherwise the dimensions are those of the target type. + + else + Analyze_Dimension_Has_Etype (N); + end if; + + -- A conversion between types in different dimension systems (e.g. MKS + -- and British units) must respect the dimensions of expression and + -- type, It is up to the user to provide proper conversion factors. + + -- Upward conversions to root type of a dimensioned system are legal, + -- and correspond to "view conversions", i.e. preserve the dimensions + -- of the expression; otherwise conversion must be between types with + -- then same dimensions. Conversions to a non-dimensioned type such as + -- Float lose the dimensions of the expression. + + if Present (Expr_Root) + and then Present (Target_Root) + and then Etype (N) /= Target_Root + and then Dimensions_Of (Expression (N)) /= Dimensions_Of (Etype (N)) + then + Error_Msg_N ("dimensions mismatch in conversion", N); + Error_Msg_N + ("\expression " & Dimensions_Msg_Of (Expression (N), True), N); + Error_Msg_N + ("\target type " & Dimensions_Msg_Of (Etype (N), True), N); + end if; + end Analyze_Dimension_Type_Conversion; + -------------------------------- -- Analyze_Dimension_Unary_Op -- -------------------------------- @@ -2665,6 +2703,24 @@ or else Dimensions_Of (T1) = Dimensions_Of (T2); end Dimensions_Match; + --------------------------- + -- Dimension_System_Root -- + --------------------------- + + function Dimension_System_Root (T : Entity_Id) return Entity_Id is + Root : Entity_Id; + + begin + Root := Base_Type (T); + + if Has_Dimension_System (Root) then + return First_Subtype (Root); -- for example Dim_Mks + + else + return Empty; + end if; + end Dimension_System_Root; + ---------------------------------------- -- Eval_Op_Expon_For_Dimensioned_Type -- ----------------------------------------