Patchwork [Ada] Handling of predicate type errors in generics

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 22, 2010, 2:36 p.m.
Message ID <20101022143600.GA19392@adacore.com>
Download mbox | patch
Permalink /patch/68864/
State New
Headers show

Comments

Arnaud Charlet - Oct. 22, 2010, 2:36 p.m.
All errors in generics where improper use of generic actuals that
have predicates should generate program error exceptions and
warnings rather than errors. The following is updated output
from a test that includes these cases (compiled with -gnata12
-gnatj60 -gnatld7).

     1. procedure Bad_Predicates is
     2.    -- This test should get compile-time errors
     3.
     4.    type Color is
     5.      (Red, Orange, Yellow, Green,
     6.       Blue, Indigo, Violet);
     7.    subtype RGB is Color with
     8.      Predicate =>
     9.        RGB = Red or RGB in Green .. Blue;
    10.    subtype Other_Color is Color with
    11.      Predicate => Other_Color not in RGB;
    12.
    13.    subtype Another_Color is Other_Color;
                   |
        >>> info: "Another_Color" inherits predicate from
            "Other_Color" at line 10

    14.
    15.    type Bad_Array is array
    16.      (Another_Color range <>) of Character;
              |
        >>> subtype "Another_Color" has predicate, not
            allowed as index subtype

    17.    --  ERROR: Subtype with predicate not
    18.    --         allowed as index subtype
    19.
    20.    type OK_Array is array
    21.      (Color range <>) of Character;
    22.
    23.    subtype Bad_Array_Subtype is
    24.      OK_Array (Another_Color);
                       |
        >>> subtype "Another_Color" has predicate, not
            allowed in index constraint

    25.    --  ERROR: Subtype with predicate not
    26.    --         allowed in index_constraint
    27.
    28.    OK : constant OK_Array := (Color => 'x');
    29.
    30.    Bad_Slice : constant OK_Array :=
    31.                  OK (Another_Color);
                             |
        >>> subtype "Another_Color" has predicate, not
            allowed in slice

    32.    --  ERROR: Subtype with predicate not
    33.    --         allowed in slice
    34.
    35.    protected type Prot is
    36.       entry Bad_Family
    37.               (Another_Color) (X : Integer);
                       |
        >>> subtype "Another_Color" has predicate, not
            allowed in entry family

    38.       --  ERROR: Subtype with predicate not
    39.       --         allowed in entry family
    40.    end Prot;
    41.
    42.    protected body Prot is
    43.       entry Bad_Family (for J in Another_Color)
    44.         (X : Integer)
    45.          when True
    46.       is
    47.       begin null; end;
    48.    end Prot;
    49.
    50.    --  Same set of checks in a generic
    51.
    52.    generic
    53.       type Another_Color is (<>);
    54.    package T is
    55.       type Bad_Array is array
    56.         (Another_Color range <>) of Character;
    57.       --  ERROR: Subtype with predicate not
    58.       --         allowed as index subtype
    59.
    60.       subtype Bad_Array_Subtype is
    61.         Bad_Array (Another_Color);
    62.       --  ERROR: Subtype with predicate not
    63.       --         allowed in index_constraint
    64.
    65.       protected type Prot is
    66.          entry Bad_Family
    67.            (Another_Color) (X : Integer);
    68.          --  ERROR: Subtype with predicate not
    69.          --         allowed in entry family
    70.       end Prot;
    71.    end T;
    72.
    73.    package body T is
    74.       protected body Prot is
    75.          entry Bad_Family (for J in Another_Color)
    76.            (X : Integer)
    77.          when True
    78.          is
    79.          begin null; end;
    80.       end Prot;
    81.    end;
    82.
    83.    package TT is new T (Another_Color);
           |
        >>> warning: in instantiation at line 56, subtype
            "Another_Color" has predicate, not allowed as
            index subtype, Program_Error will be raised at
            run time
        >>> warning: in instantiation at line 61, subtype
            "Another_Color" has predicate, not allowed in
            index constraint, Program_Error will be raised
            at run time
        >>> warning: in instantiation at line 67, subtype
            "Another_Color" has predicate, not allowed in
            entry family, Program_Error will be raised at
            run time

    84.
    85. begin
    86.    null;
    87. end Bad_Predicates;

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

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

	* sem_case.adb, sem_attr.adb (Bad_Predicated_Subtype_Use): Change order
	of parameters.
	* sem_ch13.adb (Build_Predicate_Function): Don't give inheritance
	messages for generic actual subtypes.
	* sem_ch9.adb, sem_res.adb, sem_util.adb, sem_util.ads, sem_ch3.adb
	(Bad_Predicated_Subtype_Use): Use this procedure.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165828)
