[Ada] Check that rtsfind entities are not overloaded

Arnaud Charlet charlet@adacore.com
Mon Sep 5 14:31:00 GMT 2011


This patch properly documents the rule that rtsfind entities may not
be overloaded, and adds a check that this rule is met. This found
one violation of the rule in the run time which has been fixed. No
test is required, since this clean up has no external effect.

Tested on x86_64-pc-linux-gnu, committed on trunk

2011-09-05  Robert Dewar  <dewar@adacore.com>

	* rtsfind.adb (Check_CRT): Check for overloaded entity
	* rtsfind.ads: Document that entities to be found by rtsfind
	cannot be overloaded
	* s-taenca.adb, s-tasren.adb, s-tpobop.adb, s-tpoben.ads, s-tpoben.adb
	(Lock_Entries_With_Status): New name for Lock_Entries with two
	arguments (changed to meet rtsfind no overloading rule).

-------------- next part --------------
Index: s-tpoben.adb
===================================================================
--- s-tpoben.adb	(revision 178381)
+++ s-tpoben.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                               B o d y                                    --
 --                                                                          --
---          Copyright (C) 1998-2010, Free Software Foundation, Inc.         --
+--          Copyright (C) 1998-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNARL 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- --
@@ -261,7 +261,22 @@
    -- Lock_Entries --
    ------------------
 
-   procedure Lock_Entries
+   procedure Lock_Entries (Object : Protection_Entries_Access) is
+      Ceiling_Violation : Boolean;
+
+   begin
+      Lock_Entries_With_Status (Object, Ceiling_Violation);
+
+      if Ceiling_Violation then
+         raise Program_Error with "Ceiling Violation";
+      end if;
+   end Lock_Entries;
+
+   ------------------------------
+   -- Lock_Entries_With_Status --
+   ------------------------------
+
+   procedure Lock_Entries_With_Status
      (Object            : Protection_Entries_Access;
       Ceiling_Violation : out Boolean)
    is
@@ -316,20 +331,8 @@
               Self_Id.Common.Protected_Action_Nesting + 1;
          end;
       end if;
+   end Lock_Entries_With_Status;
 
-   end Lock_Entries;
-
-   procedure Lock_Entries (Object : Protection_Entries_Access) is
-      Ceiling_Violation : Boolean;
-
-   begin
-      Lock_Entries (Object, Ceiling_Violation);
-
-      if Ceiling_Violation then
-         raise Program_Error with "Ceiling Violation";
-      end if;
-   end Lock_Entries;
-
    ----------------------------
    -- Lock_Read_Only_Entries --
    ----------------------------
Index: s-tpoben.ads
===================================================================
--- s-tpoben.ads	(revision 178381)
+++ s-tpoben.ads	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  S p e c                                 --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2011, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNARL 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- --
@@ -183,7 +183,7 @@
    --  Unlock has been made by the caller. Program_Error is raised in case of
    --  ceiling violation.
 
-   procedure Lock_Entries
+   procedure Lock_Entries_With_Status
      (Object            : Protection_Entries_Access;
       Ceiling_Violation : out Boolean);
    --  Same as above, but return the ceiling violation status instead of
Index: s-tasren.adb
===================================================================
--- s-tasren.adb	(revision 178381)
+++ s-tasren.adb	(working copy)
@@ -628,7 +628,7 @@
                --  Requeue to a protected entry
 
                Called_PO := POE.To_Protection (Entry_Call.Called_PO);
-               STPE.Lock_Entries (Called_PO, Ceiling_Violation);
+               STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation);
 
                if Ceiling_Violation then
                   pragma Assert (Ex = Ada.Exceptions.Null_Id);
Index: rtsfind.adb
===================================================================
--- rtsfind.adb	(revision 178381)
+++ rtsfind.adb	(working copy)
@@ -135,7 +135,7 @@
    --  Check entity Eid to ensure that configurable run-time restrictions are
    --  met. May generate an error message (if RTE_Available_Call is false) and
    --  raise RE_Not_Available if entity E does not exist (e.g. Eid is Empty).
