[Ada] Minor changes for GNAT dimensionality checking system
Tested on x86_64-pc-linux-gnu, committed on trunk 2012-02-22 Vincent Pucci pu...@adacore.com * rtsfind.adb (Get_Unit_Name): Ada_Numerics_Child and System_Dim_Child cases added. * rtsfind.ads: Ada_Numerics, Ada_Numerics_Generic_Elementary_Functions, System_Dim, System_Dim_Float_IO and System_Dim_Integer_IO added to the list of RTU_Id. Ada_Numerics_Child and System_Dim_Child added as new RTU_Id subtypes. * sem_dim.adb (Is_Dim_IO_Package_Entity): Use of Rtsfind to verify the package entity is located either in System.Dim.Integer_IO or in System.Dim.Float_IO. (Is_Dim_IO_Package_Instantiation): Minor changes. (Is_Elementary_Function_Call): Removed. (Is_Elementary_Function_Entity): New routine. (Is_Procedure_Put_Call): Is_Dim_IO_Package_Entity call added. * snames.ads-tmpl: Name_Dim and Name_Generic_Elementary_Functions removed. Index: sem_dim.adb === --- sem_dim.adb (revision 184470) +++ sem_dim.adb (working copy) @@ -36,7 +36,6 @@ 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 Snames; use Snames; with Stand;use Stand; @@ -1359,94 +1358,105 @@ -- Analyze_Dimension_Function_Call -- - + -- 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_Function_Call (N : Node_Id) is + Actuals: constant List_Id := Parameter_Associations (N); Name_Call : constant Node_Id := Name (N); - Actuals: constant List_Id := Parameter_Associations (N); Actual : Node_Id; Dims_Of_Actual : Dimension_Type; Dims_Of_Call : Dimension_Type; + Ent: Entity_Id; - function Is_Elementary_Function_Call return Boolean; - -- Return True if the call is a call of an elementary function (see + function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean; + -- Given E the original subprogram entity, return True if the call is a + -- an elementary function call (see -- Ada.Numerics.Generic_Elementary_Functions). - - - -- Is_Elementary_Function_Call -- - - + --- + -- Is_Elementary_Function_Entity -- + --- - function Is_Elementary_Function_Call return Boolean is - Ent : Entity_Id; + function Is_Elementary_Function_Entity (E : Entity_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (E); begin - if Is_Entity_Name (Name_Call) then -Ent := Entity (Name_Call); + -- Check the function entity is located in + -- Ada.Numerics.Generic_Elementary_Functions. --- Check the procedure is defined in an instantiation of a generic --- package. + 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 Is_Generic_Instance (Scope (Ent)) then - Ent := Cunit_Entity (Get_Source_Unit (Ent)); + -- Start of processing for Analyze_Dimension_Function_Call - -- Check the name of the generic package is - -- Generic_Elementary_Functions + begin + -- Look for elementary function call - return - Is_Library_Level_Entity (Ent) - and then Chars (Ent) = Name_Generic_Elementary_Functions; -end if; - end if; + if Is_Entity_Name (Name_Call) then + Ent := Entity (Name_Call); - return False; - end Is_Elementary_Function_Call; + -- Get the original subprogram entity following the renaming chain - -- Start of processing for Analyze_Dimension_Function_Call + if Present (Alias (Ent)) then +Ent := Alias (Ent); + end if; - begin - -- Elementary function case + -- Elementary function case - if Is_Elementary_Function_Call then + if Is_Elementary_Function_Entity (Ent) then -- Sqrt function call case - if Chars (Name_Call) = Name_Sqrt then -Dims_Of_Call := Dimensions_Of (First (Actuals)); +if Chars (Ent) = Name_Sqrt then + Dims_Of_Call :=
[Ada] Minor changes for GNAT dimensionality checking system
Tested on x86_64-pc-linux-gnu, committed on trunk 2012-01-30 Vincent Pucci pu...@adacore.com * sem_dim.adb (Expand_Put_Call_With_Dimension_Symbol): Rewritten. * snames.ads-tmpl: Name_Item and Name_Symbols added. * s-diflio.adb, s-diflio.ads, s-diinio.adb, s-diinio.ads: Rename and change the position of parameter Symbols in every Put routine. * s-dimmks.ads: Convert long float type Mks_Type into long long float. * s-llflex.ads: Modifications in comments. Index: s-diinio.adb === --- s-diinio.adb(revision 183694) +++ s-diinio.adb(working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- ---Copyright (C) 2011, Free Software Foundation, Inc.-- +-- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -38,40 +38,40 @@ - procedure Put - (File : File_Type; - Item : Num_Dim_Integer; - Unit : String := ; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) + (File: File_Type; + Item: Num_Dim_Integer; + Width : Field := Default_Width; + Base: Number_Base := Default_Base; + Symbols : String := ) is begin Num_Dim_Integer_IO.Put (File, Item, Width, Base); - Ada.Text_IO.Put (File, Unit); + Ada.Text_IO.Put (File, Symbols); end Put; procedure Put - (Item : Num_Dim_Integer; - Unit : String := ; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) + (Item: Num_Dim_Integer; + Width : Field := Default_Width; + Base: Number_Base := Default_Base; + Symbols : String := ) is begin Num_Dim_Integer_IO.Put (Item, Width, Base); - Ada.Text_IO.Put (Unit); + Ada.Text_IO.Put (Symbols); end Put; procedure Put - (To: out String; - Item : Num_Dim_Integer; - Unit : String := ; - Base : Number_Base := Default_Base) + (To : out String; + Item: Num_Dim_Integer; + Base: Number_Base := Default_Base; + Symbols : String := ) is begin Num_Dim_Integer_IO.Put (To, Item, Base); - To := To Unit; + To := To Symbols; end Put; end System.Dim_Integer_IO; Index: s-diinio.ads === --- s-diinio.ads(revision 183694) +++ s-diinio.ads(working copy) @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- ---Copyright (C) 2011, Free Software Foundation, Inc.-- +-- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -47,23 +47,23 @@ Default_Base : Number_Base := 10; procedure Put - (File : File_Type; - Item : Num_Dim_Integer; - Unit : String := ; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); + (File: File_Type; + Item: Num_Dim_Integer; + Width : Field := Default_Width; + Base: Number_Base := Default_Base; + Symbols : String := ); procedure Put - (Item : Num_Dim_Integer; - Unit : String := ; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); + (Item: Num_Dim_Integer; + Width : Field := Default_Width; + Base: Number_Base := Default_Base; + Symbols : String := ); procedure Put - (To: out String; - Item : Num_Dim_Integer; - Unit : String := ; - Base : Number_Base := Default_Base); + (To : out String; + Item: Num_Dim_Integer; + Base: Number_Base := Default_Base; + Symbols : String := ); pragma Inline (Put); Index: sem_dim.adb === --- sem_dim.adb (revision 183694) +++ sem_dim.adb (working copy) @@ -6,7 +6,7 @@ --