+++ sem_ch3.adb	(working copy)
@@ -4429,11 +4429,9 @@  package body Sem_Ch3 is
 
          --  Check error of subtype with predicate for index type
 
-         if Has_Predicates (Etype (Index)) then
-            Error_Msg_NE
-              ("subtype& has predicate, not allowed as index subtype",
-               Index, Etype (Index));
-         end if;
+         Bad_Predicated_Subtype_Use
+           ("subtype& has predicate, not allowed as index subtype",
+            Index, Etype (Index));
 
          --  Move to next index
 
@@ -11402,9 +11400,9 @@  package body Sem_Ch3 is
 
             --  Check error of subtype with predicate in index constraint
 
-            elsif Has_Predicates (Entity (S)) then
-               Error_Msg_NE
-                 ("subtype& has predicate, not allowed in index consraint",
+            else
+               Bad_Predicated_Subtype_Use
+                 ("subtype& has predicate, not allowed in index constraint",
                   S, Entity (S));
             end if;
 
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb	(revision 165805)
+++ sem_ch9.adb	(working copy)
@@ -894,11 +894,9 @@  package body Sem_Ch9 is
 
          --  Check subtype with predicate in entry family
 
-         if Has_Predicates (Etype (D_Sdef)) then
-            Error_Msg_NE
-              ("subtype& has predicate, not allowed in entry family",
-               D_Sdef, Etype (D_Sdef));
-         end if;
+         Bad_Predicated_Subtype_Use
+           ("subtype& has predicate, not allowed in entry family",
+            D_Sdef, Etype (D_Sdef));
       end if;
 
       --  Decorate Def_Id
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 165828)
+++ sem_util.adb	(working copy)
@@ -334,21 +334,21 @@  package body Sem_Util is
    --------------------------------
 
    procedure Bad_Predicated_Subtype_Use
-     (Typ : Entity_Id;
+     (Msg : String;
       N   : Node_Id;
-      Msg : String)
+      Typ : Entity_Id)
    is
    begin
       if Has_Predicates (Typ) then
          if Is_Generic_Actual_Type (Typ) then
-            Error_Msg_F (Msg & '?', Typ);
-            Error_Msg_F ("\Program_Error will be raised at run time?", Typ);
+            Error_Msg_FE (Msg & '?', N, Typ);
+            Error_Msg_F ("\Program_Error will be raised at run time?", N);
             Insert_Action (N,
               Make_Raise_Program_Error (Sloc (N),
                 Reason => PE_Bad_Predicated_Generic_Type));
 
          else
-            Error_Msg_F (Msg, Typ);
+            Error_Msg_FE (Msg, N, Typ);
          end if;
       end if;
    end Bad_Predicated_Subtype_Use;
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 165828)
+++ sem_util.ads	(working copy)
@@ -94,18 +94,19 @@  package Sem_Util is
    --  whether an error or warning is given.
 
    procedure Bad_Predicated_Subtype_Use
-     (Typ : Entity_Id;
+     (Msg : String;
       N   : Node_Id;
-      Msg : String);
+      Typ : Entity_Id);
    --  This is called when Typ, a predicated subtype, is used in a context
-   --  which does not allow the use of a predicated subtype. Msg will be
-   --  passed to Error_Msg_F to output an appropriate message. The caller
-   --  should set up any insertions other than the & for the type itself.
-   --  Note that if Typ is a generic actual type, then the message will be
-   --  output as a warning, and a raise Program_Error is inserted using
-   --  Insert_Action with node N as the insertion point. Node N also supplies
-   --  the source location for construction of the raise node. If Typ is NOT a
-   --  type with predicates this call has no effect.
+   --  which does not allow the use of a predicated subtype. Msg is passed
+   --  to Error_Msg_FE to output an appropriate message using N as the
+   --  location, and Typ as the entity. The caller must set up any insertions
+   --  other than the & for the type itself. Note that if Typ is a generic
+   --  actual type, then the message will be output as a warning, and a
+   --  raise Program_Error is inserted using Insert_Action with node N as
+   --  the insertion point. Node N also supplies the source location for
+   --  construction of the raise node. If Typ is NOT a type with predicates
+   --  this call has no effect.
 
    function Build_Actual_Subtype
      (T : Entity_Id;
Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 165805)
+++ sem_res.adb	(working copy)
@@ -8481,7 +8481,7 @@  package body Sem_Res is
       --  Check bad use of type with predicates
 
       if Has_Predicates (Etype (Drange)) then