-   --  Above documentation not clear ???
+   --  Also check that entity is not overloaded.
 
    procedure Entity_Not_Defined (Id : RE_Id);
    --  Outputs error messages for an entity that is not defined in the run-time
@@ -233,6 +233,22 @@
             raise RE_Not_Available;
          end if;
 
+         --  Check entity is not overloaded, checking for special exceptions
+
+         if Has_Homonym (Eid)
+           and then E /= RE_Save_Occurrence
+         then
+            Set_Standard_Error;
+            Write_Str ("Run-time configuration error (");
+            Write_Str ("rtsfind entity """);
+            Get_Decoded_Name_String (Chars (Eid));
+            Set_Casing (Mixed_Case);
+            Write_Str (Name_Buffer (1 .. Name_Len));
+            Write_Str (""" is overloaded)");
+            Write_Eol;
+            raise Unrecoverable_Error;
+         end if;
+
          --  Otherwise entity is accessible
 
          return Eid;
@@ -414,8 +430,8 @@
          return E1 = E2;
       end if;
 
-      --  If the unit containing E is not loaded, we already know that
-      --  the entity we have cannot have come from this unit.
+      --  If the unit containing E is not loaded, we already know that the
+      --  entity we have cannot have come from this unit.
 
       E_Unit_Name := Get_Unit_Name (RE_Unit_Table (E));
 
Index: rtsfind.ads
===================================================================
--- rtsfind.ads	(revision 178381)
+++ rtsfind.ads	(working copy)
@@ -498,6 +498,14 @@
    --  value is required syntactically, but no real entry is required or
    --  needed. Use of this value will cause a fatal error in an RTE call.
 
+   --  Note that under no circumstances can any of these entities be defined
+   --  more than once in a given package, i.e. no overloading is allowed for
+   --  any entity that is found using rtsfind. A fatal error is given if this
+   --  rule is violated. The one exception is for Save_Occurrence, where the
+   --  RM mandates the overloading. In this case, the compiler only uses the
+   --  procedure, not the function, and the procedure must come first so that
+   --  the compiler finds it and not the function.
+
    type RE_Id is (
 
      RE_Null,
Index: s-tpobop.adb
===================================================================
--- s-tpobop.adb	(revision 178381)
+++ s-tpobop.adb	(working copy)
@@ -568,7 +568,7 @@
       --  where abort is already deferred.
 
       Initialization.Defer_Abort_Nestable (Self_ID);
-      Lock_Entries (Object, Ceiling_Violation);
+      Lock_Entries_With_Status (Object, Ceiling_Violation);
 
       if Ceiling_Violation then
 
@@ -722,7 +722,7 @@
 
             --  Requeue is to different PO
 
-            Lock_Entries (New_Object, Ceiling_Violation);
+            Lock_Entries_With_Status (New_Object, Ceiling_Violation);
 
             if Ceiling_Violation then
                Object.Call_In_Progress := null;
@@ -966,7 +966,7 @@
       end if;
 
       Initialization.Defer_Abort_Nestable (Self_Id);
-      Lock_Entries (Object, Ceiling_Violation);
+      Lock_Entries_With_Status (Object, Ceiling_Violation);
 
       if Ceiling_Violation then
          Initialization.Undefer_Abort (Self_Id);
Index: s-taenca.adb
===================================================================
--- s-taenca.adb	(revision 178381)
+++ s-taenca.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                  B o d y                                 --
 --                                                                          --
---         Copyright (C) 1992-2010, Free Software Foundation, Inc.          --
+--         Copyright (C) 1992-2011, Free Software Foundation, Inc.          --
 --                                                                          --
 -- GNARL 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- --
@@ -216,7 +216,7 @@
                   STPO.Unlock_RTS;
                end if;
 
-               Lock_Entries (Test_PO, Ceiling_Violation);
+               Lock_Entries_With_Status (Test_PO, Ceiling_Violation);
 
                --  ???
 


More information about the Gcc-patches mailing list