Patchwork [Ada] Minor changes for GNAT dimensionality checking system

login
register
mail settings
Submitter Arnaud Charlet
Date Feb. 22, 2012, 1:54 p.m.
Message ID <20120222135408.GA6621@adacore.com>
Download mbox | patch
Permalink /patch/142457/
State New
Headers show

Comments

Arnaud Charlet - Feb. 22, 2012, 1:54 p.m.
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.

Patch

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