-         Error_Msg_NE
+         Bad_Predicated_Subtype_Use
            ("subtype& has predicate, not allowed in slice",
             Drange, Etype (Drange));
 
Index: sem_attr.adb
===================================================================
--- sem_attr.adb	(revision 165828)
+++ sem_attr.adb	(working copy)
@@ -842,7 +842,7 @@  package body Sem_Attr is
          if Comes_From_Source (N) then
             Error_Msg_Name_1 := Aname;
             Bad_Predicated_Subtype_Use
-              (P_Type, N, "type& has predicates, attribute % not allowed");
+              ("type& has predicates, attribute % not allowed", N, P_Type);
          end if;
       end Bad_Attribute_For_Predicate;
 
Index: sem_case.adb
===================================================================
--- sem_case.adb	(revision 165828)
+++ sem_case.adb	(working copy)
@@ -866,9 +866,8 @@  package body Sem_Case is
                              or else No (Static_Predicate (E))
                            then
                               Bad_Predicated_Subtype_Use
-                                (E, N,
-                                 "cannot use subtype&  with non-static "
-                                 & "predicate as case alternative");
+                                ("cannot use subtype&  with non-static "
+                                 & "predicate as case alternative", N, E);
 
                               --  Static predicate case
 
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165828)
+++ sem_ch13.adb	(working copy)
@@ -3888,9 +3888,13 @@  package body Sem_Ch13 is
                    Right_Opnd => Exp);
             end if;
 
-            --  Output info message on inheritance if required
+            --  Output info message on inheritance if required. Note we do not
+            --  give this information for generic actual types, since it is
+            --  unwelcome noise in that case in instantiations.
 
-            if Opt.List_Inherited_Aspects then
+            if Opt.List_Inherited_Aspects
+              and then not Is_Generic_Actual_Type (Typ)
+            then
                Error_Msg_Sloc := Sloc (Predicate_Function (T));
                Error_Msg_Node_2 := T;
                Error_Msg_N ("?info: & inherits predicate from & #", Typ);
@@ -4087,9 +4091,10 @@  package body Sem_Ch13 is
 
             function Hi_Val (N : Node_Id) return Uint is
             begin
-               if Nkind (N) = N_Identifier then
+               if Is_Static_Expression (N) then
                   return Expr_Value (N);
                else
+                  pragma Assert (Nkind (N) = N_Range);
                   return Expr_Value (High_Bound (N));
                end if;
             end Hi_Val;
@@ -4100,9 +4105,10 @@  package body Sem_Ch13 is
 
             function Lo_Val (N : Node_Id) return Uint is
             begin
-               if Nkind (N) = N_Identifier then
+               if Is_Static_Expression (N) then
                   return Expr_Value (N);
                else
+                  pragma Assert (Nkind (N) = N_Range);
                   return Expr_Value (Low_Bound (N));
                end if;
             end Lo_Val;
@@ -4124,19 +4130,19 @@  package body Sem_Ch13 is
                   SHi := Hi_Val (N);
                end if;
 
-            --  Identifier case
+            --  Static expression case
 
-            else pragma Assert (Nkind (N) = N_Identifier);
+            elsif Is_Static_Expression (N) then
+               SLo := Lo_Val (N);
+               SHi := Hi_Val (N);
 
-               --  Static expression case
+            --  Identifier (other than static expression) case
 
-               if Is_Static_Expression (N) then
-                  SLo := Lo_Val (N);
-                  SHi := Hi_Val (N);
+            else pragma Assert (Nkind (N) = N_Identifier);
 
                --  Type case
 
-               elsif Is_Type (Entity (N)) then
+               if Is_Type (Entity (N)) then
 
                   --  If type has static predicates, process them recursively