[Ada] Minor changes for GNAT dimensionality checking system
Arnaud Charlet
charlet@adacore.com
Wed Feb 22 14:04:00 GMT 2012
Tested on x86_64-pc-linux-gnu, committed on trunk
2012-02-22 Vincent Pucci <pucci@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.
-------------- next part --------------
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 := Dimensions_Of (First (Actuals));
- 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,
+ 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;
+ end loop;
- Set_Dimensions (N, Dims_Of_Call);
- end if;
+ Set_Dimensions (N, Dims_Of_Call);
+ end if;
- -- All other functions in Ada.Numerics.Generic_Elementary_Functions
- -- case. Note that all parameters here should be dimensionless.
+ -- All other elementary functions case. Note that every actual
+ -- here should be dimensionless.
- else
- Actual := First (Actuals);
- while Present (Actual) loop
- Dims_Of_Actual := Dimensions_Of (Actual);
+ else
+ Actual := First (Actuals);
+ while Present (Actual) loop
+ Dims_Of_Actual := Dimensions_Of (Actual);
- if Exists (Dims_Of_Actual) then
- Error_Msg_NE ("parameter should be dimensionless for " &
- "elementary function&",
- Actual,
- Name_Call);
- Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
- Actual);
- end if;
+ if Exists (Dims_Of_Actual) then
+ Error_Msg_NE ("parameter should be dimensionless for " &
+ "elementary function&",
+ Actual,
+ Name_Call);
+ Error_Msg_N ("\parameter " & Dimensions_Msg_Of (Actual),
+ Actual);
+ end if;
- Next (Actual);
- end loop;
+ Next (Actual);
+ end loop;
+ end if;
+
+ return;
end if;
+ end if;
- -- Other case
+ -- Other cases
- else
- Analyze_Dimension_Has_Etype (N);
- end if;
+ Analyze_Dimension_Has_Etype (N);
end Analyze_Dimension_Function_Call;
---------------------------------
@@ -2226,28 +2236,31 @@
function Is_Procedure_Put_Call return Boolean is
Ent : Entity_Id;
+ Loc : Source_Ptr;
begin
- -- There are three different Put routine in each generic package
- -- Check that the current procedure call is one of them
+ -- There are three different Put routines in each generic dim IO
+ -- package. Verify the current procedure call is one of them.
if Is_Entity_Name (Name_Call) then
Ent := Entity (Name_Call);
- -- Check that the name of the procedure is Put
- -- Check the procedure is defined in an instantiation of a
- -- generic package.
+ -- Get the original subprogram entity following the renaming chain
- if Chars (Name_Call) = Name_Put
- and then Is_Generic_Instance (Scope (Ent))
- then
- Ent := Cunit_Entity (Get_Source_Unit (Ent));
+ if Present (Alias (Ent)) then
+ Ent := Alias (Ent);
+ end if;
- -- Verify that the generic package is either
- -- System.Dim.Float_IO or System.Dim.Integer_IO.
+ Loc := Sloc (Ent);
- return Is_Dim_IO_Package_Entity (Ent);
- end if;
+ -- Check the name of the entity subprogram is Put and verify this
+ -- entity is located in either System.Dim.Float_IO or
+ -- System.Dim.Integer_IO.
+
+ return Chars (Ent) = Name_Put
+ and then Loc > No_Location
+ and then Is_Dim_IO_Package_Entity
+ (Cunit_Entity (Get_Source_Unit (Loc)));
end if;
return False;
@@ -2499,22 +2512,14 @@
-- Is_Dim_IO_Package_Entity --
------------------------------
- -- Why all this comparison of names, why not use Is_RTE and Is_RTU ???
-
function Is_Dim_IO_Package_Entity (E : Entity_Id) return Boolean is
begin
- -- Check the package entity is standard and its scope is either
- -- System.Dim.Float_IO or System.Dim.Integer_IO.
+ -- Check the package entity corresponds to System.Dim.Float_IO or
+ -- System.Dim.Integer_IO.
- if Is_Library_Level_Entity (E)
- and then (Chars (E) = Name_Float_IO
- or else Chars (E) = Name_Integer_IO)
- then
- return Chars (Scope (E)) = Name_Dim
- and Chars (Scope (Scope (E))) = Name_System;
- end if;
-
- return False;
+ return
+ Is_RTU (E, System_Dim_Float_IO)
+ or Is_RTU (E, System_Dim_Integer_IO);
end Is_Dim_IO_Package_Entity;
-------------------------------------
@@ -2523,19 +2528,14 @@
function Is_Dim_IO_Package_Instantiation (N : Node_Id) return Boolean is
Gen_Id : constant Node_Id := Name (N);
- Ent : Entity_Id;
begin
- if Is_Entity_Name (Gen_Id) then
- Ent := Entity (Gen_Id);
+ -- Check that the instantiated package is either System.Dim.Float_IO
+ -- or System.Dim.Integer_IO.
- -- Verify that the instantiated package is either System.Dim.Float_IO
- -- or System.Dim.Integer_IO.
-
- return Is_Dim_IO_Package_Entity (Ent);
- end if;
-
- return False;
+ return
+ Is_Entity_Name (Gen_Id)
+ and then Is_Dim_IO_Package_Entity (Entity (Gen_Id));
end Is_Dim_IO_Package_Instantiation;
----------------
Index: rtsfind.adb
===================================================================
--- rtsfind.adb (revision 184470)
+++ rtsfind.adb (working copy)
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
@@ -313,6 +313,9 @@
elsif U_Id in Ada_Interrupts_Child then
Name_Buffer (15) := '.';
+ elsif U_Id in Ada_Numerics_Child then
+ Name_Buffer (13) := '.';
+
elsif U_Id in Ada_Real_Time_Child then
Name_Buffer (14) := '.';
@@ -338,6 +341,10 @@
elsif U_Id in System_Child then
Name_Buffer (7) := '.';
+ if U_Id in System_Dim_Child then
+ Name_Buffer (11) := '.';
+ end if;
+
if U_Id in System_Multiprocessors_Child then
Name_Buffer (23) := '.';
end if;
Index: rtsfind.ads
===================================================================
--- rtsfind.ads (revision 184470)
+++ rtsfind.ads (working copy)
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-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- --
@@ -125,6 +125,7 @@
Ada_Exceptions,
Ada_Finalization,
Ada_Interrupts,
+ Ada_Numerics,
Ada_Real_Time,
Ada_Streams,
Ada_Strings,
@@ -144,6 +145,10 @@
Ada_Interrupts_Names,
+ -- Children of Ada.Numerics
+
+ Ada_Numerics_Generic_Elementary_Functions,
+
-- Children of Ada.Real_Time
Ada_Real_Time_Delays,
@@ -223,6 +228,7 @@
System_Concat_7,
System_Concat_8,
System_Concat_9,
+ System_Dim,
System_DSA_Services,
System_DSA_Types,
System_Exception_Table,
@@ -372,6 +378,11 @@
System_WWd_Enum,
System_WWd_Wchar,
+ -- Children of System.Dim
+
+ System_Dim_Float_IO,
+ System_Dim_Integer_IO,
+
-- Children of System.Multiprocessors
System_Multiprocessors_Dispatching_Domains,
@@ -413,6 +424,11 @@
Ada_Interrupts_Names .. Ada_Interrupts_Names;
-- Range of values for children of Ada.Interrupts
+ subtype Ada_Numerics_Child is Ada_Child
+ range Ada_Numerics_Generic_Elementary_Functions ..
+ Ada_Numerics_Generic_Elementary_Functions;
+ -- Range of values for children of Ada.Numerics
+
subtype Ada_Real_Time_Child is Ada_Child
range Ada_Real_Time_Delays .. Ada_Real_Time_Timing_Events;
-- Range of values for children of Ada.Real_Time
@@ -445,6 +461,10 @@
range System_Address_Image .. System_Tasking_Stages;
-- Range of values for children or grandchildren of System
+ subtype System_Dim_Child is RTU_Id
+ range System_Dim_Float_IO .. System_Dim_Integer_IO;
+ -- Range of values for children of System.Dim
+
subtype System_Multiprocessors_Child is RTU_Id
range System_Multiprocessors_Dispatching_Domains ..
System_Multiprocessors_Dispatching_Domains;
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl (revision 184470)
+++ snames.ads-tmpl (working copy)
@@ -225,8 +225,6 @@
-- Names used by the analyzer and expander for aspect Dimension and
-- Dimension_System to deal with Sqrt and IO routines.
- Name_Dim : constant Name_Id := N + $; -- Ada 12
- Name_Generic_Elementary_Functions : constant Name_Id := N + $; -- Ada 12
Name_Item : constant Name_Id := N + $; -- Ada 12
Name_Sqrt : constant Name_Id := N + $; -- Ada 12
Name_Symbols : constant Name_Id := N + $; -- Ada 12
More information about the Gcc-patches
mailing list