From patchwork Mon Oct 1 10:07:43 2012 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 188270 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 004EC2C00E5 for ; Mon, 1 Oct 2012 20:08:10 +1000 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1349690892; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition: Content-Transfer-Encoding:User-Agent:Mailing-List:Precedence: List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender: Delivered-To; bh=P4dhhuOEXDbzTne5Jrjej9Bkzc0=; b=rs3t62W0rPbma5n 7gymXyaA7Czdfj6MVe6n/bTXNK27T7EFXHNBoh6R/1KU+NYq5WAo2NtXaeYEkogQ mtTEYwboA1846Or4X6LVh5vxw5v5BZX0hXQJugkgTnIQKlo+ePzt1qo3rgoa9i+l f81yv2Rk0KCmyVqknkq6VstKN4d0= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:Content-Transfer-Encoding:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=lueicn8AR6luyM/BOSC6BudO8gkugJvJ6e0pOSTl0xzIJg2sX3DsBdCm9kN4x8 oCUKxFPELSDttU/ZUdVQGpwRVWqrPiOM91oFfaEVIQUjqVIw0oz6HMN/W4NcVCtD PyCfT9fhQepR9fI0k/plM+YL31/3zQhVkwGsUU0WaoQW8=; Received: (qmail 5180 invoked by alias); 1 Oct 2012 10:08:04 -0000 Received: (qmail 5097 invoked by uid 22791); 1 Oct 2012 10:07:57 -0000 X-SWARE-Spam-Status: No, hits=2.3 required=5.0 tests=AWL, BAYES_50, KAM_STOCKTIP, RCVD_IN_HOSTKARMA_NO, TW_TM X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 01 Oct 2012 10:07:44 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A10A51C786B; Mon, 1 Oct 2012 06:07:43 -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 KfReA7rso9Ov; Mon, 1 Oct 2012 06:07:43 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 76DA71C7867; Mon, 1 Oct 2012 06:07:43 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 7263F3FF09; Mon, 1 Oct 2012 06:07:43 -0400 (EDT) Date: Mon, 1 Oct 2012 06:07:43 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Vincent Pucci Subject: [Ada] New addition to the GNAT dimensionality checking system Message-ID: <20121001100743.GA14939@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 implements dimension analysis for array, extension and record aggregates, and also for calls. Moreover, the compiler warns whenever a numeric literal is used as a default value of a dimensioned subtype object (object declaration, component declaration and formal parameter). The test presented below illustrates some of the new additions, in particular the dimension anlysis of aggregates. ------------ -- Source -- ------------ with Ada.Text_IO; use Ada.Text_IO; with System.Dim.Mks; use System.Dim.Mks; with System.Dim.Mks_IO; use System.Dim.Mks_IO; procedure Main is subtype Axis is Integer range 1 .. 3; type Position is array (Axis) of Length; type Particle is record Q: Mass := 0.0; R: Position := (Axis => 0.0 * m); end record; P : Particle := (Q => 1.0 * g, R => (Axis => 0.0 * m)); begin Put (P.Q, Aft => 2, Exp => 0); New_Line; for C of P.R loop Put (C, Aft => 2, Exp => 0); New_Line; end loop; end Main; ----------------------------- -- Compilation & Execution -- ----------------------------- $ gnatmake -q -gnat12 main.adb $ ./main main.adb:10:21: warning: assumed to be "0.0 kg" 0.00 kg 0.00 m 0.00 m 0.00 m Tested on x86_64-pc-linux-gnu, committed on trunk 2012-10-01 Vincent Pucci * exp_ch6.adb (Expand_Call): Remove call to Remove_Dimension_In_Call. * sem_aggr.adb (Resolve_Array_Aggregate): Analyze dimension of components in array aggregate. (Resolve_Aggr_Expr): Propagate dimensions from the original expression Expr to the new created expression New_Expr when resolving the expression of a component in record aggregates. (Resolve_Record_Aggregate): Analyze dimension of components in record (or extension) aggregate. * sem_ch6.adb (Analyze_Subprogram_Specification): Analyze dimension of formals with default expressions in subprogram specification. * sem_ch8.adb (Analyze_Expanded_Name): Analyze dimension of expanded names. (Find_Selected_Component): Analyze dimension of selected component. * sem_dim.adb: Several dimension error messages reformatting. (Dimensions_Msg_Of): New flag Description_Needed in order to differentiate two different sort of dimension error messages. (Dim_Warning_For_Numeric_Literal): New routine. (Exists): New routine. (Move_Dimensions): Routine spec moved to spec file. * sem_dim.ads (String_From_Numeric_Literal): New routine. (Analyze_Dimension): Analyze dimension only when the node comes from source. Dimension analysis for expanded names added. (Analyze_Dimension_Array_Aggregate): New routine. (Analyze_Dimension_Call): New routine. (Analyze_Dimension_Component_Declaration): Warning if default expression is a numeric literal. (Analyze_Dimension_Extension_Or_Record_Aggregate): New routine. (Analyze_Dimension_Formals): New routine. (Analyze_Dimension_Object_Declaration): Warning if default expression is a numeric literal. (Symbol_Of): Return either the dimension subtype symbol or the dimension symbol built by From_Dim_To_Str_Of_Unit_Symbols. * sem_dim.ads (Analyze_Dimension_Array_Aggregate): New routine. (Analyze_Dimension_Call): New routine. (Analyze_Dimension_Extension_Or_Record_Aggregate): New routine. (Analyze_Dimension_Formals): New routine. (Move_Dimensions): Moved from sem_dim.adb. * s-dimmks.ads: Turn off the warnings for dimensioned object declaration. Dimensioned subtypes sorted in alphabetical order. New subtypes Area, Speed, Volume. * s-dmotpr.ads: Turn off the warnings for dimensioned object declaration. * sem_res.adb (Resolve_Call): Analyze dimension for calls. Index: sem_aggr.adb =================================================================== --- sem_aggr.adb (revision 191889) +++ sem_aggr.adb (working copy) @@ -47,6 +47,7 @@ with Sem_Ch3; use Sem_Ch3; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -2549,6 +2550,10 @@ Duplicate_Subexpr (High_Bound (Aggregate_Bounds (N)))); end if; + -- Check the dimensions of each component in the array aggregate. + + Analyze_Dimension_Array_Aggregate (N, Component_Typ); + return Success; end Resolve_Array_Aggregate; @@ -3225,8 +3230,9 @@ ----------------------- procedure Resolve_Aggr_Expr (Expr : Node_Id; Component : Node_Id) is + Expr_Type : Entity_Id := Empty; New_C : Entity_Id := Component; - Expr_Type : Entity_Id := Empty; + New_Expr : Node_Id; function Has_Expansion_Delayed (Expr : Node_Id) return Boolean; -- If the expression is an aggregate (possibly qualified) then its @@ -3380,10 +3386,17 @@ end if; if Relocate then - Add_Association (New_C, Relocate_Node (Expr), New_Assoc_List); + New_Expr := Relocate_Node (Expr); + + -- Since New_Expr is not gonna be analyzed later on, we need to + -- propagate here the dimensions form Expr to New_Expr. + + Move_Dimensions (Expr, New_Expr); else - Add_Association (New_C, Expr, New_Assoc_List); + New_Expr := Expr; end if; + + Add_Association (New_C, New_Expr, New_Assoc_List); end Resolve_Aggr_Expr; -- Start of processing for Resolve_Record_Aggregate @@ -4490,6 +4503,10 @@ Rewrite (N, New_Aggregate); end Step_8; + + -- Check the dimensions of the components in the record aggregate. + + Analyze_Dimension_Extension_Or_Record_Aggregate (N); end Resolve_Record_Aggregate; ----------------------------- Index: sem_dim.adb =================================================================== --- sem_dim.adb (revision 191888) +++ sem_dim.adb (working copy) @@ -36,7 +36,9 @@ with Sem; use Sem; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; +with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; +with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; with Stringt; use Stringt; @@ -190,6 +192,7 @@ OK_For_Dimension : constant array (Node_Kind) of Boolean := (N_Attribute_Reference => True, + N_Expanded_Name => True, N_Defining_Identifier => True, N_Function_Call => True, N_Identifier => True, @@ -236,14 +239,6 @@ -- that the dimensions of the returned type and of the returned object -- match. - procedure Analyze_Dimension_Function_Call (N : Node_Id); - -- Subroutine of Analyze_Dimension for function call. General case: - -- propagate the dimensions from the returned type to N. Elementary - -- function case (Ada.Numerics.Generic_Elementary_Functions): If N - -- is a Sqrt call, then evaluate the resulting dimensions as half the - -- dimensions of the parameter. Otherwise, verify that each parameters - -- are dimensionless. - procedure Analyze_Dimension_Has_Etype (N : Node_Id); -- Subroutine of Analyze_Dimension for a subset of N_Has_Etype denoted by -- the list below: @@ -292,10 +287,18 @@ function Dimensions_Of (N : Node_Id) return Dimension_Type; -- Return the dimension vector of node N - function Dimensions_Msg_Of (N : Node_Id) return String; - -- Given a node, return "has dimension" followed by the dimension symbols - -- of N or "is dimensionless" if N is dimensionless. + function Dimensions_Msg_Of + (N : Node_Id; + Description_Needed : Boolean := False) return String; + -- Given a node N, return the dimension symbols of N, preceded by "has + -- dimension" if Description_Needed. if N is dimensionless, return "[]", or + -- "is dimensionless" if Description_Needed. + procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id); + -- Issue a warning on the given numeric literal N to indicate the + -- compilateur made the assumption that the literal is not dimensionless + -- but has the dimension of Typ. + procedure Eval_Op_Expon_With_Rational_Exponent (N : Node_Id; Exponent_Value : Rational); @@ -304,6 +307,9 @@ function Exists (Dim : Dimension_Type) return Boolean; -- Returns True iff Dim does not denote the null dimension + function Exists (Str : String_Id) return Boolean; + -- Returns True iff Str does not denote No_String + function Exists (Sys : System_Type) return Boolean; -- Returns True iff Sys does not denote the null system @@ -330,9 +336,6 @@ function Is_Invalid (Position : Dimension_Position) return Boolean; -- Return True if Pos denotes the invalid position - procedure Move_Dimensions (From : Node_Id; To : Node_Id); - -- Copy dimension vector of From to To, delete dimension vector of From - procedure Remove_Dimensions (N : Node_Id); -- Remove the dimension vector of node N @@ -342,6 +345,10 @@ procedure Set_Symbol (E : Entity_Id; Val : String_Id); -- Associate a symbol representation of a dimension vector with a subtype + function String_From_Numeric_Literal (N : Node_Id) return String_Id; + -- Return the string that corresponds to the numeric litteral N as it + -- appears in the source. + function Symbol_Of (E : Entity_Id) return String_Id; -- E denotes a subtype with a dimension. Return the symbol representation -- of the dimension vector. @@ -1122,14 +1129,16 @@ procedure Analyze_Dimension (N : Node_Id) is begin - -- Aspect is an Ada 2012 feature + -- Aspect is an Ada 2012 feature. Note that there is no need to check + -- dimensions for nodes that don't come from source. - if Ada_Version < Ada_2012 then + if Ada_Version < Ada_2012 + or else not Comes_From_Source (N) + then return; end if; case Nkind (N) is - when N_Assignment_Statement => Analyze_Dimension_Assignment_Statement (N); @@ -1142,10 +1151,8 @@ when N_Extended_Return_Statement => Analyze_Dimension_Extended_Return_Statement (N); - when N_Function_Call => - Analyze_Dimension_Function_Call (N); - when N_Attribute_Reference | + N_Expanded_Name | N_Identifier | N_Indexed_Component | N_Qualified_Expression | @@ -1177,6 +1184,95 @@ end case; end Analyze_Dimension; + --------------------------------------- + -- Analyze_Dimension_Array_Aggregate -- + --------------------------------------- + + procedure Analyze_Dimension_Array_Aggregate + (N : Node_Id; + Comp_Typ : Entity_Id) + is + Comp_Ass : constant List_Id := Component_Associations (N); + Dims_Of_Comp_Typ : constant Dimension_Type := Dimensions_Of (Comp_Typ); + Exps : constant List_Id := Expressions (N); + + Comp : Node_Id; + Expr : Node_Id; + + Error_Detected : Boolean := False; + -- This flag is used in order to indicate if an error has been detected + -- so far by the compiler in this routine. + + begin + -- Aspect is an Ada 2012 feature. Nothing to do here if the component + -- base type is not a dimensioned type. + + -- Note that here the original node must come from source since the + -- original array aggregate may not have been entirely decorated. + + if Ada_Version < Ada_2012 + or else not Comes_From_Source (Original_Node (N)) + or else not Has_Dimension_System (Base_Type (Comp_Typ)) + then + return; + end if; + + -- Check whether there is any positional component association + + if Is_Empty_List (Exps) then + Comp := First (Comp_Ass); + else + Comp := First (Exps); + end if; + + while Present (Comp) loop + -- Get the expression from the component + + if Nkind (Comp) = N_Component_Association then + Expr := Expression (Comp); + else + Expr := Comp; + end if; + + -- Issue an error if the dimensions of the component type and the + -- dimensions of the component mismatch. + + -- Note that we must ensure the expression has been fully analyzed + -- since it may not be decorated at this point. We also don't want to + -- issue the same error message multiple times on the same expression + -- (may happen when an aggregate is converted into a positional + -- aggregate). + + if Comes_From_Source (Original_Node (Expr)) + and then Present (Etype (Expr)) + and then Dimensions_Of (Expr) /= Dims_Of_Comp_Typ + and then Sloc (Comp) /= Sloc (Prev (Comp)) + then + -- Check if an error has already been encountered so far + + if not Error_Detected then + Error_Msg_N ("dimensions mismatch in array aggregate", N); + Error_Detected := True; + end if; + + Error_Msg_N ("\expected dimension " & + Dimensions_Msg_Of (Comp_Typ) & ", found " & + Dimensions_Msg_Of (Expr), + Expr); + end if; + + -- Look at the named components right after the positional components + + if not Present (Next (Comp)) + and then List_Containing (Comp) = Exps + then + Comp := First (Comp_Ass); + else + Next (Comp); + end if; + end loop; + end Analyze_Dimension_Array_Aggregate; + -------------------------------------------- -- Analyze_Dimension_Assignment_Statement -- -------------------------------------------- @@ -1205,8 +1301,8 @@ is begin Error_Msg_N ("dimensions mismatch in assignment", N); - Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs), N); - Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs), N); + Error_Msg_N ("\left-hand side " & Dimensions_Msg_Of (Lhs, True), N); + Error_Msg_N ("\right-hand side " & Dimensions_Msg_Of (Rhs, True), N); end Error_Dim_Msg_For_Assignment_Statement; -- Start of processing for Analyze_Dimension_Assignment @@ -1241,8 +1337,8 @@ "dimensions", N, Entity (N)); - Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L), N); - Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R), N); + Error_Msg_N ("\left operand " & Dimensions_Msg_Of (L, True), N); + Error_Msg_N ("\right operand " & Dimensions_Msg_Of (R, True), N); end Error_Dim_Msg_For_Binary_Op; -- Start of processing for Analyze_Dimension_Binary_Op @@ -1390,6 +1486,174 @@ end if; end Analyze_Dimension_Binary_Op; + ---------------------------- + -- Analyze_Dimension_Call -- + ---------------------------- + + procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id) is + Actuals : constant List_Id := Parameter_Associations (N); + Actual : Node_Id; + Dims_Of_Formal : Dimension_Type; + Formal : Node_Id; + Formal_Typ : Entity_Id; + + Error_Detected : Boolean := False; + -- This flag is used in order to indicate if an error has been detected + -- so far by the compiler in this routine. + + begin + -- Aspect is an Ada 2012 feature. Nothing to do here if the list of + -- actuals is empty.Note that there is no need to check dimensions for + -- calls that don't come from source. + + if Ada_Version < Ada_2012 + or else not Comes_From_Source (N) + or else Is_Empty_List (Actuals) + then + return; + end if; + + -- Special processing for elementary functions + + -- For Sqrt call, the resulting dimensions equal to half the dimensions + -- of the actual. For all other elementary calls, this routine check + -- that every actual is dimensionless. + + if Nkind (N) = N_Function_Call then + Elementary_Function_Calls : declare + Dims_Of_Call : Dimension_Type; + Ent : Entity_Id := Nam; + + function Is_Elementary_Function_Entity + (Sub_Id : Entity_Id) return Boolean; + -- Given Sub_Id, the original subprogram entity, return True if + -- call is to an elementary function + -- (see Ada.Numerics.Generic_Elementary_Functions). + + ----------------------------------- + -- Is_Elementary_Function_Entity -- + ----------------------------------- + + function Is_Elementary_Function_Entity + (Sub_Id : Entity_Id) return Boolean + is + Loc : constant Source_Ptr := Sloc (Sub_Id); + + begin + -- Is function entity in + -- Ada.Numerics.Generic_Elementary_Functions? + + return + Loc > No_Location + and then + Is_RTU + (Cunit_Entity (Get_Source_Unit (Loc)), + Ada_Numerics_Generic_Elementary_Functions); + end Is_Elementary_Function_Entity; + + begin + -- Get the original subprogram entity following the renaming chain + + if Present (Alias (Ent)) then + Ent := Alias (Ent); + end if; + + -- Check the call is an Elementary function call + + if Is_Elementary_Function_Entity (Ent) then + -- Sqrt function call case + + if Chars (Ent) = Name_Sqrt then + Dims_Of_Call := Dimensions_Of (First_Actual (N)); + + -- Eavluates the resulting dimensions (i.e. half the + -- dimensions of the actual). + + if Exists (Dims_Of_Call) then + for Position in Dims_Of_Call'Range loop + Dims_Of_Call (Position) := + Dims_Of_Call (Position) * + Rational'(Numerator => 1, + Denominator => 2); + end loop; + + Set_Dimensions (N, Dims_Of_Call); + end if; + + -- All other elementary functions case. Note that every actual + -- here should be dimensionless. + + else + Actual := First_Actual (N); + + while Present (Actual) loop + if Exists (Dimensions_Of (Actual)) then + -- Check if an error has already been encountered so + -- far. + + if not Error_Detected then + Error_Msg_NE ("dimensions mismatch in call of&", + N, Name (N)); + Error_Detected := True; + end if; + + Error_Msg_N ("\expected dimension [], found " & + Dimensions_Msg_Of (Actual), + Actual); + end if; + + Next_Actual (Actual); + end loop; + end if; + + -- Nothing more to do for elementary functions + + return; + end if; + end Elementary_Function_Calls; + end if; + + -- General case. Check, for each parameter, the dimensions of the actual + -- and its corresponding formal match. Otherwise, complain. + + Actual := First_Actual (N); + Formal := First_Formal (Nam); + + while Present (Formal) loop + Formal_Typ := Etype (Formal); + Dims_Of_Formal := Dimensions_Of (Formal_Typ); + + -- If the formal is not dimensionless, check dimensions of formal and + -- actual match. Otherwise, complain. + + if Exists (Dims_Of_Formal) + and then Dimensions_Of (Actual) /= Dims_Of_Formal + then + -- Check if an error has already been encountered so far + + if not Error_Detected then + Error_Msg_NE ("dimensions mismatch in& call", N, Name (N)); + Error_Detected := True; + end if; + + Error_Msg_N ("\expected dimension " & + Dimensions_Msg_Of (Formal_Typ) & ", found " & + Dimensions_Msg_Of (Actual), + Actual); + end if; + + Next_Actual (Actual); + Next_Formal (Formal); + end loop; + + -- For function calls, propagate the dimensions from the returned type + -- to the function call. + + if Nkind (N) = N_Function_Call then + Analyze_Dimension_Has_Etype (N); + end if; + end Analyze_Dimension_Call; + --------------------------------------------- -- Analyze_Dimension_Component_Declaration -- --------------------------------------------- @@ -1418,21 +1682,38 @@ Expr : Node_Id) is begin Error_Msg_N ("dimensions mismatch in component declaration", N); - Error_Msg_N ("\component type " & Dimensions_Msg_Of (Etyp), N); - Error_Msg_N ("\component expression " & Dimensions_Msg_Of (Expr), N); + Error_Msg_N ("\expected dimension " & + Dimensions_Msg_Of (Etyp) & ", found " & + Dimensions_Msg_Of (Expr), + Expr); end Error_Dim_Msg_For_Component_Declaration; -- Start of processing for Analyze_Dimension_Component_Declaration begin + -- Expression is present + if Present (Expr) then Dims_Of_Expr := Dimensions_Of (Expr); - -- Return an error if the dimension of the expression and the - -- dimension of the type mismatch. + -- Check dimensions match if Dims_Of_Etyp /= Dims_Of_Expr then - Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr); + -- Numeric literal case. Issue a warning if the object type is not + -- dimensionless to indicate the literal is treated as if its + -- dimension matches the type dimension. + + if Nkind_In (Original_Node (Expr), + N_Real_Literal, + N_Integer_Literal) + then + Dim_Warning_For_Numeric_Literal (Expr, Etyp); + + -- Issue a dimension mismatch error for all other cases + + else + Error_Dim_Msg_For_Component_Declaration (N, Etyp, Expr); + end if; end if; -- Removal of dimensions in expression @@ -1446,38 +1727,36 @@ ------------------------------------------------- procedure Analyze_Dimension_Extended_Return_Statement (N : Node_Id) is - Return_Ent : constant Entity_Id := - Return_Statement_Entity (N); - Return_Etyp : constant Entity_Id := - Etype (Return_Applies_To (Return_Ent)); - Dims_Of_Return_Etyp : constant Dimension_Type := - Dimensions_Of (Return_Etyp); - Return_Obj_Decls : constant List_Id := - Return_Object_Declarations (N); - Dims_Of_Return_Obj_Id : Dimension_Type; - Return_Obj_Decl : Node_Id; - Return_Obj_Id : Entity_Id; + Return_Ent : constant Entity_Id := Return_Statement_Entity (N); + Return_Etyp : constant Entity_Id := + Etype (Return_Applies_To (Return_Ent)); + Return_Obj_Decls : constant List_Id := Return_Object_Declarations (N); + Return_Obj_Decl : Node_Id; + Return_Obj_Id : Entity_Id; + Return_Obj_Typ : Entity_Id; procedure Error_Dim_Msg_For_Extended_Return_Statement - (N : Node_Id; - Return_Etyp : Entity_Id; - Return_Obj_Id : Entity_Id); + (N : Node_Id; + Return_Etyp : Entity_Id; + Return_Obj_Typ : Entity_Id); -- Error using Error_Msg_N at node N. Output the dimensions of the - -- returned type Return_Etyp and the returned object Return_Obj_Id of N. + -- returned type Return_Etyp and the returned object type Return_Obj_Typ + -- of N. ------------------------------------------------- -- Error_Dim_Msg_For_Extended_Return_Statement -- ------------------------------------------------- procedure Error_Dim_Msg_For_Extended_Return_Statement - (N : Node_Id; - Return_Etyp : Entity_Id; - Return_Obj_Id : Entity_Id) + (N : Node_Id; + Return_Etyp : Entity_Id; + Return_Obj_Typ : Entity_Id) is begin Error_Msg_N ("dimensions mismatch in extended return statement", N); - Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N); - Error_Msg_N ("\returned object " & Dimensions_Msg_Of (Return_Obj_Id), + Error_Msg_N ("\expected dimension " & + Dimensions_Msg_Of (Return_Etyp) & ", found " & + Dimensions_Msg_Of (Return_Obj_Typ), N); end Error_Dim_Msg_For_Extended_Return_Statement; @@ -1486,16 +1765,21 @@ begin if Present (Return_Obj_Decls) then Return_Obj_Decl := First (Return_Obj_Decls); + while Present (Return_Obj_Decl) loop if Nkind (Return_Obj_Decl) = N_Object_Declaration then - Return_Obj_Id := Defining_Identifier (Return_Obj_Decl); + Return_Obj_Id := Defining_Identifier (Return_Obj_Decl); if Is_Return_Object (Return_Obj_Id) then - Dims_Of_Return_Obj_Id := Dimensions_Of (Return_Obj_Id); + Return_Obj_Typ := Etype (Return_Obj_Id); - if Dims_Of_Return_Etyp /= Dims_Of_Return_Obj_Id then + -- Issue an error message if dimensions mismatch + + if Dimensions_Of (Return_Etyp) /= + Dimensions_Of (Return_Obj_Typ) + then Error_Dim_Msg_For_Extended_Return_Statement - (N, Return_Etyp, Return_Obj_Id); + (N, Return_Etyp, Return_Obj_Typ); return; end if; end if; @@ -1506,107 +1790,122 @@ end if; end Analyze_Dimension_Extended_Return_Statement; - ------------------------------------- - -- Analyze_Dimension_Function_Call -- - ------------------------------------- + ----------------------------------------------------- + -- Analyze_Dimension_Extension_Or_Record_Aggregate -- + ----------------------------------------------------- - -- Propagate the dimensions from the returned type to the call node. Note - -- that there is a special treatment for elementary function calls. Indeed - -- for Sqrt call, the resulting dimensions equal to half the dimensions of - -- the actual, and for other elementary calls, this routine check that - -- every actuals are dimensionless. + procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id) is + Comp : Node_Id := First (Component_Associations (N)); + Comp_Id : Entity_Id; + Comp_Typ : Entity_Id; + Expr : Node_Id; - procedure Analyze_Dimension_Function_Call (N : Node_Id) is - Actuals : constant List_Id := Parameter_Associations (N); - Name_Call : constant Node_Id := Name (N); - Actual : Node_Id; - Dims_Of_Actual : Dimension_Type; - Dims_Of_Call : Dimension_Type; - Ent : Entity_Id; + Error_Detected : Boolean := False; + -- This flag is used in order to indicate if an error has been detected + -- so far by the compiler in this routine. - function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean; - -- Given E, the original subprogram entity, return True if call is to an - -- elementary function (see Ada.Numerics.Generic_Elementary_Functions). + begin + -- Aspect is an Ada 2012 feature. Note that there is no need to check + -- dimensions for aggregates that don't come from source. - ----------------------------------- - -- Is_Elementary_Function_Entity -- - ----------------------------------- + if Ada_Version < Ada_2012 + or else not Comes_From_Source (N) + then + return; + end if; - function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is - Loc : constant Source_Ptr := Sloc (E); + while Present (Comp) loop + Comp_Id := Entity (First (Choices (Comp))); + Comp_Typ := Etype (Comp_Id); - begin - -- Is function entity in Ada.Numerics.Generic_Elementary_Functions? + -- Check the component type is either a dimensioned type or a + -- dimensioned subtype. - return - Loc > No_Location - and then - Is_RTU - (Cunit_Entity (Get_Source_Unit (Loc)), - Ada_Numerics_Generic_Elementary_Functions); - end Is_Elementary_Function_Entity; + if Has_Dimension_System (Base_Type (Comp_Typ)) then + Expr := Expression (Comp); - -- Start of processing for Analyze_Dimension_Function_Call + -- Issue an error if the dimensions of the component type and the + -- dimensions of the component mismatch. - begin - -- Look for elementary function call + if Dimensions_Of (Expr) /= Dimensions_Of (Comp_Typ) then + -- Check if an error has already been encountered so far - if Is_Entity_Name (Name_Call) then - Ent := Entity (Name_Call); + if not Error_Detected then + -- Extension aggregate case - -- Get the original subprogram entity following the renaming chain + if Nkind (N) = N_Extension_Aggregate then + Error_Msg_N ("dimensions mismatch in extension aggregate", + N); - if Present (Alias (Ent)) then - Ent := Alias (Ent); + -- Record aggregate case + + else + Error_Msg_N ("dimensions mismatch in record aggregate", + N); + end if; + + Error_Detected := True; + end if; + + Error_Msg_N ("\expected dimension " & + Dimensions_Msg_Of (Comp_Typ) & ", found " & + Dimensions_Msg_Of (Expr), + Comp); + end if; end if; - -- Elementary function case + Next (Comp); + end loop; + end Analyze_Dimension_Extension_Or_Record_Aggregate; - if Is_Elementary_Function_Entity (Ent) then + ------------------------------- + -- Analyze_Dimension_Formals -- + ------------------------------- - -- Sqrt function call case + procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id) is + Dims_Of_Typ : Dimension_Type; + Formal : Node_Id; + Typ : Entity_Id; - if Chars (Ent) = Name_Sqrt then - Dims_Of_Call := Dimensions_Of (First (Actuals)); + begin + -- Aspect is an Ada 2012 feature. Note that there is no need to check + -- dimensions for sub specs that don't come from source. - if Exists (Dims_Of_Call) then - for Position in Dims_Of_Call'Range loop - Dims_Of_Call (Position) := - Dims_Of_Call (Position) * Rational'(Numerator => 1, - Denominator => 2); - end loop; + if Ada_Version < Ada_2012 + or else not Comes_From_Source (N) + then + return; + end if; - Set_Dimensions (N, Dims_Of_Call); - end if; + Formal := First (Formals); - -- All other elementary functions case. Note that every actual - -- here should be dimensionless. + while Present (Formal) loop + Typ := Parameter_Type (Formal); + Dims_Of_Typ := Dimensions_Of (Typ); - else - Actual := First (Actuals); - while Present (Actual) loop - Dims_Of_Actual := Dimensions_Of (Actual); + if Exists (Dims_Of_Typ) then + declare + Expr : constant Node_Id := Expression (Formal); - if Exists (Dims_Of_Actual) then - Error_Msg_NE ("parameter of& must be dimensionless", - Actual, Name_Call); - Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual), - Actual); - end if; + begin + -- Issue a warning if Expr is a numeric literal and if its + -- dimensions differ with the dimensions of the formal type. - Next (Actual); - end loop; - end if; - - return; + if Present (Expr) + and then Dims_Of_Typ /= Dimensions_Of (Expr) + and then Nkind_In (Original_Node (Expr), + N_Real_Literal, + N_Integer_Literal) + then + Dim_Warning_For_Numeric_Literal (Expr, Etype (Typ)); + end if; + end; end if; - end if; - -- Other cases + Next (Formal); + end loop; + end Analyze_Dimension_Formals; - Analyze_Dimension_Has_Etype (N); - end Analyze_Dimension_Function_Call; - --------------------------------- -- Analyze_Dimension_Has_Etype -- --------------------------------- @@ -1691,8 +1990,10 @@ Expr : Node_Id) is begin Error_Msg_N ("dimensions mismatch in object declaration", N); - Error_Msg_N ("\object type " & Dimensions_Msg_Of (Etyp), N); - Error_Msg_N ("\object expression " & Dimensions_Msg_Of (Expr), N); + Error_Msg_N ("\expected dimension " & + Dimensions_Msg_Of (Etyp) & ", found " & + Dimensions_Msg_Of (Expr), + Expr); end Error_Dim_Msg_For_Object_Declaration; -- Start of processing for Analyze_Dimension_Object_Declaration @@ -1703,22 +2004,29 @@ if Present (Expr) then Dim_Of_Expr := Dimensions_Of (Expr); - -- Case when expression is not a literal and when dimensions of the - -- expression and of the type mismatch + -- Check dimensions match - if not Nkind_In (Original_Node (Expr), + if Dim_Of_Expr /= Dim_Of_Etyp then + -- Numeric literal case. Issue a warning if the object type is not + -- dimensionless to indicate the literal is treated as if its + -- dimension matches the type dimension. + + if Nkind_In (Original_Node (Expr), N_Real_Literal, N_Integer_Literal) - and then Dim_Of_Expr /= Dim_Of_Etyp - then - -- Propagate the dimension from the expression to the object - -- entity when the object is a constant whose type is a - -- dimensioned type. + then + Dim_Warning_For_Numeric_Literal (Expr, Etyp); - if Constant_Present (N) and then not Exists (Dim_Of_Etyp) then + -- Case where the object is a constant whose type is a dimensioned + -- type. + + elsif Constant_Present (N) and then not Exists (Dim_Of_Etyp) then + -- Propagate the dimension from the expression to the object + -- entity + Set_Dimensions (Id, Dim_Of_Expr); - -- Otherwise, issue an error message + -- For all other cases, issue an error message else Error_Dim_Msg_For_Object_Declaration (N, Etyp, Expr); @@ -1755,11 +2063,11 @@ Sub_Mark : Node_Id; Renamed_Name : Node_Id) is begin - Error_Msg_N ("dimensions mismatch in object renaming declaration", - N); - Error_Msg_N ("\type " & Dimensions_Msg_Of (Sub_Mark), N); - Error_Msg_N ("\renamed object " & Dimensions_Msg_Of (Renamed_Name), - N); + Error_Msg_N ("dimensions mismatch in object renaming declaration", N); + Error_Msg_N ("\expected dimension " & + Dimensions_Msg_Of (Sub_Mark) & ", found " & + Dimensions_Msg_Of (Renamed_Name), + Renamed_Name); end Error_Dim_Msg_For_Object_Renaming_Declaration; -- Start of processing for Analyze_Dimension_Object_Renaming_Declaration @@ -1802,8 +2110,10 @@ is begin Error_Msg_N ("dimensions mismatch in return statement", N); - Error_Msg_N ("\returned type " & Dimensions_Msg_Of (Return_Etyp), N); - Error_Msg_N ("\returned expression " & Dimensions_Msg_Of (Expr), N); + Error_Msg_N ("\expected dimension " & + Dimensions_Msg_Of (Return_Etyp) & ", found " & + Dimensions_Msg_Of (Expr), + Expr); end Error_Dim_Msg_For_Simple_Return_Statement; -- Start of processing for Analyze_Dimension_Simple_Return_Statement @@ -1838,7 +2148,8 @@ -- it cannot inherit a dimension from its subtype. if Exists (Dims_Of_Id) then - Error_Msg_N ("subtype& already" & Dimensions_Msg_Of (Id), N); + Error_Msg_N ("subtype& already" & Dimensions_Msg_Of (Id, True), + N); else Set_Dimensions (Id, Dims_Of_Etyp); Set_Symbol (Id, Symbol_Of (Etyp)); @@ -2011,7 +2322,10 @@ -- Dimensions_Msg_Of -- ----------------------- - function Dimensions_Msg_Of (N : Node_Id) return String is + function Dimensions_Msg_Of + (N : Node_Id; + Description_Needed : Boolean := False) return String + is Dims_Of_N : constant Dimension_Type := Dimensions_Of (N); Dimensions_Msg : Name_Id; System : System_Type; @@ -2021,13 +2335,32 @@ Name_Len := 0; + -- N is not dimensionless + if Exists (Dims_Of_N) then System := System_Of (Base_Type (Etype (N))); - Add_Str_To_Name_Buffer ("has dimension "); + + -- When Description_Needed, add to string "has dimension " before the + -- actual dimension. + + if Description_Needed then + Add_Str_To_Name_Buffer ("has dimension "); + end if; + Add_String_To_Name_Buffer (From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_N, System, True)); + + -- N is dimensionless + + -- When Description_Needed, return "is dimensionless" + + elsif Description_Needed then + Add_Str_To_Name_Buffer ("is dimensionless"); + + -- Otherwise, return "[]" + else - Add_Str_To_Name_Buffer ("is dimensionless"); + Add_Str_To_Name_Buffer ("[]"); end if; Dimensions_Msg := Name_Find; @@ -2045,6 +2378,27 @@ return Dimension_Table_Range (Key mod 511); end Dimension_Table_Hash; + ------------------------------------- + -- Dim_Warning_For_Numeric_Literal -- + ------------------------------------- + + procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id) is + begin + -- Initialize name buffer + + Name_Len := 0; + + Add_String_To_Name_Buffer (String_From_Numeric_Literal (N)); + + -- Insert a blank between the literal and the symbol + Add_Str_To_Name_Buffer (" "); + + Add_String_To_Name_Buffer (Symbol_Of (Typ)); + + Error_Msg_Name_1 := Name_Find; + Error_Msg_N ("?assumed to be%%", N); + end Dim_Warning_For_Numeric_Literal; + ---------------------------------------- -- Eval_Op_Expon_For_Dimensioned_Type -- ---------------------------------------- @@ -2243,6 +2597,11 @@ return Dim /= Null_Dimension; end Exists; + function Exists (Str : String_Id) return Boolean is + begin + return Str /= No_String; + end Exists; + function Exists (Sys : System_Type) return Boolean is begin return Sys /= Null_System; @@ -2311,7 +2670,7 @@ Dims_Of_Actual : Dimension_Type; Etyp : Entity_Id; New_Str_Lit : Node_Id := Empty; - System : System_Type; + Symbols : String_Id; Is_Put_Dim_Of : Boolean := False; -- This flag is used in order to differentiate routines Put and @@ -2463,10 +2822,10 @@ -- by the routine From_Dim_To_Str_Of_Dim_Symbols. if Exists (Dims_Of_Actual) then - System := System_Of (Base_Type (Etyp)); New_Str_Lit := Make_String_Literal (Loc, - From_Dim_To_Str_Of_Dim_Symbols (Dims_Of_Actual, System)); + From_Dim_To_Str_Of_Dim_Symbols + (Dims_Of_Actual, System_Of (Base_Type (Etyp)))); -- If dimensionless, the output is [] @@ -2481,25 +2840,24 @@ -- Add the symbol as a suffix of the value if the subtype has a -- unit symbol or if the parameter is not dimensionless. - if Symbol_Of (Etyp) /= No_String then + if Exists (Symbol_Of (Etyp)) then + Symbols := Symbol_Of (Etyp); + + else + Symbols := From_Dim_To_Str_Of_Unit_Symbols + (Dims_Of_Actual, System_Of (Base_Type (Etyp))); + end if; + + -- Check Symbols exists + + if Exists (Symbols) then Start_String; -- Put a space between the value and the dimension Store_String_Char (' '); - Store_String_Chars (Symbol_Of (Etyp)); + Store_String_Chars (Symbols); New_Str_Lit := Make_String_Literal (Loc, End_String); - - -- Check that the item is not dimensionless - - -- Create the new String_Literal with the new String_Id generated - -- by the routine From_Dim_To_Str_Of_Unit_Symbols. - - elsif Exists (Dims_Of_Actual) then - System := System_Of (Base_Type (Etyp)); - New_Str_Lit := - Make_String_Literal (Loc, - From_Dim_To_Str_Of_Unit_Symbols (Dims_Of_Actual, System)); end if; end if; @@ -2672,14 +3030,16 @@ First_Dim : Boolean := True; begin + -- Return No_String if dimensionless + + if not Exists (Dims) then + return No_String; + end if; + -- Initialization of the new String_Id Start_String; - -- Put a space between the value and the symbols - - Store_String_Char (' '); - for Position in Dimension_Type'Range loop Dim_Power := Dims (Position); @@ -2823,6 +3183,10 @@ Dims_Of_From : constant Dimension_Type := Dimensions_Of (From); begin + if Ada_Version < Ada_2012 then + return; + end if; + -- Copy the dimension of 'From to 'To' and remove dimension of 'From' if Exists (Dims_Of_From) then @@ -2861,26 +3225,6 @@ end if; end Remove_Dimensions; - ------------------------------ - -- Remove_Dimension_In_Call -- - ------------------------------ - - procedure Remove_Dimension_In_Call (Call : Node_Id) is - Actual : Node_Id; - - begin - if Ada_Version < Ada_2012 then - return; - end if; - - Actual := First (Parameter_Associations (Call)); - - while Present (Actual) loop - Remove_Dimensions (Actual); - Next (Actual); - end loop; - end Remove_Dimension_In_Call; - ----------------------------------- -- Remove_Dimension_In_Statement -- ----------------------------------- @@ -2935,13 +3279,86 @@ Symbol_Table.Set (E, Val); end Set_Symbol; + --------------------------------- + -- String_From_Numeric_Literal -- + --------------------------------- + + function String_From_Numeric_Literal (N : Node_Id) return String_Id is + Loc : constant Source_Ptr := Sloc (N); + Sbuffer : constant Source_Buffer_Ptr := + Source_Text (Get_Source_File_Index (Loc)); + Src_Ptr : Source_Ptr := Loc; + C : Character := Sbuffer (Src_Ptr); + -- Current source program character + + function Belong_To_Numeric_Literal (C : Character) return Boolean; + -- Return True if C belongs to a numeric literal + + ------------------------------- + -- Belong_To_Numeric_Literal -- + ------------------------------- + + function Belong_To_Numeric_Literal (C : Character) return Boolean is + begin + case C is + when '0' .. '9' | + '_' | + '.' | + 'e' | + '#' | + 'A' | + 'B' | + 'C' | + 'D' | + 'E' | + 'F' => + return True; + + -- Make sure '+' or '-' is part of an exponent. + + when '+' | '-' => + declare + Prev_C : constant Character := Sbuffer (Src_Ptr - 1); + begin + return Prev_C = 'e' or else Prev_C = 'E'; + end; + + -- All other character doesn't belong to a numeric literal + + when others => + return False; + end case; + end Belong_To_Numeric_Literal; + + -- Start of processing for String_From_Numeric_Literal + + begin + Start_String; + + while Belong_To_Numeric_Literal (C) loop + Store_String_Char (C); + Src_Ptr := Src_Ptr + 1; + C := Sbuffer (Src_Ptr); + end loop; + + return End_String; + end String_From_Numeric_Literal; + --------------- -- Symbol_Of -- --------------- function Symbol_Of (E : Entity_Id) return String_Id is + Subtype_Symbol : constant String_Id := Symbol_Table.Get (E); + begin - return Symbol_Table.Get (E); + if Subtype_Symbol /= No_String then + return Subtype_Symbol; + + else + return From_Dim_To_Str_Of_Unit_Symbols + (Dimensions_Of (E), System_Of (Base_Type (E))); + end if; end Symbol_Of; ----------------------- @@ -2971,5 +3388,4 @@ return Null_System; end System_Of; - end Sem_Dim; Index: sem_dim.ads =================================================================== --- sem_dim.ads (revision 191888) +++ sem_dim.ads (working copy) @@ -108,16 +108,19 @@ procedure Analyze_Dimension (N : Node_Id); -- N may denote any of the following contexts: + -- * aggregate -- * assignment statement -- * attribute reference -- * binary operator + -- * call -- * compontent declaration -- * extended return statement - -- * function call + -- * expanded name -- * identifier -- * indexed component -- * object declaration -- * object renaming declaration + -- * procedure call statement -- * qualified expression -- * selected component -- * simple return statement @@ -129,6 +132,36 @@ -- Depending on the context, ensure that all expressions and entities -- involved do not violate the rules of a system. + procedure Analyze_Dimension_Array_Aggregate + (N : Node_Id; + Comp_Typ : Entity_Id); + -- Check, for each component of the array aggregate denoted by N, the + -- dimensions of the component expression match the dimensions of the + -- component type Comp_Typ. + + procedure Analyze_Dimension_Call (N : Node_Id; Nam : Entity_Id); + -- This routine is split in two steps. Note the second step applies only to + -- function calls. + -- Step 1. Dimension checking: + -- * General case: check the dimensions of each actual parameter match + -- the dimensions of the corresponding formal parameter. + -- * Elementary function case: check each actual is dimensionless except + -- for Sqrt call. + -- Step 2. Dimension propagation (only for functions): + -- * General case: propagate the dimensions from the returned type to the + -- function call. + -- * Sqrt case: the resulting dimensions equal to half the dimensions of + -- the actual + + procedure Analyze_Dimension_Extension_Or_Record_Aggregate (N : Node_Id); + -- Check, for each component of the extension or record aggregate denoted + -- by N, the dimensions of the component expression match the dimensions of + -- the component type. + + procedure Analyze_Dimension_Formals (N : Node_Id; Formals : List_Id); + -- For sub spec N, issue a warning for each dimensioned formal with a + -- literal default value in the list of formals Formals. + procedure Eval_Op_Expon_For_Dimensioned_Type (N : Node_Id; Btyp : Entity_Id); @@ -150,8 +183,8 @@ -- Return True if N is a package instantiation of System.Dim.Integer_IO or -- of System.Dim.Float_IO. - procedure Remove_Dimension_In_Call (Call : Node_Id); - -- Remove the dimensions from all formal parameters of Call + procedure Move_Dimensions (From : Node_Id; To : Node_Id); + -- Copy dimension vector of From to To, delete dimension vector of From procedure Remove_Dimension_In_Statement (Stmt : Node_Id); -- Remove the dimensions associated with Stmt Index: s-dmotpr.ads =================================================================== --- s-dmotpr.ads (revision 191888) +++ s-dmotpr.ads (working copy) @@ -38,6 +38,9 @@ -- SI prefixes for Meter + pragma Warnings (Off); + -- Turn off the all the dimension warnings + ym : constant Length := 1.0E-24; -- yocto zm : constant Length := 1.0E-21; -- zepto am : constant Length := 1.0E-18; -- atto @@ -165,4 +168,5 @@ Zecd : constant Luminous_Intensity := 1.0E+21; -- zetta Yocd : constant Luminous_Intensity := 1.0E+24; -- yotta + pragma Warnings (On); end System.Dim.Mks.Other_Prefixes; Index: sem_res.adb =================================================================== --- sem_res.adb (revision 191894) +++ sem_res.adb (working copy) @@ -5888,8 +5888,11 @@ end; end if; - Analyze_Dimension (N); + -- Check the dimensions of the actuals in the call. For function calls, + -- propagate the dimensions from the returned type to N. + Analyze_Dimension_Call (N, Nam); + -- All done, evaluate call and deal with elaboration issues Eval_Call (N); Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 191900) +++ exp_ch6.adb (working copy) @@ -2392,10 +2392,6 @@ Expand_Put_Call_With_Symbol (Call_Node); end if; - -- Remove the dimensions of every parameters in call - - Remove_Dimension_In_Call (N); - -- Ignore if previous error if Nkind (Call_Node) in N_Has_Etype Index: sem_ch6.adb =================================================================== --- sem_ch6.adb (revision 191903) +++ sem_ch6.adb (working copy) @@ -3450,6 +3450,10 @@ Push_Scope (Designator); Process_Formals (Formals, N); + -- Check dimensions in N for formals with default expression + + Analyze_Dimension_Formals (N, Formals); + -- Ada 2005 (AI-345): If this is an overriding operation of an -- inherited interface operation, and the controlling type is -- a synchronized type, replace the type with its corresponding Index: sem_ch8.adb =================================================================== --- sem_ch8.adb (revision 191894) +++ sem_ch8.adb (working copy) @@ -577,6 +577,8 @@ else Find_Expanded_Name (N); end if; + + Analyze_Dimension (N); end Analyze_Expanded_Name; --------------------------------------- @@ -6153,6 +6155,8 @@ Analyze_Selected_Component (N); end if; + + Analyze_Dimension (N); end Find_Selected_Component; --------------- Index: s-dimmks.ads =================================================================== --- s-dimmks.ads (revision 191888) +++ s-dimmks.ads (working copy) @@ -103,6 +103,9 @@ -- SI Base units + pragma Warnings (Off); + -- Turn off the all the dimension warnings + m : constant Length := 1.0; kg : constant Mass := 1.0; s : constant Time := 1.0; @@ -111,98 +114,134 @@ mol : constant Amount_Of_Substance := 1.0; cd : constant Luminous_Intensity := 1.0; + pragma Warnings (On); + -- SI Derived dimensioned subtypes + subtype Absorbed_Dose is Mks_Type + with + Dimension => (Symbol => "Gy", + Meter => 2, + Second => -2, + others => 0); + subtype Angle is Mks_Type with Dimension => (Symbol => "rad", others => 0); - subtype Solid_Angle is Mks_Type + subtype Area is Mks_Type with - Dimension => (Symbol => "sr", + Dimension => ( + Meter => 2, others => 0); - subtype Frequency is Mks_Type + subtype Catalytic_Activity is Mks_Type with - Dimension => (Symbol => "Hz", + Dimension => (Symbol => "kat", Second => -1, + Mole => 1, others => 0); - subtype Force is Mks_Type + subtype Celsius_Temperature is Mks_Type with - Dimension => (Symbol => 'N', - Meter => 1, - Kilogram => 1, - Second => -2, + Dimension => (Symbol => "°C", + Kelvin => 1, + others => 0); + + subtype Electric_Capacitance is Mks_Type + with + Dimension => (Symbol => 'F', + Meter => -2, + Kilogram => -1, + Second => 4, + Ampere => 2, others => 0); - subtype Pressure is Mks_Type + subtype Electric_Charge is Mks_Type with - Dimension => (Symbol => "Pa", - Meter => -1, - Kilogram => 1, - Second => -2, + Dimension => (Symbol => 'C', + Second => 1, + Ampere => 1, + others => 0); + + subtype Electric_Conductance is Mks_Type + with + Dimension => (Symbol => 'S', + Meter => -2, + Kilogram => -1, + Second => 3, + Ampere => 2, others => 0); - subtype Energy is Mks_Type + subtype Electric_Potential_Difference is Mks_Type with - Dimension => (Symbol => 'J', + Dimension => (Symbol => 'V', Meter => 2, Kilogram => 1, - Second => -2, + Second => -3, + Ampere => -1, others => 0); - subtype Power is Mks_Type + subtype Electric_Resistance is Mks_Type with - Dimension => (Symbol => 'W', + Dimension => (Symbol => "Ω", Meter => 2, Kilogram => 1, Second => -3, + Ampere => -2, others => 0); - subtype Electric_Charge is Mks_Type + subtype Energy is Mks_Type with - Dimension => (Symbol => 'C', - Second => 1, - Ampere => 1, + Dimension => (Symbol => 'J', + Meter => 2, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Equivalent_Dose is Mks_Type + with + Dimension => (Symbol => "Sv", + Meter => 2, + Second => -2, others => 0); - subtype Electric_Potential_Difference is Mks_Type + subtype Force is Mks_Type with - Dimension => (Symbol => 'V', - Meter => 2, + Dimension => (Symbol => 'N', + Meter => 1, Kilogram => 1, - Second => -3, - Ampere => -1, + Second => -2, others => 0); - subtype Electric_Capacitance is Mks_Type + subtype Frequency is Mks_Type with - Dimension => (Symbol => 'F', - Meter => -2, - Kilogram => -1, - Second => 4, - Ampere => 2, - others => 0); + Dimension => (Symbol => "Hz", + Second => -1, + others => 0); - subtype Electric_Resistance is Mks_Type + subtype Illuminance is Mks_Type with - Dimension => (Symbol => "Ω", + Dimension => (Symbol => "lx", + Meter => -2, + Candela => 1, + others => 0); + + subtype Inductance is Mks_Type + with + Dimension => (Symbol => 'H', Meter => 2, Kilogram => 1, - Second => -3, + Second => -2, Ampere => -2, others => 0); - subtype Electric_Conductance is Mks_Type + subtype Luminous_Flux is Mks_Type with - Dimension => (Symbol => 'S', - Meter => -2, - Kilogram => -1, - Second => 3, - Ampere => 2, - others => 0); + Dimension => (Symbol => "lm", + Candela => 1, + others => 0); subtype Magnetic_Flux is Mks_Type with @@ -221,61 +260,49 @@ Ampere => -1, others => 0); - subtype Inductance is Mks_Type + subtype Power is Mks_Type with - Dimension => (Symbol => 'H', + Dimension => (Symbol => 'W', Meter => 2, Kilogram => 1, - Second => -2, - Ampere => -2, + Second => -3, others => 0); - subtype Celsius_Temperature is Mks_Type + subtype Pressure is Mks_Type with - Dimension => (Symbol => "°C", - Kelvin => 1, - others => 0); + Dimension => (Symbol => "Pa", + Meter => -1, + Kilogram => 1, + Second => -2, + others => 0); - subtype Luminous_Flux is Mks_Type - with - Dimension => (Symbol => "lm", - Candela => 1, - others => 0); - - subtype Illuminance is Mks_Type - with - Dimension => (Symbol => "lx", - Meter => -2, - Candela => 1, - others => 0); - subtype Radioactivity is Mks_Type with Dimension => (Symbol => "Bq", Second => -1, others => 0); - subtype Absorbed_Dose is Mks_Type + subtype Solid_Angle is Mks_Type with - Dimension => (Symbol => "Gy", - Meter => 2, - Second => -2, + Dimension => (Symbol => "sr", others => 0); - subtype Equivalent_Dose is Mks_Type + subtype Speed is Mks_Type with - Dimension => (Symbol => "Sv", - Meter => 2, - Second => -2, + Dimension => ( + Meter => 1, + Second => -1, others => 0); - subtype Catalytic_Activity is Mks_Type + subtype Volume is Mks_Type with - Dimension => (Symbol => "kat", - Second => -1, - Mole => 1, + Dimension => ( + Meter => 3, others => 0); + pragma Warnings (Off); + -- Turn off the all the dimension warnings + rad : constant Angle := 1.0; sr : constant Solid_Angle := 1.0; Hz : constant Frequency := 1.0; @@ -349,4 +376,5 @@ kA : constant Electric_Current := 1.0E+03; -- kilo MeA : constant Electric_Current := 1.0E+06; -- mega + pragma Warnings (On); end System.Dim.Mks;