From patchwork Fri Oct 22 13:59:41 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 68854 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) by ozlabs.org (Postfix) with SMTP id 3E8CCB7043 for ; Sat, 23 Oct 2010 01:00:34 +1100 (EST) Received: (qmail 19336 invoked by alias); 22 Oct 2010 14:00:09 -0000 Received: (qmail 19010 invoked by uid 22791); 22 Oct 2010 13:59:56 -0000 X-SWARE-Spam-Status: No, hits=-1.6 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (194.98.77.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Fri, 22 Oct 2010 13:59:44 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id B5B35290001; Fri, 22 Oct 2010 15:59:41 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id mkS7Qak7FV98; Fri, 22 Oct 2010 15:59:41 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id 997C1CB01EC; Fri, 22 Oct 2010 15:59:41 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id 78EA1D9BB4; Fri, 22 Oct 2010 15:59:41 +0200 (CEST) Date: Fri, 22 Oct 2010 15:59:41 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Implement static predicates and case statements Message-ID: <20101022135941.GA28782@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org This is a fairly major patch that implements static predicates and allows their use in case statements. A predicate is considered static if it is a membership test with all static alternatives in range of the static range of the subtype, and no other predicates are inherited. The following shows static predicates used in case statements (compiled with -gnatj60 -gnatld7 -gnata12) 1. procedure Static_Predicates is 2. type a is (B, C, D, E, F, G, H, I, J, K, L, M, N); 3. subtype s1 is a with 4. Predicate => S1 in C | J | E .. F; 5. subtype s2 is a with 6. Predicate => S2 in L .. N | S1 | D | L .. M; 7. 8. V1 : s1; 9. V2 : s2; 10. 11. begin 12. case V1 is 13. when B => null; 14. when D => null; 15. when G .. I => null; 16. when K .. N => null; 17. when S1 => null; 18. end case; 19. 20. case V2 is -- I missing | >>> missing case value: "I" 21. when B => null; 22. when S2 => null; 23. when G .. H => null; 24. when J .. K => null; -- duplicates J | >>> duplication of choice value at line 22 25. end case; 26. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-22 Robert Dewar * a-except-2005.adb (Rmsg_18): New message text. * a-except.adb (Rmsg_18): New message text. * atree.adb (List25): New function (Set_List25): New procedure * atree.ads (List25): New function (Set_List25): New procedure * einfo.adb (Static_Predicate): Is now a list (OK_To_Reference): Present in all entities * einfo.ads (Static_Predicate): Is now a list (OK_To_Reference): Applies to all entities * exp_ch13.adb (Build_Predicate_Function): Moved to Sem_Ch13 * sem_attr.adb (Bad_Attribute_For_Predicate): Call Bad_Predicated_Subtype_Use. * sem_case.ads, sem_case.adb: Major surgery to deal with predicated subtype case. * sem_ch13.adb (Build_Predicate_Function): Moved from Exp_Ch13 to Sem_Ch13. (Build_Static_Predicate): New procedure handles static predicates. * sem_ch3.adb (Analyze_Subtype_Declaration): Delay freeze on subtype with no constraint if ancestor subtype has predicates. (Analyze_Variant_Part): New calling sequence for Analyze_Choices * sem_ch4.adb (Junk_Operand): Don't complain about OK_To_Reference entity. (Analyze_Case_Expression): New calling sequence for Analyze_Choices * sem_ch5.adb (Analyze_Case_Statement): New calling sequence for Analyze_Choices. * sem_util.ads, sem_util.adb (Bad_Predicated_Subtype_Use): New procedure * types.ads (PE_Bad_Predicated_Generic_Type): Replaces PE_Bad_Attribute_For_Predicate. * atree.h: Add definition of List25. Index: a-except-2005.adb =================================================================== --- a-except-2005.adb (revision 165822) +++ a-except-2005.adb (working copy) @@ -588,8 +588,8 @@ package body Ada.Exceptions is Rmsg_16 : constant String := "attempt to take address of" & " intrinsic subprogram" & NUL; Rmsg_17 : constant String := "all guards closed" & NUL; - Rmsg_18 : constant String := "attribute not allowed for " & - " generic subtype with predicate" & NUL; + Rmsg_18 : constant String := "improper use of generic subtype" & + " with predicate" & NUL; Rmsg_19 : constant String := "Current_Task referenced in entry" & " body" & NUL; Rmsg_20 : constant String := "duplicated entry address" & NUL; Index: a-except.adb =================================================================== --- a-except.adb (revision 165822) +++ a-except.adb (working copy) @@ -520,8 +520,8 @@ package body Ada.Exceptions is Rmsg_16 : constant String := "attempt to take address of" & " intrinsic subprogram" & NUL; Rmsg_17 : constant String := "all guards closed" & NUL; - Rmsg_18 : constant String := "attribute not allowed for " & - " generic subtype with predicate" & NUL; + Rmsg_18 : constant String := "improper use of generic subtype" & + " with predicate" & NUL; Rmsg_19 : constant String := "Current_Task referenced in entry" & " body" & NUL; Rmsg_20 : constant String := "duplicated entry address" & NUL; Index: atree.adb =================================================================== --- atree.adb (revision 165803) +++ atree.adb (working copy) @@ -2400,6 +2400,12 @@ package body Atree is return List_Id (Nodes.Table (N + 2).Field7); end List14; + function List25 (N : Node_Id) return List_Id is + begin + pragma Assert (Nkind (N) in N_Entity); + return List_Id (Nodes.Table (N + 4).Field7); + end List25; + function Elist1 (N : Node_Id) return Elist_Id is pragma Assert (N <= Nodes.Last); Value : constant Union_Id := Nodes.Table (N).Field1; @@ -4657,6 +4663,12 @@ package body Atree is Nodes.Table (N + 2).Field7 := Union_Id (Val); end Set_List14; + procedure Set_List25 (N : Node_Id; Val : List_Id) is + begin + pragma Assert (Nkind (N) in N_Entity); + Nodes.Table (N + 4).Field7 := Union_Id (Val); + end Set_List25; + procedure Set_Elist1 (N : Node_Id; Val : Elist_Id) is begin Nodes.Table (N).Field1 := Union_Id (Val); Index: atree.ads =================================================================== --- atree.ads (revision 165804) +++ atree.ads (working copy) @@ -1096,6 +1096,9 @@ package Atree is function List14 (N : Node_Id) return List_Id; pragma Inline (List14); + function List25 (N : Node_Id) return List_Id; + pragma Inline (List25); + function Elist1 (N : Node_Id) return Elist_Id; pragma Inline (Elist1); @@ -2159,6 +2162,9 @@ package Atree is procedure Set_List14 (N : Node_Id; Val : List_Id); pragma Inline (Set_List14); + procedure Set_List25 (N : Node_Id; Val : List_Id); + pragma Inline (Set_List25); + procedure Set_Elist1 (N : Node_Id; Val : Elist_Id); pragma Inline (Set_Elist1); Index: atree.h =================================================================== --- atree.h (revision 165803) +++ atree.h (working copy) @@ -421,6 +421,7 @@ extern Node_Id Current_Error_Node; #define List5(N) Field5 (N) #define List10(N) Field10 (N) #define List14(N) Field14 (N) +#define List25(N) Field25 (N) #define Elist1(N) Field1 (N) #define Elist2(N) Field2 (N) Index: einfo.adb =================================================================== --- einfo.adb (revision 165822) +++ einfo.adb (working copy) @@ -215,7 +215,7 @@ package body Einfo is -- Debug_Renaming_Link Node25 -- DT_Offset_To_Top_Func Node25 -- PPC_Wrapper Node25 - -- Static_Predicate Node25 + -- Static_Predicate List25 -- Task_Body_Procedure Node25 -- Dispatch_Table_Wrappers Elist26 @@ -2316,7 +2316,6 @@ package body Einfo is function OK_To_Reference (Id : E) return B is begin - pragma Assert (Is_Type (Id)); return Flag249 (Id); end OK_To_Reference; @@ -2621,10 +2620,10 @@ package body Einfo is return Node24 (Id); end Spec_PPC_List; - function Static_Predicate (Id : E) return N is + function Static_Predicate (Id : E) return S is begin pragma Assert (Is_Discrete_Type (Id)); - return Node25 (Id); + return List25 (Id); end Static_Predicate; function Storage_Size_Variable (Id : E) return E is @@ -4811,7 +4810,6 @@ package body Einfo is procedure Set_OK_To_Reference (Id : E; V : B := True) is begin - pragma Assert (Is_Type (Id)); Set_Flag249 (Id, V); end Set_OK_To_Reference; @@ -5127,14 +5125,14 @@ package body Einfo is Set_Node24 (Id, V); end Set_Spec_PPC_List; - procedure Set_Static_Predicate (Id : E; V : N) is + procedure Set_Static_Predicate (Id : E; V : S) is begin pragma Assert (Ekind_In (Id, E_Enumeration_Subtype, E_Modular_Integer_Subtype, E_Signed_Integer_Subtype) and then Has_Predicates (Id)); - Set_Node25 (Id, V); + Set_List25 (Id, V); end Set_Static_Predicate; procedure Set_Storage_Size_Variable (Id : E; V : E) is Index: einfo.ads =================================================================== --- einfo.ads (revision 165822) +++ einfo.ads (working copy) @@ -3152,10 +3152,10 @@ package Einfo is -- formals as a value of type Pos. -- OK_To_Reference (Flag249) --- Present in all entities for types and subtypes. If set it indicates --- that a naked reference to the type is permitted within an expression --- that is being analyzed or preanalyed (for example, a type name may --- be referenced within the Invariant aspect expression for the type). +-- Present in all entities. If set it indicates that a naked reference to +-- the entity is permitted within an expression that is being preanalyzed +-- (for example, a type name may be referenced within the Invariant +-- or Predicate aspect expression for a type). -- OK_To_Rename (Flag247) -- Present only in entities for variables. If this flag is set, it @@ -3609,11 +3609,14 @@ package Einfo is -- textual appearance. Note that this includes precondition/postcondition -- pragmas generated to correspond to Pre/Post aspects. --- Static_Predicate (Node25) +-- Static_Predicate (List25) -- Present in discrete types/subtypes with predicates (Has_Predicates --- set True). Set for a subtype that has a predicate that is considered --- static. Points to the fully analyzed predicate expression, which is --- always a membership test (possibly a set membership). +-- set True). Points to a list of expression and N_Range nodes that +-- represent the predicate in canonical form. The canonical form has +-- entries sorted in ascending order, with all duplicates eliminated, +-- and adjacent ranges coalesced, so that there is always a gap in the +-- values between successive entries. The entries in this list are +-- fully analyzed. -- Storage_Size_Variable (Node15) [implementation base type only] -- Present in access types and task type entities. This flag is set @@ -4735,6 +4738,7 @@ package Einfo is -- Needs_Debug_Info (Flag147) -- Never_Set_In_Source (Flag115) -- No_Return (Flag113) + -- OK_To_Reference (Flag249) -- Overlays_Constant (Flag243) -- Referenced (Flag156) -- Referenced_As_LHS (Flag36) @@ -4817,7 +4821,6 @@ package Einfo is -- Known_To_Have_Preelab_Init (Flag207) -- Must_Be_On_Byte_Boundary (Flag183) -- Must_Have_Preelab_Init (Flag208) - -- OK_To_Reference (Flag249) -- Optimize_Alignment_Space (Flag241) -- Optimize_Alignment_Time (Flag242) -- Size_Depends_On_Discriminant (Flag177) @@ -5073,7 +5076,7 @@ package Einfo is -- First_Literal (Node17) -- Scalar_Range (Node20) -- Enum_Pos_To_Rep (Node23) (type only) - -- Static_Predicate (Node25) + -- Static_Predicate (List25) -- Has_Biased_Representation (Flag139) -- Has_Contiguous_Rep (Flag181) -- Has_Enumeration_Rep_Clause (Flag66) @@ -5275,7 +5278,7 @@ package Einfo is -- Modulus (Uint17) (base type only) -- Original_Array_Type (Node21) -- Scalar_Range (Node20) - -- Static_Predicate (Node25) + -- Static_Predicate (List25) -- Non_Binary_Modulus (Flag58) (base type only) -- Has_Biased_Representation (Flag139) -- Type_Low_Bound (synth) @@ -5545,7 +5548,7 @@ package Einfo is -- E_Signed_Integer_Type -- E_Signed_Integer_Subtype -- Scalar_Range (Node20) - -- Static_Predicate (Node25) + -- Static_Predicate (List25) -- Has_Biased_Representation (Flag139) -- Type_Low_Bound (synth) -- Type_High_Bound (synth) @@ -6241,7 +6244,7 @@ package Einfo is function Small_Value (Id : E) return R; function Spec_Entity (Id : E) return E; function Spec_PPC_List (Id : E) return N; - function Static_Predicate (Id : E) return N; + function Static_Predicate (Id : E) return S; function Storage_Size_Variable (Id : E) return E; function Static_Elaboration_Desired (Id : E) return B; function Static_Initialization (Id : E) return N; @@ -6829,7 +6832,7 @@ package Einfo is procedure Set_Small_Value (Id : E; V : R); procedure Set_Spec_Entity (Id : E; V : E); procedure Set_Spec_PPC_List (Id : E; V : N); - procedure Set_Static_Predicate (Id : E; V : N); + procedure Set_Static_Predicate (Id : E; V : S); procedure Set_Storage_Size_Variable (Id : E; V : E); procedure Set_Static_Elaboration_Desired (Id : E; V : B); procedure Set_Static_Initialization (Id : E; V : N); Index: exp_ch13.adb =================================================================== --- exp_ch13.adb (revision 165822) +++ exp_ch13.adb (working copy) @@ -26,8 +26,6 @@ with Atree; use Atree; with Checks; use Checks; with Einfo; use Einfo; -with Elists; use Elists; -with Errout; use Errout; with Exp_Ch3; use Exp_Ch3; with Exp_Ch6; use Exp_Ch6; with Exp_Imgv; use Exp_Imgv; @@ -39,8 +37,6 @@ with Nmake; use Nmake; with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; -with Sem_Aux; use Sem_Aux; -with Sem_Ch3; use Sem_Ch3; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Eval; use Sem_Eval; @@ -54,313 +50,6 @@ with Validsw; use Validsw; package body Exp_Ch13 is - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Build_Predicate_Function - (Typ : Entity_Id; - FDecl : out Node_Id; - FBody : out Node_Id); - -- If Typ has predicates (indicated by Has_Predicates being set for Typ, - -- then either there are pragma Invariant entries on the rep chain for the - -- type (note that Predicate aspects are converted to pragam Predicate), or - -- there are inherited aspects from a parent type, or ancestor subtypes, - -- or interfaces. This procedure builds the spec and body for the Predicate - -- function that tests these predicates, returning them in PDecl and Pbody - -- and setting Predicate_Procedure for Typ. In some error situations no - -- procedure is built, in which case PDecl/PBody are empty on return. - - ------------------------------ - -- Build_Predicate_Function -- - ------------------------------ - - -- The procedure that is constructed here has the form - - -- function typPredicate (Ixxx : typ) return Boolean is - -- begin - -- return - -- exp1 and then exp2 and then ... - -- and then typ1Predicate (typ1 (Ixxx)) - -- and then typ2Predicate (typ2 (Ixxx)) - -- and then ...; - -- end typPredicate; - - -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that - -- this is the point at which these expressions get analyzed, providing the - -- required delay, and typ1, typ2, are entities from which predicates are - -- inherited. Note that we do NOT generate Check pragmas, that's because we - -- use this function even if checks are off, e.g. for membership tests. - - procedure Build_Predicate_Function - (Typ : Entity_Id; - FDecl : out Node_Id; - FBody : out Node_Id) - is - Loc : constant Source_Ptr := Sloc (Typ); - Spec : Node_Id; - SId : Entity_Id; - - Expr : Node_Id; - -- This is the expression for the return statement in the function. It - -- is build by connecting the component predicates with AND THEN. - - procedure Add_Call (T : Entity_Id); - -- Includes a call to the predicate function for type T in Expr if T - -- has predicates and Predicate_Function (T) is non-empty. - - procedure Add_Predicates; - -- Appends expressions for any Predicate pragmas in the rep item chain - -- Typ to Expr. Note that we look only at items for this exact entity. - -- Inheritance of predicates for the parent type is done by calling the - -- Predicate_Function of the parent type, using Add_Call above. - - Object_Name : constant Name_Id := New_Internal_Name ('I'); - -- Name for argument of Predicate procedure - - -------------- - -- Add_Call -- - -------------- - - procedure Add_Call (T : Entity_Id) is - Exp : Node_Id; - - begin - if Present (T) and then Present (Predicate_Function (T)) then - Set_Has_Predicates (Typ); - - -- Build the call to the predicate function of T - - Exp := - Make_Predicate_Call - (T, - Convert_To (T, - Make_Identifier (Loc, Chars => Object_Name))); - - -- Add call to evolving expression, using AND THEN if needed - - if No (Expr) then - Expr := Exp; - else - Expr := - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (Expr), - Right_Opnd => Exp); - end if; - - -- Output info message on inheritance if required - - 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 & #", Typ); - end if; - end if; - end Add_Call; - - -------------------- - -- Add_Predicates -- - -------------------- - - procedure Add_Predicates is - Ritem : Node_Id; - Arg1 : Node_Id; - Arg2 : Node_Id; - - function Replace_Node (N : Node_Id) return Traverse_Result; - -- Process single node for traversal to replace type references - - procedure Replace_Type is new Traverse_Proc (Replace_Node); - -- Traverse an expression changing every occurrence of an entity - -- reference to type T with a reference to the object argument. - - ------------------ - -- Replace_Node -- - ------------------ - - function Replace_Node (N : Node_Id) return Traverse_Result is - begin - -- Case of entity name referencing the type - - if Is_Entity_Name (N) and then Entity (N) = Typ then - - -- Replace with object - - Rewrite (N, - Make_Identifier (Loc, - Chars => Object_Name)); - - -- All done with this node - - return Skip; - - -- Not an occurrence of the type entity, keep going - - else - return OK; - end if; - end Replace_Node; - - -- Start of processing for Add_Predicates - - begin - Ritem := First_Rep_Item (Typ); - while Present (Ritem) loop - if Nkind (Ritem) = N_Pragma - and then Pragma_Name (Ritem) = Name_Predicate - then - Arg1 := First (Pragma_Argument_Associations (Ritem)); - Arg2 := Next (Arg1); - - Arg1 := Get_Pragma_Arg (Arg1); - Arg2 := Get_Pragma_Arg (Arg2); - - -- See if this predicate pragma is for the current type - - if Entity (Arg1) = Typ then - - -- We have a match, this entry is for our subtype - - -- First We need to replace any occurrences of the name of - -- the type with references to the object. We do this by - -- first doing a preanalysis, to identify all the entities, - -- then we traverse looking for the type entity, doing the - -- needed substitution. The preanalysis is done with the - -- special OK_To_Reference flag set on the type, so that if - -- we get an occurrence of this type, it will be recognized - -- as legitimate. - - Set_OK_To_Reference (Typ, True); - Preanalyze_Spec_Expression (Arg2, Standard_Boolean); - Set_OK_To_Reference (Typ, False); - Replace_Type (Arg2); - - -- OK, replacement complete, now we can add the expression - - if No (Expr) then - Expr := Relocate_Node (Arg2); - else - Expr := - Make_And_Then (Loc, - Left_Opnd => Relocate_Node (Expr), - Right_Opnd => Relocate_Node (Arg2)); - end if; - end if; - end if; - - Next_Rep_Item (Ritem); - end loop; - end Add_Predicates; - - -- Start of processing for Build_Predicate_Function - - begin - -- Initialize for construction of statement list - - Expr := Empty; - FDecl := Empty; - FBody := Empty; - - -- Return if already built or if type does not have predicates - - if not Has_Predicates (Typ) - or else Present (Predicate_Function (Typ)) - then - return; - end if; - - -- Add Predicates for the current type - - Add_Predicates; - - -- Add predicates for ancestor if present - - declare - Atyp : constant Entity_Id := Nearest_Ancestor (Typ); - begin - if Present (Atyp) then - Add_Call (Atyp); - end if; - end; - - -- Add predicates of any interfaces of a tagged type - - if Is_Tagged_Type (Typ) then - declare - Iface_List : Elist_Id; - Elmt : Elmt_Id; - - begin - Collect_Interfaces (Typ, Iface_List); - - if Present (Iface_List) then - loop - Elmt := First_Elmt (Iface_List); - exit when No (Elmt); - - Add_Call (Node (Elmt)); - Remove_Elmt (Iface_List, Elmt); - end loop; - end if; - end; - end if; - - if Present (Expr) then - - -- Build function declaration - - pragma Assert (Has_Predicates (Typ)); - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - Set_Has_Predicates (SId); - Set_Predicate_Function (Typ, SId); - - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars => Object_Name), - Parameter_Type => New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FDecl := - Make_Subprogram_Declaration (Loc, - Specification => Spec); - - -- Build function body - - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); - - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => SId, - Parameter_Specifications => New_List ( - Make_Parameter_Specification (Loc, - Defining_Identifier => - Make_Defining_Identifier (Loc, Chars => Object_Name), - Parameter_Type => - New_Occurrence_Of (Typ, Loc))), - Result_Definition => - New_Occurrence_Of (Standard_Boolean, Loc)); - - FBody := - Make_Subprogram_Body (Loc, - Specification => Spec, - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Simple_Return_Statement (Loc, - Expression => Expr)))); - end if; - end Build_Predicate_Function; - ------------------------------------------ -- Expand_N_Attribute_Definition_Clause -- ------------------------------------------ @@ -725,24 +414,6 @@ package body Exp_Ch13 is Rewrite (N, Make_Null_Statement (Sloc (N))); end if; - -- If freezing a type entity which has predicates, this is where we - -- build and insert the predicate function for the type. - - if Is_Type (E) and then Has_Predicates (E) then - declare - FDecl : Node_Id; - FBody : Node_Id; - - begin - Build_Predicate_Function (E, FDecl, FBody); - - if Present (FDecl) then - Insert_After (N, FBody); - Insert_After (N, FDecl); - end if; - end; - end if; - -- Pop scope if we installed one for the analysis if In_Other_Scope then Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 165822) +++ sem_attr.adb (working copy) @@ -215,7 +215,8 @@ package body Sem_Attr is -- Output error message for use of a predicate (First, Last, Range) not -- allowed with a type that has predicates. If the type is a generic -- actual, then the message is a warning, and we generate code to raise - -- program error with an appropriate reason. + -- program error with an appropriate reason. No error message is given + -- for internally generated uses of the attributes. procedure Check_Array_Or_Scalar_Type; -- Common procedure used by First, Last, Range attribute to check @@ -838,23 +839,10 @@ package body Sem_Attr is procedure Bad_Attribute_For_Predicate is begin - if Has_Predicates (P_Type) then + if Comes_From_Source (N) then Error_Msg_Name_1 := Aname; - - if Is_Generic_Actual_Type (P_Type) then - Error_Msg_F - ("type& has predicates, attribute % not allowed?", P); - Error_Msg_F - ("\?Program_Error will be raised at run time", P); - Rewrite (N, - Make_Raise_Program_Error (Loc, - Reason => PE_Bad_Attribute_For_Predicate)); - - else - Error_Msg_F - ("type& has predicates, attribute % not allowed", P); - Error_Attr; - end if; + Bad_Predicated_Subtype_Use + (P_Type, N, "type& has predicates, attribute % not allowed"); end if; end Bad_Attribute_For_Predicate; Index: sem_case.adb =================================================================== --- sem_case.adb (revision 165803) +++ sem_case.adb (working copy) @@ -32,7 +32,6 @@ with Nmake; use Nmake; with Opt; use Opt; with Sem; use Sem; with Sem_Aux; use Sem_Aux; -with Sem_Case; use Sem_Case; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; @@ -43,23 +42,31 @@ with Sinfo; use Sinfo; with Tbuild; use Tbuild; with Uintp; use Uintp; +with Ada.Unchecked_Deallocation; + with GNAT.Heap_Sort_G; package body Sem_Case is + type Choice_Bounds is record + Lo : Node_Id; + Hi : Node_Id; + Node : Node_Id; + end record; + -- Represent one choice bounds entry with Lo and Hi values, Node points + -- to the choice node itself. + + type Choice_Table_Type is array (Nat range <>) of Choice_Bounds; + -- Table type used to sort the choices present in a case statement, array + -- aggregate or record variant. The actual entries are stored in 1 .. Last, + -- but we have a 0 entry for convenience in sorting. + ----------------------- -- Local Subprograms -- ----------------------- - type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds; - -- This new array type is used as the actual table type for sorting - -- discrete choices. The reason for not using Choice_Table_Type, is that - -- in Sort_Choice_Table_Type we reserve entry 0 for the sorting algorithm - -- (this is not absolutely necessary but it makes the code more - -- efficient). - procedure Check_Choices - (Choice_Table : in out Sort_Choice_Table_Type; + (Choice_Table : in out Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; Others_Present : Boolean; @@ -101,7 +108,7 @@ package body Sem_Case is ------------------- procedure Check_Choices - (Choice_Table : in out Sort_Choice_Table_Type; + (Choice_Table : in out Choice_Table_Type; Bounds_Type : Entity_Id; Subtyp : Entity_Id; Others_Present : Boolean; @@ -321,7 +328,9 @@ package body Sem_Case is Issue_Msg (Prev_Hi + 1, Lo - 1); end if; - Prev_Hi := Hi; + if Hi > Prev_Hi then + Prev_Hi := Hi; + end if; end loop; if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then @@ -511,7 +520,7 @@ package body Sem_Case is -- Start of processing for Expand_Others_Choice begin - if Case_Table'Length = 0 then + if Case_Table'Last = 0 then -- Special case: only an others case is present. -- The others case covers the full range of the type. @@ -537,9 +546,9 @@ package body Sem_Case is Exp_Hi := Type_High_Bound (Base_Type (Choice_Type)); end if; - Lo := Expr_Value (Case_Table (Case_Table'First).Lo); - Hi := Expr_Value (Case_Table (Case_Table'First).Hi); - Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi); + Lo := Expr_Value (Case_Table (1).Lo); + Hi := Expr_Value (Case_Table (1).Hi); + Previous_Hi := Expr_Value (Case_Table (1).Hi); -- Build the node for any missing choices that are smaller than any -- explicit choices given in the case. @@ -551,7 +560,7 @@ package body Sem_Case is -- Build the nodes representing any missing choices that lie between -- the explicit ones given in the case. - for J in Case_Table'First + 1 .. Case_Table'Last loop + for J in 2 .. Case_Table'Last loop Lo := Expr_Value (Case_Table (J).Lo); Hi := Expr_Value (Case_Table (J).Hi); @@ -588,7 +597,6 @@ package body Sem_Case is procedure No_OP (C : Node_Id) is pragma Warnings (Off, C); - begin null; end No_OP; @@ -599,6 +607,19 @@ package body Sem_Case is package body Generic_Choices_Processing is + -- The following type is used to gather the entries for the choice + -- table, so that we can then allocate the right length. + + type Link; + type Link_Ptr is access all Link; + + type Link is record + Val : Choice_Bounds; + Nxt : Link_Ptr; + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr); + --------------------- -- Analyze_Choices -- --------------------- @@ -606,20 +627,19 @@ package body Sem_Case is procedure Analyze_Choices (N : Node_Id; Subtyp : Entity_Id; - Choice_Table : out Choice_Table_Type; - Last_Choice : out Nat; Raises_CE : out Boolean; Others_Present : out Boolean) is - pragma Assert (Choice_Table'First = 1); - E : Entity_Id; Enode : Node_Id; -- This is where we post error messages for bounds out of range - Nb_Choices : constant Nat := Choice_Table'Length; - Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices); + Choice_List : Link_Ptr := null; + -- Gather list of choices + + Num_Choices : Nat := 0; + -- Number of entries in Choice_List Choice_Type : constant Entity_Id := Base_Type (Subtyp); -- The actual type against which the discrete choices are resolved. @@ -648,13 +668,17 @@ package body Sem_Case is Kind : Node_Kind; -- The node kind of the current Choice + Delete_Choice : Boolean; + -- Set to True to delete the current choice + Others_Choice : Node_Id := Empty; -- Remember others choice if it is present (empty otherwise) procedure Check (Choice : Node_Id; Lo, Hi : Node_Id); -- Checks the validity of the bounds of a choice. When the bounds - -- are static and no error occurred the bounds are entered into the - -- choices table so that they can be sorted later on. + -- are static and no error occurred the bounds are collected for + -- later entry into the choices table so that they can be sorted + -- later on. ----------- -- Check -- @@ -706,8 +730,7 @@ package body Sem_Case is -- If the choice is an entity name, then it is a type, and we -- want to post the message on the reference to this entity. - -- Otherwise we want to post it on the lower bound of the - -- range. + -- Otherwise post it on the lower bound of the range. if Is_Entity_Name (Choice) then Enode := Choice; @@ -751,22 +774,20 @@ package body Sem_Case is end if; end if; - -- Store bounds in the table + -- Collect bounds in the list -- Note: we still store the bounds, even if they are out of range, -- since this may prevent unnecessary cascaded errors for values -- that are covered by such an excessive range. - Last_Choice := Last_Choice + 1; - Sort_Choice_Table (Last_Choice).Lo := Lo; - Sort_Choice_Table (Last_Choice).Hi := Hi; - Sort_Choice_Table (Last_Choice).Node := Choice; + Choice_List := + new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List); + Num_Choices := Num_Choices + 1; end Check; -- Start of processing for Analyze_Choices begin - Last_Choice := 0; Raises_CE := False; Others_Present := False; @@ -811,6 +832,7 @@ package body Sem_Case is else Choice := First (Get_Choices (Alt)); while Present (Choice) loop + Delete_Choice := False; Analyze (Choice); Kind := Nkind (Choice); @@ -834,7 +856,45 @@ package body Sem_Case is else E := Entity (Choice); - if not Is_Static_Subtype (E) then + -- Case of predicated subtype + + if Has_Predicates (E) then + + -- Use of non-static predicate is an error + + if not Is_Discrete_Type (E) + or else No (Static_Predicate (E)) + then + Bad_Predicated_Subtype_Use + (E, N, + "cannot use subtype& with non-static " + & "predicate as case alternative"); + + -- Static predicate case + + else + declare + Copy : constant List_Id := Empty_List; + P : Node_Id; + C : Node_Id; + + begin + P := First (Static_Predicate (E)); + while Present (P) loop + C := New_Copy (P); + Set_Sloc (C, Sloc (Choice)); + Append_To (Copy, C); + Next (P); + end loop; + + Insert_List_After (Choice, Copy); + Delete_Choice := True; + end; + end if; + + -- Not predicated subtype case + + elsif not Is_Static_Subtype (E) then Process_Non_Static_Choice (Choice); else Check @@ -848,6 +908,8 @@ package body Sem_Case is Resolve_Discrete_Subtype_Indication (Choice, Expected_Type); + -- Here for other than predicated subtype case + if Etype (Choice) /= Any_Type then declare C : constant Node_Id := Constraint (Choice); @@ -911,7 +973,18 @@ package body Sem_Case is Check (Choice, Choice, Choice); end if; - Next (Choice); + -- Move to next choice, deleting the current one if the + -- flag requesting this deletion is set True. + + declare + C : constant Node_Id := Choice; + begin + Next (Choice); + + if Delete_Choice then + Remove (C); + end if; + end; end loop; Process_Associated_Node (Alt); @@ -920,65 +993,47 @@ package body Sem_Case is Next (Alt); end loop; - Check_Choices - (Sort_Choice_Table (0 .. Last_Choice), - Bounds_Type, - Subtyp, - Others_Present or else (Choice_Type = Universal_Integer), - N); - - -- Now copy the sorted discrete choices - - for J in 1 .. Last_Choice loop - Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J); - end loop; - - -- If no others choice we are all done, otherwise we have one more - -- step, which is to set the Others_Discrete_Choices field of the - -- others choice (to contain all otherwise unspecified choices). - -- Skip this if CE is known to be raised. - - if Others_Present and not Raises_CE then - Expand_Others_Choice - (Case_Table => Choice_Table (1 .. Last_Choice), - Others_Choice => Others_Choice, - Choice_Type => Bounds_Type); - end if; - end Analyze_Choices; - - ----------------------- - -- Number_Of_Choices -- - ----------------------- - - function Number_Of_Choices (N : Node_Id) return Nat is - Alt : Node_Id; - -- A case statement alternative or a record variant - - Choice : Node_Id; - Count : Nat := 0; - - begin - if No (Get_Alternatives (N)) then - return 0; - end if; - - Alt := First_Non_Pragma (Get_Alternatives (N)); - while Present (Alt) loop + -- Now we can create the Choice_Table, since we know how long + -- it needs to be so we can allocate exactly the right length. - Choice := First (Get_Choices (Alt)); - while Present (Choice) loop - if Nkind (Choice) /= N_Others_Choice then - Count := Count + 1; - end if; + declare + Choice_Table : Choice_Table_Type (0 .. Num_Choices); - Next (Choice); - end loop; + begin + -- Now copy the items we collected in the linked list into this + -- newly allocated table (leave entry 0 unused for sorting). - Next_Non_Pragma (Alt); - end loop; + declare + T : Link_Ptr; + begin + for J in 1 .. Num_Choices loop + T := Choice_List; + Choice_List := T.Nxt; + Choice_Table (J) := T.Val; + Free (T); + end loop; + end; - return Count; - end Number_Of_Choices; + Check_Choices + (Choice_Table, + Bounds_Type, + Subtyp, + Others_Present or else (Choice_Type = Universal_Integer), + N); + + -- If no others choice we are all done, otherwise we have one more + -- step, which is to set the Others_Discrete_Choices field of the + -- others choice (to contain all otherwise unspecified choices). + -- Skip this if CE is known to be raised. + + if Others_Present and not Raises_CE then + Expand_Others_Choice + (Case_Table => Choice_Table, + Others_Choice => Others_Choice, + Choice_Type => Bounds_Type); + end if; + end; + end Analyze_Choices; end Generic_Choices_Processing; Index: sem_case.ads =================================================================== --- sem_case.ads (revision 165803) +++ sem_case.ads (working copy) @@ -34,16 +34,6 @@ with Types; use Types; package Sem_Case is - type Choice_Bounds is record - Lo : Node_Id; - Hi : Node_Id; - Node : Node_Id; - end record; - - type Choice_Table_Type is array (Pos range <>) of Choice_Bounds; - -- Table type used to sort the choices present in a case statement, - -- array aggregate or record variant. - procedure No_OP (C : Node_Id); -- The no-operation routine. Does absolutely nothing. Can be used -- in the following generic for the parameter Process_Empty_Choice. @@ -75,16 +65,9 @@ package Sem_Case is package Generic_Choices_Processing is - function Number_Of_Choices (N : Node_Id) return Nat; - -- Iterates through the choices of N, (N can be a case expression, case - -- statement, array aggregate or record variant), counting all the - -- Choice nodes except for the Others choice. - procedure Analyze_Choices (N : Node_Id; Subtyp : Entity_Id; - Choice_Table : out Choice_Table_Type; - Last_Choice : out Nat; Raises_CE : out Boolean; Others_Present : out Boolean); -- From a case expression, case statement, array aggregate or record @@ -92,23 +75,6 @@ package Sem_Case is -- choices. Subtyp is the subtype of the discrete choices. The type -- against which the discrete choices must be resolved is its base type. -- - -- On entry Choice_Table must be big enough to contain all the discrete - -- choices encountered. The lower bound of Choice_Table must be one. - -- - -- On exit Choice_Table contains all the static and non empty discrete - -- choices in sorted order. Last_Choice gives the position of the last - -- valid choice in Choice_Table, Choice_Table'First contains the first. - -- We can have Last_Choice < Choice_Table'Last for one (or several) of - -- the following reasons: - -- - -- (a) The list of choices contained a non static choice - -- - -- (b) The list of choices contained an empty choice - -- (something like "1 .. 0 => ") - -- - -- (c) One of the bounds of a discrete choice contains an - -- error or raises constraint error. - -- -- In one of the bounds of a discrete choice raises a constraint -- error the flag Raise_CE is set. -- Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 165804) +++ sem_ch13.adb (working copy) @@ -77,6 +77,23 @@ package body Sem_Ch13 is -- inherited from a derived type that is no longer appropriate for the -- new Esize value. In this case, we reset the Alignment to unknown. + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Build_Predicate_Function + (Typ : Entity_Id; + FDecl : out Node_Id; + FBody : out Node_Id); + -- If Typ has predicates (indicated by Has_Predicates being set for Typ, + -- then either there are pragma Invariant entries on the rep chain for the + -- type (note that Predicate aspects are converted to pragam Predicate), or + -- there are inherited aspects from a parent type, or ancestor subtypes, + -- or interfaces. This procedure builds the spec and body for the Predicate + -- function that tests these predicates, returning them in PDecl and Pbody + -- and setting Predicate_Procedure for Typ. In some error situations no + -- procedure is built, in which case PDecl/PBody are empty on return. + function Get_Alignment_Value (Expr : Node_Id) return Uint; -- Given the expression for an alignment value, returns the corresponding -- Uint value. If the value is inappropriate, then error messages are @@ -3038,6 +3055,23 @@ package body Sem_Ch13 is end if; Inside_Freezing_Actions := Inside_Freezing_Actions - 1; + + -- If we have a type with predicates, build predicate function + + if Is_Type (E) and then Has_Predicates (E) then + declare + FDecl : Node_Id; + FBody : Node_Id; + + begin + Build_Predicate_Function (E, FDecl, FBody); + + if Present (FDecl) then + Insert_After (N, FBody); + Insert_After (N, FDecl); + end if; + end; + end if; end Analyze_Freeze_Entity; ------------------------------------------ @@ -3773,6 +3807,605 @@ package body Sem_Ch13 is end if; end Build_Invariant_Procedure; + ------------------------------ + -- Build_Predicate_Function -- + ------------------------------ + + -- The procedure that is constructed here has the form + + -- function typPredicate (Ixxx : typ) return Boolean is + -- begin + -- return + -- exp1 and then exp2 and then ... + -- and then typ1Predicate (typ1 (Ixxx)) + -- and then typ2Predicate (typ2 (Ixxx)) + -- and then ...; + -- end typPredicate; + + -- Here exp1, and exp2 are expressions from Predicate pragmas. Note that + -- this is the point at which these expressions get analyzed, providing the + -- required delay, and typ1, typ2, are entities from which predicates are + -- inherited. Note that we do NOT generate Check pragmas, that's because we + -- use this function even if checks are off, e.g. for membership tests. + + procedure Build_Predicate_Function + (Typ : Entity_Id; + FDecl : out Node_Id; + FBody : out Node_Id) + is + Loc : constant Source_Ptr := Sloc (Typ); + Spec : Node_Id; + SId : Entity_Id; + + Expr : Node_Id; + -- This is the expression for the return statement in the function. It + -- is build by connecting the component predicates with AND THEN. + + procedure Add_Call (T : Entity_Id); + -- Includes a call to the predicate function for type T in Expr if T + -- has predicates and Predicate_Function (T) is non-empty. + + procedure Add_Predicates; + -- Appends expressions for any Predicate pragmas in the rep item chain + -- Typ to Expr. Note that we look only at items for this exact entity. + -- Inheritance of predicates for the parent type is done by calling the + -- Predicate_Function of the parent type, using Add_Call above. + + procedure Build_Static_Predicate; + -- This function is called to process a static predicate, and put it in + -- canonical form and store it in Static_Predicate (Typ). + + Object_Name : constant Name_Id := New_Internal_Name ('I'); + -- Name for argument of Predicate procedure + + -------------- + -- Add_Call -- + -------------- + + procedure Add_Call (T : Entity_Id) is + Exp : Node_Id; + + begin + if Present (T) and then Present (Predicate_Function (T)) then + Set_Has_Predicates (Typ); + + -- Build the call to the predicate function of T + + Exp := + Make_Predicate_Call + (T, + Convert_To (T, + Make_Identifier (Loc, Chars => Object_Name))); + + -- Add call to evolving expression, using AND THEN if needed + + if No (Expr) then + Expr := Exp; + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Exp); + end if; + + -- Output info message on inheritance if required + + 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 & #", Typ); + end if; + end if; + end Add_Call; + + -------------------- + -- Add_Predicates -- + -------------------- + + procedure Add_Predicates is + Ritem : Node_Id; + Arg1 : Node_Id; + Arg2 : Node_Id; + + function Replace_Node (N : Node_Id) return Traverse_Result; + -- Process single node for traversal to replace type references + + procedure Replace_Type is new Traverse_Proc (Replace_Node); + -- Traverse an expression changing every occurrence of an entity + -- reference to type T with a reference to the object argument. + + ------------------ + -- Replace_Node -- + ------------------ + + function Replace_Node (N : Node_Id) return Traverse_Result is + begin + -- Case of entity name referencing the type + + if Is_Entity_Name (N) and then Entity (N) = Typ then + + -- Replace with object + + Rewrite (N, + Make_Identifier (Loc, + Chars => Object_Name)); + + -- All done with this node + + return Skip; + + -- Not an occurrence of the type entity, keep going + + else + return OK; + end if; + end Replace_Node; + + -- Start of processing for Add_Predicates + + begin + Ritem := First_Rep_Item (Typ); + while Present (Ritem) loop + if Nkind (Ritem) = N_Pragma + and then Pragma_Name (Ritem) = Name_Predicate + then + Arg1 := First (Pragma_Argument_Associations (Ritem)); + Arg2 := Next (Arg1); + + Arg1 := Get_Pragma_Arg (Arg1); + Arg2 := Get_Pragma_Arg (Arg2); + + -- See if this predicate pragma is for the current type + + if Entity (Arg1) = Typ then + + -- We have a match, this entry is for our subtype + + -- First We need to replace any occurrences of the name of + -- the type with references to the object. We do this by + -- first doing a preanalysis, to identify all the entities, + -- then we traverse looking for the type entity, doing the + -- needed substitution. The preanalysis is done with the + -- special OK_To_Reference flag set on the type, so that if + -- we get an occurrence of this type, it will be recognized + -- as legitimate. + + Set_OK_To_Reference (Typ, True); + Preanalyze_Spec_Expression (Arg2, Standard_Boolean); + Set_OK_To_Reference (Typ, False); + Replace_Type (Arg2); + + -- OK, replacement complete, now we can add the expression + + if No (Expr) then + Expr := Relocate_Node (Arg2); + + -- There already was a predicate, so add to it + + else + Expr := + Make_And_Then (Loc, + Left_Opnd => Relocate_Node (Expr), + Right_Opnd => Relocate_Node (Arg2)); + end if; + end if; + end if; + + Next_Rep_Item (Ritem); + end loop; + end Add_Predicates; + + ---------------------------- + -- Build_Static_Predicate -- + ---------------------------- + + procedure Build_Static_Predicate is + Exp : Node_Id; + Alt : Node_Id; + + Non_Static : Boolean := False; + -- Set True if something non-static is found + + Plist : List_Id := No_List; + -- The entries in Plist are either static expressions which represent + -- a possible value, or ranges of values. Subtype marks don't appear, + -- since we expand them out. + + Lo, Hi : Uint; + -- Low bound and high bound values of static subtype of Typ + + procedure Process_Entry (N : Node_Id); + -- Process one entry (range or value or subtype mark) + + ------------------- + -- Process_Entry -- + ------------------- + + procedure Process_Entry (N : Node_Id) is + SLo, SHi : Uint; + -- Low and high bounds of range in list + + P : Node_Id; + + function Build_Val (V : Uint) return Node_Id; + -- Return an analyzed N_Identifier node referencing this value + + function Build_Range (Lo, Hi : Uint) return Node_Id; + -- Return an analyzed N_Range node referencing this range + + function Lo_Val (N : Node_Id) return Uint; + -- Given static expression or static range, gets expression value + -- or low bound of range. + + function Hi_Val (N : Node_Id) return Uint; + -- Given static expression or static range, gets expression value + -- of high bound of range. + + ----------------- + -- Build_Range -- + ----------------- + + function Build_Range (Lo, Hi : Uint) return Node_Id is + Result : Node_Id; + begin + if Lo = Hi then + return Build_Val (Hi); + else + Result := + Make_Range (Sloc (N), + Low_Bound => Build_Val (Lo), + High_Bound => Build_Val (Hi)); + Set_Etype (Result, Typ); + Set_Analyzed (Result); + return Result; + end if; + end Build_Range; + + --------------- + -- Build_Val -- + --------------- + + function Build_Val (V : Uint) return Node_Id is + Result : Node_Id; + + begin + if Is_Enumeration_Type (Typ) then + Result := Get_Enum_Lit_From_Pos (Typ, V, Sloc (N)); + else + Result := Make_Integer_Literal (Sloc (N), Intval => V); + end if; + + Set_Etype (Result, Typ); + Set_Is_Static_Expression (Result); + Set_Analyzed (Result); + return Result; + end Build_Val; + + ------------ + -- Hi_Val -- + ------------ + + function Hi_Val (N : Node_Id) return Uint is + begin + if Nkind (N) = N_Identifier then + return Expr_Value (N); + else + return Expr_Value (High_Bound (N)); + end if; + end Hi_Val; + + ------------ + -- Lo_Val -- + ------------ + + function Lo_Val (N : Node_Id) return Uint is + begin + if Nkind (N) = N_Identifier then + return Expr_Value (N); + else + return Expr_Value (Low_Bound (N)); + end if; + end Lo_Val; + + -- Start of processing for Process_Entry + + begin + -- Range case + + if Nkind (N) = N_Range then + if not Is_Static_Expression (Low_Bound (N)) + or else + not Is_Static_Expression (High_Bound (N)) + then + Non_Static := True; + return; + else + SLo := Lo_Val (N); + SHi := Hi_Val (N); + end if; + + -- Identifier case + + else pragma Assert (Nkind (N) = N_Identifier); + + -- Static expression case + + if Is_Static_Expression (N) then + SLo := Lo_Val (N); + SHi := Hi_Val (N); + + -- Type case + + elsif Is_Type (Entity (N)) then + + -- If type has static predicates, process them recursively + + if Present (Static_Predicate (Entity (N))) then + P := First (Static_Predicate (Entity (N))); + while Present (P) loop + Process_Entry (P); + + if Non_Static then + return; + else + Next (P); + end if; + end loop; + + return; + + -- For static subtype without predicates, get range + + elsif Is_Static_Subtype (Entity (N)) + and then not Has_Predicates (Entity (N)) + then + SLo := Expr_Value (Type_Low_Bound (Entity (N))); + SHi := Expr_Value (Type_High_Bound (Entity (N))); + + -- Any other type makes us non-static + + else + Non_Static := True; + return; + end if; + + -- Any other kind of identifier in predicate (e.g. a non-static + -- expression value) means this is not a static predicate. + + else + Non_Static := True; + return; + end if; + end if; + + -- Here with SLo and SHi set for (possibly single element) range + -- of entry to insert in Plist. Non-static if out of range. + + if SLo < Lo or else SHi > Hi then + Non_Static := True; + return; + end if; + + -- If no Plist currently, create it + + if No (Plist) then + Plist := New_List (Build_Range (SLo, SHi)); + return; + + -- Otherwise search Plist for insertion point + + else + P := First (Plist); + loop + -- Case of inserting before current entry + + if SHi < Lo_Val (P) - 1 then + Insert_Before (P, Build_Range (SLo, SHi)); + exit; + + -- Case of belongs past current entry + + elsif SLo > Hi_Val (P) + 1 then + + -- End of list case + + if No (Next (P)) then + Append_To (Plist, Build_Range (SLo, SHi)); + exit; + + -- Else just move to next item on list + + else + Next (P); + end if; + + -- Case of extending current entyr, and in overlap cases + -- may also eat up entries past this one. + + else + declare + New_Lo : constant Uint := UI_Min (Lo_Val (P), SLo); + New_Hi : Uint := UI_Max (Hi_Val (P), SHi); + + begin + -- See if there are entries past us that we eat up + + while Present (Next (P)) + and then Lo_Val (Next (P)) <= New_Hi + 1 + loop + New_Hi := Hi_Val (Next (P)); + Remove (Next (P)); + end loop; + + -- We now need to replace the current node P with + -- a new entry New_Lo .. New_Hi. + + Insert_After (P, Build_Range (New_Lo, New_Hi)); + Remove (P); + exit; + end; + end if; + end loop; + end if; + end Process_Entry; + + -- Start of processing for Build_Static_Predicate + + begin + -- Immediately non-static if our subtype is non static, or we + -- do not have an appropriate discrete subtype in the first place. + + if not Ekind_In (Typ, E_Enumeration_Subtype, + E_Modular_Integer_Subtype, + E_Signed_Integer_Subtype) + or else not Is_Static_Subtype (Typ) + then + return; + end if; + + Lo := Expr_Value (Type_Low_Bound (Typ)); + Hi := Expr_Value (Type_High_Bound (Typ)); + + -- Check if we have membership predicate + + if Nkind (Expr) = N_In then + Exp := Expr; + + -- Allow qualified expression with membership predicate inside + + elsif Nkind (Expr) = N_Qualified_Expression + and then Nkind (Expression (Expr)) = N_In + then + Exp := Expression (Expr); + + -- Anything else cannot be a static predicate + + else + return; + end if; + + -- We have a membership operation, so we have a potentially static + -- predicate, collect and canonicalize the entries in the list. + + if Present (Right_Opnd (Exp)) then + Process_Entry (Right_Opnd (Exp)); + + if Non_Static then + return; + end if; + + else + Alt := First (Alternatives (Exp)); + while Present (Alt) loop + Process_Entry (Alt); + + if Non_Static then + return; + end if; + + Next (Alt); + end loop; + end if; + + -- Processing was successful and all entries were static, so + -- now we can store the result as the predicate list. + + Set_Static_Predicate (Typ, Plist); + end Build_Static_Predicate; + + -- Start of processing for Build_Predicate_Function + + begin + -- Initialize for construction of statement list + + Expr := Empty; + FDecl := Empty; + FBody := Empty; + + -- Return if already built or if type does not have predicates + + if not Has_Predicates (Typ) + or else Present (Predicate_Function (Typ)) + then + return; + end if; + + -- Add Predicates for the current type + + Add_Predicates; + + -- Add predicates for ancestor if present + + declare + Atyp : constant Entity_Id := Nearest_Ancestor (Typ); + begin + if Present (Atyp) then + Add_Call (Atyp); + end if; + end; + + -- If we have predicates, build the function + + if Present (Expr) then + + -- Deal with static predicate case + + Build_Static_Predicate; + + -- Build function declaration + + pragma Assert (Has_Predicates (Typ)); + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + Set_Has_Predicates (SId); + Set_Predicate_Function (Typ, SId); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars => Object_Name), + Parameter_Type => New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FDecl := + Make_Subprogram_Declaration (Loc, + Specification => Spec); + + -- Build function body + + SId := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Typ), "Predicate")); + + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => SId, + Parameter_Specifications => New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars => Object_Name), + Parameter_Type => + New_Occurrence_Of (Typ, Loc))), + Result_Definition => + New_Occurrence_Of (Standard_Boolean, Loc)); + + FBody := + Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List ( + Make_Simple_Return_Statement (Loc, + Expression => Expr)))); + end if; + end Build_Predicate_Function; + ----------------------------------- -- Check_Constant_Address_Clause -- ----------------------------------- Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 165819) +++ sem_ch3.adb (working copy) @@ -3842,7 +3842,14 @@ package body Sem_Ch3 is Set_Is_Ada_2005_Only (Id, Is_Ada_2005_Only (T)); Set_Is_Ada_2012_Only (Id, Is_Ada_2012_Only (T)); Set_Convention (Id, Convention (T)); - Set_Has_Predicates (Id, Has_Predicates (T)); + + -- If ancestor has predicates then so does the subtype, and in addition + -- we must delay the freeze to properly arrange predicate inheritance. + + if Has_Predicates (T) then + Set_Has_Predicates (Id); + Set_Has_Delayed_Freeze (Id); + end if; -- In the case where there is no constraint given in the subtype -- indication, Process_Subtype just returns the Subtype_Mark, so its @@ -4292,13 +4299,9 @@ package body Sem_Ch3 is Discr_Name : Node_Id; Discr_Type : Entity_Id; - Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N)); - Last_Choice : Nat; Dont_Care : Boolean; Others_Present : Boolean := False; - pragma Warnings (Off, Case_Table); - pragma Warnings (Off, Last_Choice); pragma Warnings (Off, Dont_Care); pragma Warnings (Off, Others_Present); -- We don't care about the assigned values of any of these @@ -4332,8 +4335,7 @@ package body Sem_Ch3 is -- Call the instantiated Analyze_Choices which does the rest of the work - Analyze_Choices - (N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present); + Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present); end Analyze_Variant_Part; ---------------------------- Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 165826) +++ sem_ch4.adb (working copy) @@ -1137,7 +1137,6 @@ package body Sem_Ch4 is Exp_Type : Entity_Id; Exp_Btype : Entity_Id; - Last_Choice : Nat; Dont_Care : Boolean; Others_Present : Boolean; @@ -1154,8 +1153,6 @@ package body Sem_Ch4 is Process_Associated_Node => No_OP); use Case_Choices_Processing; - Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N)); - ----------------------------- -- Non_Static_Choice_Error -- ----------------------------- @@ -1252,8 +1249,7 @@ package body Sem_Ch4 is -- Call instantiated Analyze_Choices which does the rest of the work - Analyze_Choices - (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present); + Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N @@ -5563,6 +5559,13 @@ package body Sem_Ch4 is return False; end if; + -- If OK_To_Reference is set for the entity, then don't complain, it + -- means we are doing a preanalysis in which such complaints are wrong. + + if OK_To_Reference (Entity (Enode)) then + return False; + end if; + -- Now test the entity we got to see if it is a bad case case Ekind (Entity (Enode)) is Index: sem_ch5.adb =================================================================== --- sem_ch5.adb (revision 165827) +++ sem_ch5.adb (working copy) @@ -1018,12 +1018,6 @@ package body Sem_Ch5 is Analyze_Statements (Statements (Alternative)); end Process_Statements; - -- Table to record choices. Put after subprograms since we make - -- a call to Number_Of_Choices to get the right number of entries. - - Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N)); - pragma Warnings (Off, Case_Table); - -- Start of processing for Analyze_Case_Statement begin @@ -1096,8 +1090,7 @@ package body Sem_Ch5 is -- Call instantiated Analyze_Choices which does the rest of the work - Analyze_Choices - (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present); + Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present); if Exp_Type = Universal_Integer and then not Others_Present then Error_Msg_N ("case on universal integer requires OTHERS choice", Exp); Index: sem_util.adb =================================================================== --- sem_util.adb (revision 165817) +++ sem_util.adb (working copy) @@ -329,6 +329,30 @@ package body Sem_Util is end if; end Apply_Compile_Time_Constraint_Error; + -------------------------------- + -- Bad_Predicated_Subtype_Use -- + -------------------------------- + + procedure Bad_Predicated_Subtype_Use + (Typ : Entity_Id; + N : Node_Id; + Msg : String) + 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); + Insert_Action (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Bad_Predicated_Generic_Type)); + + else + Error_Msg_F (Msg, Typ); + end if; + end if; + end Bad_Predicated_Subtype_Use; + -------------------------- -- Build_Actual_Subtype -- -------------------------- Index: sem_util.ads =================================================================== --- sem_util.ads (revision 165827) +++ sem_util.ads (working copy) @@ -93,6 +93,20 @@ package Sem_Util is -- not end with a ? (this is used when the caller wants to parameterize -- whether an error or warning is given. + procedure Bad_Predicated_Subtype_Use + (Typ : Entity_Id; + N : Node_Id; + Msg : String); + -- 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. + function Build_Actual_Subtype (T : Entity_Id; N : Node_Or_Entity_Id) return Node_Id; Index: types.ads =================================================================== --- types.ads (revision 165822) +++ types.ads (working copy) @@ -789,7 +789,7 @@ package Types is PE_Accessibility_Check_Failed, -- 15 PE_Address_Of_Intrinsic, -- 16 PE_All_Guards_Closed, -- 17 - PE_Bad_Attribute_For_Predicate, -- 18 + PE_Bad_Predicated_Generic_Type, -- 18 PE_Current_Task_In_Entry_Body, -- 19 PE_Duplicated_Entry_Address, -- 20 PE_Explicit_Raise, -- 21