Patchwork [Ada] Implement inheritance for predicates

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 22, 2010, 9:20 a.m.
Message ID <20101022092011.GA12472@adacore.com>
Download mbox | patch
Permalink /patch/68816/
State New
Headers show

Comments

Arnaud Charlet - Oct. 22, 2010, 9:20 a.m.
This patch finalizes the proper treatment of inheritance for
predicates. The following test compiles as shown with -gnata12
-gnatld7 -gnatj60 and generates no output when run:

     1. with Ada.Assertions; use Ada.Assertions;
     2. procedure inherit_predicates is
     3.    type r is new integer range 1 .. 100 with
     4.      predicate => r mod 2 = 1;
     5.
     6.    subtype s is r with
                   |
        >>> info: "s" inherits predicate from "r" at line 3

     7.      predicate => s <= 13;
     8.
     9.    type q is new s with
                |
        >>> info: "q" inherits predicate from "s" at line 6

    10.       predicate => q mod 3 = 0;
    11.
    12.    qv : q;
    13.
    14. begin
    15.    begin
    16.       qv := 11; -- not divisible by 3
    17.       raise Program_Error;
    18.    exception
    19.       when Assertion_Error =>
    20.          null;
    21.    end;
    22.
    23.    begin
    24.       qv := 21; -- greater than 13
    25.       raise Program_Error;
    26.    exception
    27.       when Assertion_Error =>
    28.          null;
    29.    end;
    30.
    31.    begin
    32.       qv := 6; -- not odd
    33.       raise Program_Error;
    34.    exception
    35.       when Assertion_Error =>
    36.          null;
    37.    end;
    38.
    39.    begin
    40.       qv := 9; -- ok
    41.    end;
    42. end inherit_predicates;

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

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* checks.adb (Apply_Predicate_Check): Remove attempt at optimization
	when subtype is the same, caused legitimate checks to be missed.
	* exp_ch13.adb (Build_Predicate_Function): Use Nearest_Ancestor to get
	inheritance from right entity.
	* freeze.adb (Freeze_Entity): Use Nearest_Ancestor to freeze in the
	derived type case if the ancestor type has predicates.
	* sem_aux.ads, sem_aux.adb (Nearest_Ancestor): New function.

Patch

Index: sem_aux.adb
===================================================================
--- sem_aux.adb	(revision 165803)
+++ sem_aux.adb	(working copy)
@@ -749,6 +749,46 @@  package body Sem_Aux is
       end if;
    end Is_Limited_Type;
 
+   ----------------------
+   -- Nearest_Ancestor --
+   ----------------------
+
+   function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
+         D : constant Node_Id := Declaration_Node (Typ);
+
+   begin
+      --  If we have a subtype declaration, get the ancestor subtype
+
+      if Nkind (D) = N_Subtype_Declaration then
+         if Nkind (Subtype_Indication (D)) = N_Subtype_Indication then
+            return Entity (Subtype_Mark (Subtype_Indication (D)));
+         else
+            return Entity (Subtype_Indication (D));
+         end if;
+
+      --  If derived type declaration, find who we are derived from
+
+      elsif Nkind (D) = N_Full_Type_Declaration
+        and then Nkind (Type_Definition (D)) = N_Derived_Type_Definition
+      then
+         declare
+            DTD : constant Entity_Id := Type_Definition (D);
+            SI  : constant Entity_Id := Subtype_Indication (DTD);
+         begin
+            if Is_Entity_Name (SI) then
+               return Entity (SI);
+            else
+               return Entity (Subtype_Mark (SI));
+            end if;
+         end;
+
+      --  Otherwise, nothing useful to return, return Empty
+
+      else
+         return Empty;
+      end if;
+   end Nearest_Ancestor;
+
    ---------------------------
    -- Nearest_Dynamic_Scope --
    ---------------------------
Index: sem_aux.ads
===================================================================
--- sem_aux.ads	(revision 165803)
+++ sem_aux.ads	(working copy)
@@ -181,6 +181,24 @@  package Sem_Aux is
    --  composite containing a limited component, or a subtype of any of
    --  these types).
 
+   function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
+   --  Given a subtype Typ, this function finds out the nearest ancestor from
+   --  which constraints and predicates are inherited. There is no simple link
+   --  for doing this, consider:
+   --
+   --     subtype R is Integer range 1 .. 10;
+   --     type T is new R;
+   --
+   --  In this case the nearest ancestor is R, but the Etype of T'Base will
+   --  point to R'Base, so we have to go rummaging in the declarations to get
+   --  this information. It is used for making sure we freeze this before we
+   --  freeze Typ, and also for retrieving inherited predicate information.
+   --  For the case of base types or first subtypes, there is no useful entity
+   --  to return, so Empty is returned.
+   --
+   --  Note: this is similar to Ancestor_Subtype except that it also deals
+   --  with the case of derived types.
+
    function Nearest_Dynamic_Scope (Ent : Entity_Id) return Entity_Id;
    --  This is similar to Enclosing_Dynamic_Scope except that if Ent is itself
    --  a dynamic scope, then it is returned. Otherwise the result is the same
Index: checks.adb
===================================================================
--- checks.adb	(revision 165803)
+++ checks.adb	(working copy)
@@ -1759,9 +1759,7 @@  package body Checks is
 
    procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
    begin
-      if Etype (N) /= Typ
-        and then Present (Predicate_Function (Typ))
-      then
+      if Present (Predicate_Function (Typ)) then
          Insert_Action (N,
            Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
       end if;
Index: freeze.adb
===================================================================
--- freeze.adb	(revision 165804)
+++ freeze.adb	(working copy)
@@ -3096,18 +3096,31 @@  package body Freeze is
             end if;
 
             --  If ancestor subtype present, freeze that first. Note that this
-            --  will also get the base type frozen.
+            --  will also get the base type frozen. Need RM reference ???
 
             Atype := Ancestor_Subtype (E);
 
             if Present (Atype) then
                Freeze_And_Append (Atype, N, Result);
 
-            --  Otherwise freeze the base type of the entity before freezing
-            --  the entity itself (RM 13.14(15)).
+            --  No ancestor subtype present
 
-            elsif E /= Base_Type (E) then
-               Freeze_And_Append (Base_Type (E), N, Result);
+            else
+               --  See if we have a nearest ancestor that has a predicate.
+               --  That catches the case of derived type with a predicate.
+               --  Need RM reference here ???
+
+               Atype := Nearest_Ancestor (E);
+
+               if Present (Atype) and then Has_Predicates (Atype) then
+                  Freeze_And_Append (Atype, N, Result);
+               end if;
+
+               --  Freeze base type before freezing the entity (RM 13.14(15))
+
+               if E /= Base_Type (E) then
+                  Freeze_And_Append (Base_Type (E), N, Result);
+               end if;
             end if;
 
          --  For a derived type, freeze its parent type first (RM 13.14(15))
Index: exp_ch13.adb
===================================================================
--- exp_ch13.adb	(revision 165804)
+++ exp_ch13.adb	(working copy)
@@ -152,7 +152,7 @@  package body Exp_Ch13 is
             if Opt.List_Inherited_Aspects then
                Error_Msg_Sloc := Sloc (Predicate_Function (T));
                Error_Msg_Node_2 := T;
-               Error_Msg_N ("?info: & inherits predicate from & at #", Typ);
+               Error_Msg_N ("?info: & inherits predicate from & #", Typ);
             end if;
          end if;
       end Add_Call;
@@ -272,21 +272,13 @@  package body Exp_Ch13 is
 
       Add_Predicates;
 
-      --  Deal with ancestor subtype and parent type
+      --  Add predicates for ancestor if present
 
       declare
-         Atyp : constant Entity_Id := Ancestor_Subtype (Typ);
-
+         Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
       begin
-         --  If ancestor subtype present, add its predicates
-
          if Present (Atyp) then
             Add_Call (Atyp);
-
-         --  Else if this is derived, add predicates of parent type
-
-         elsif Is_Derived_Type (Typ) then
-            Add_Call (Etype (Base_Type (Typ)));
          end if;
       end;