From patchwork Mon Oct 25 13:51:17 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 69100 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 46DD1B6F14 for ; Tue, 26 Oct 2010 00:52:19 +1100 (EST) Received: (qmail 14100 invoked by alias); 25 Oct 2010 13:52:13 -0000 Received: (qmail 13425 invoked by uid 22791); 25 Oct 2010 13:51:52 -0000 X-SWARE-Spam-Status: No, hits=-0.2 required=5.0 tests=AWL, BAYES_50, 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; Mon, 25 Oct 2010 13:51:21 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 02080CB02AE; Mon, 25 Oct 2010 15:51:18 +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 8rCqtV0cSflE; Mon, 25 Oct 2010 15:51:17 +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 D8F17CB02A4; Mon, 25 Oct 2010 15:51:17 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id BA515D9BB5; Mon, 25 Oct 2010 15:51:17 +0200 (CEST) Date: Mon, 25 Oct 2010 15:51:17 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Implement more general predicates Message-ID: <20101025135117.GA719@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 rewrite of handling of static predicates allows much more general predicate forms, including inheritance of static predicates, comparisons with static values, IN, NOT IN, and the use of AND/OR/NOT to join conditions to create more complex static predicates. The following program compiled with -gnat12 shows some of the new capabilities (all capabilities are there, not all have been tested yet) 1. with Text_IO; use Text_IO; 2. procedure Predicate_Loops is 3. type Int is range 1 .. 10; 4. 5. subtype P2 is Int with 6. predicate => P2 > 6; 7. 8. subtype P3 is Int with 9. predicate => ((P3 > 6) and P3 < 9); 10. 11. subtype P4 is Int with 12. predicate => (P4 in P2) and P4 < 10; 13. 14. subtype P5 is Int with 15. predicate => P5 < 3 or P5 > 8; 16. 17. begin 18. for J in P2 loop 19. Put_Line ("P2:" & J'Img); 20. end loop; 21. 22. for J in P3 loop 23. Put_Line ("P3:" & J'Img); 24. end loop; 25. 26. for J in P4 loop 27. Put_Line ("P4:" & J'Img); 28. end loop; 29. 30. for J in P5 loop 31. Put_Line ("P5:" & J'Img); 32. end loop; 33. end Predicate_Loops; The output is: P2: 7 P2: 8 P2: 9 P2: 10 P3: 7 P3: 8 P4: 7 P4: 8 P4: 9 P5: 1 P5: 2 P5: 9 P5: 10 Tested on x86_64-pc-linux-gnu, committed on trunk 2010-10-25 Robert Dewar * sem_ch13.adb (Build_Static_Predicate): Moved out of Build_Predicate_Function. (Build_Static_Predicate): Complet rewrite for more general predicates Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 165916) +++ sem_ch13.adb (working copy) @@ -77,10 +77,6 @@ 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; @@ -94,6 +90,21 @@ package body Sem_Ch13 is -- and setting Predicate_Procedure for Typ. In some error situations no -- procedure is built, in which case PDecl/PBody are empty on return. + procedure Build_Static_Predicate + (Typ : Entity_Id; + Expr : Node_Id; + Nam : Name_Id); + -- Given a predicated type Typ, whose predicate expression is Expr, tests + -- if Expr is a static predicate, and if so, builds the predicate range + -- list. Nam is the name of the argument to the predicate function. + -- Occurrences of the type name in the predicate expression have been + -- replaced by identifer references to this name, which is unique, so any + -- identifier with Chars matching Nam must be a reference to the type. If + -- the predicate is non-static, this procedure returns doing nothing. If + -- the predicate is static, then the corresponding predicate list is stored + -- in Static_Predicate (Typ), and the Expr is rewritten as a canonicalized + -- membership operation. + 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 @@ -3851,10 +3862,6 @@ package body Sem_Ch13 is -- 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 @@ -4001,455 +4008,895 @@ package body Sem_Ch13 is end loop; end Add_Predicates; - ---------------------------- - -- Build_Static_Predicate -- - ---------------------------- + -- Start of processing for Build_Predicate_Function + + begin + -- Initialize for construction of statement list - procedure Build_Static_Predicate is - Exp : Node_Id; - Alt : Node_Id; + 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 (Typ, Expr, Object_Name); + + -- 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)); - Non_Static : Boolean := False; - -- Set True if something non-static is found + 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; + + ---------------------------- + -- Build_Static_Predicate -- + ---------------------------- + + procedure Build_Static_Predicate + (Typ : Entity_Id; + Expr : Node_Id; + Nam : Name_Id) + is + Loc : constant Source_Ptr := Sloc (Expr); - 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. + Non_Static : exception; + -- Raised if something non-static is found + TLo, THi : Uint; + -- Low bound and high bound values of static subtype of Typ + + type REnt is record Lo, Hi : Uint; - -- Low bound and high bound values of static subtype of Typ + end record; + -- One entry in a Rlist value, a single REnt (range entry) value + -- denotes one range from Lo to Hi. To represent a single value + -- range Lo = Hi = value. + + type RList is array (Nat range <>) of REnt; + -- A list of ranges. The ranges are sorted in increasing order, + -- and are disjoint (there is a gap of at least one value between + -- each range in the table). + + Null_Range : constant RList := RList'(1 .. 0 => REnt'(No_Uint, No_Uint)); + True_Range : RList renames Null_Range; + -- Constant representing null list of ranges, used to represent a + -- predicate of True, since there are no ranges to be satisfied. + + False_Range : constant RList := RList'(1 => REnt'(Uint_1, Uint_0)); + -- Range representing false + + function "and" (Left, Right : RList) return RList; + -- And's together two range lists, returning a range list. This is + -- a set intersection operation. + + function "or" (Left, Right : RList) return RList; + -- Or's together two range lists, returning a range list. This is a + -- set union operation. + + function "not" (Right : RList) return RList; + -- Returns complement of a given range list, i.e. a range list + -- representing all the values in TLo .. THi that are not in the + -- input operand Right. + + function Build_Val (V : Uint) return Node_Id; + -- Return an analyzed N_Identifier node referencing this value, suitable + -- for use as an entry in the Static_Predicate list. + + function Build_Range (Lo, Hi : Uint) return Node_Id; + -- Return an analyzed N_Range node referencing this range, suitable + -- for use as an entry in the Static_Predicate list. + + function Get_RList (Exp : Node_Id) return RList; + -- This is a recursive routine that converts the given expression into + -- a list of ranges, suitable for use in building the static predicate. + + function Is_Type_Ref (N : Node_Id) return Boolean; + pragma Inline (Is_Type_Ref); + -- Returns if True if N is a reference to the type for the predicate in + -- the expression (i.e. if it is an identifier whose Chars field matches + -- the Nam given in the call). + + function Lo_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value or low bound of range. + + function Hi_Val (N : Node_Id) return Uint; + -- Given static expression or static range from a Static_Predicate list, + -- gets expression value of high bound of range. + + function Membership_Entry (N : Node_Id) return RList; + -- Given a single membership entry (range, value, or subtype), returns + -- the corresponding range list. Raises Static_Error if not static. + + function Membership_Entries (N : Node_Id) return RList; + -- Given an element on an alternatives list of a membership operation, + -- returns the range list corresponding to this entry and all following + -- entries (i.e. returns the "or" of this list of values). + + function Stat_Pred (Typ : Entity_Id) return RList; + -- Given a type, if it has a static predicate, then return the predicate + -- as a range list, otherwise raise Non_Static. + + ----------- + -- "and" -- + ----------- + + function "and" (Left, Right : RList) return RList is + FEnt : REnt; + -- First range of result - procedure Process_Entry (N : Node_Id); - -- Process one entry (range or value or subtype mark) + SLeft : Nat := Left'First; + -- Start of rest of left entries - ------------------- - -- Process_Entry -- - ------------------- + SRight : Nat := Right'First; + -- Start of rest of right entries - procedure Process_Entry (N : Node_Id) is - SLo, SHi : Uint; - -- Low and high bounds of range in list + begin + -- If either range is True, return the other - P : Node_Id; + if Left = True_Range then + return Right; + elsif Right = True_Range then + return Left; + end if; - function Build_Val (V : Uint) return Node_Id; - -- Return an analyzed N_Identifier node referencing this value + -- If either range is False, return False - function Build_Range (Lo, Hi : Uint) return Node_Id; - -- Return an analyzed N_Range node referencing this range + if Left = False_Range or else Right = False_Range then + return False_Range; + end if; - function Lo_Val (N : Node_Id) return Uint; - -- Given static expression or static range, gets expression value - -- or low bound of range. + -- If either range is empty, return False - function Hi_Val (N : Node_Id) return Uint; - -- Given static expression or static range, gets expression value - -- of high bound of range. + if Left'Length = 0 or else Right'Length = 0 then + return False_Range; + end if; - ----------------- - -- Build_Range -- - ----------------- + -- Loop to remove entries at start that are disjoint, and thus + -- just get discarded from the result entirely. - 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 -- - --------------- + loop + -- If no operands left in either operand, result is false - function Build_Val (V : Uint) return Node_Id is - Result : Node_Id; + if SLeft > Left'Last or else SRight > Right'Last then + return False_Range; - 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; + -- Discard first left operand entry if disjoint with right - Set_Etype (Result, Typ); - Set_Is_Static_Expression (Result); - Set_Analyzed (Result); - return Result; - end Build_Val; + elsif Left (SLeft).Hi < Right (SRight).Lo then + SLeft := SLeft + 1; - ------------ - -- Hi_Val -- - ------------ + -- Discard first right operand entry if disjoint with left - function Hi_Val (N : Node_Id) return Uint is - begin - 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; + elsif Right (SRight).Hi < Left (SLeft).Lo then + SRight := SRight + 1; - ------------ - -- Lo_Val -- - ------------ + -- Otherwise we have an overlapping entry - function Lo_Val (N : Node_Id) return Uint is - begin - 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; + else + exit; + end if; + end loop; + + -- Now we have two non-null operands, and first entries overlap. + -- The first entry in the result will be the overlapping part of + -- these two entries. + + FEnt := REnt'(Lo => UI_Max (Left (SLeft).Lo, Right (SRight).Lo), + Hi => UI_Min (Left (SLeft).Hi, Right (SRight).Hi)); + + -- Now we can remove the entry that ended at a lower value, since + -- its contribution is entirely contained in Fent. + + if Left (SLeft).Hi <= Right (SRight).Hi then + SLeft := SLeft + 1; + else + SRight := SRight + 1; + end if; + + -- If either operand is empty, that's the only entry + + if SLeft > Left'Last or else SRight > Right'Last then + return RList'(1 => FEnt); + + -- Else compute and of remaining entries and concatenate + + else + return + FEnt & + (Left (SLeft .. Left'Last) and Right (SRight .. Right'Last)); + end if; + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" (Right : RList) return RList is + begin + -- Return True if False range + + if Right = False_Range then + return True_Range; + end if; - -- Start of processing for Process_Entry + -- Return False if True range + + if Right'Length = 0 then + return False_Range; + end if; + + -- Here if not trivial case + + declare + Result : RList (1 .. Right'Length + 1); + -- May need one more entry for gap at beginning and end + + Count : Nat := 0; + -- Number of entries stored in Result begin - -- Range case + -- Gap at start - if Nkind (N) = N_Range then - if not Is_Static_Expression (Low_Bound (N)) - or else - not Is_Static_Expression (High_Bound (N)) + if Right (Right'First).Lo > TLo then + Count := Count + 1; + Result (Count) := REnt'(TLo, Right (Right'First).Lo - 1); + end if; + + -- Gaps between ranges + + for J in Right'First .. Right'Last - 1 loop + Count := Count + 1; + Result (Count) := + REnt'(Right (J).Hi + 1, Right (J + 1).Lo - 1); + end loop; + + -- Gap at end + + if Right (Right'Last).Hi < THi then + Count := Count + 1; + Result (Count) := REnt'(Right (Right'Last).Hi + 1, THi); + end if; + + return Result (1 .. Count); + end; + end "not"; + + ---------- + -- "or" -- + ---------- + + function "or" (Left, Right : RList) return RList is + begin + -- If either range is True, return True + + if Left = True_Range or else Right = True_Range then + return True_Range; + end if; + + -- If either range is False, return the other + + if Left = False_Range then + return Right; + elsif Right = False_Range then + return Left; + end if; + + -- If either operand is null, return the other one + + if Left'Length = 0 then + return Right; + elsif Right'Length = 0 then + return Left; + end if; + + -- Now we have two non-null ranges + + declare + FEnt : REnt; + -- First range of result + + SLeft : Nat := Left'First; + -- Start of rest of left entries + + SRight : Nat := Right'First; + -- Start of rest of right entries + + begin + -- Initialize result first entry from left or right operand + -- depending on which starts with the lower range. + + if Left (SLeft).Lo < Right (SRight).Lo then + FEnt := Left (SLeft); + SLeft := SLeft + 1; + else + FEnt := Right (SRight); + SRight := SRight + 1; + end if; + + -- This loop eats ranges from left and right operands that + -- are contiguous with the first range we are gathering. + + loop + -- Eat first entry in left operand if contiguous or + -- overlapped by gathered first operand of result. + + if SLeft <= Left'Last + and then Left (SLeft).Lo <= FEnt.Hi + 1 then - Non_Static := True; - return; + FEnt.Hi := UI_Max (FEnt.Hi, Left (SLeft).Hi); + SLeft := SLeft + 1; + + -- Eat first entry in right operand if contiguous or + -- overlapped by gathered right operand of result. + + elsif SRight <= Right'Last + and then Right (SRight).Lo <= FEnt.Hi + 1 + then + FEnt.Hi := UI_Max (FEnt.Hi, Right (SRight).Hi); + SRight := SRight + 1; + + -- All done if no more entries to eat! + else - SLo := Lo_Val (N); - SHi := Hi_Val (N); + exit; end if; + end loop; - -- Static expression case + -- If left operand now empty, concatenate our new entry to right - elsif Is_Static_Expression (N) then - SLo := Lo_Val (N); - SHi := Hi_Val (N); + if SLeft > Left'Last then + return FEnt & Right (SRight .. Right'Last); - -- Identifier (other than static expression) case + -- If right operand now empty, concatenate our new entry to left - else pragma Assert (Nkind (N) = N_Identifier); + elsif SRight > Right'Last then + return FEnt & Left (SLeft .. Left'Last); - -- Type case + -- Otherwise, compute or of what is left and concatenate - if Is_Type (Entity (N)) then + else + return + FEnt & + (Left (SLeft .. Left'Last) or Right (SRight .. Right'Last)); + end if; + end; + end "or"; - -- If type has static predicates, process them recursively + ----------------- + -- Build_Range -- + ----------------- - if Present (Static_Predicate (Entity (N))) then - P := First (Static_Predicate (Entity (N))); - while Present (P) loop - Process_Entry (P); + 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 (Loc, + 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 -- + --------------- - if Non_Static then - return; - else - Next (P); - end if; - end loop; + function Build_Val (V : Uint) return Node_Id is + Result : Node_Id; - return; + begin + if Is_Enumeration_Type (Typ) then + Result := Get_Enum_Lit_From_Pos (Typ, V, Loc); + else + Result := Make_Integer_Literal (Loc, Intval => V); + end if; - -- For static subtype without predicates, get range + Set_Etype (Result, Typ); + Set_Is_Static_Expression (Result); + Set_Analyzed (Result); + return Result; + end Build_Val; + + --------------- + -- Get_RList -- + --------------- + + function Get_RList (Exp : Node_Id) return RList is + Op : Node_Kind; + Val : Uint; - 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))); + begin + -- Static expression can only be true or false - -- Any other type makes us non-static + if Is_OK_Static_Expression (Exp) then - else - Non_Static := True; - return; - end if; + -- For False, return impossible range, which will always fail + + if Expr_Value (Exp) = 0 then + return False_Range; + + -- For True, null range + + else + return Null_Range; + end if; + end if; + + -- Otherwise test node type - -- Any other kind of identifier in predicate (e.g. a non-static - -- expression value) means this is not a static predicate. + Op := Nkind (Exp); + + case Op is + + -- And + + when N_Op_And | N_And_Then => + return Get_RList (Left_Opnd (Exp)) + and + Get_RList (Right_Opnd (Exp)); + + -- Or + + when N_Op_Or | N_Or_Else => + return Get_RList (Left_Opnd (Exp)) + or + Get_RList (Right_Opnd (Exp)); + + -- Not + + when N_Op_Not => + return not Get_RList (Right_Opnd (Exp)); + + -- Comparisons of type with static value + + when N_Op_Compare => + -- Type is left operand + + if Is_Type_Ref (Left_Opnd (Exp)) + and then Is_OK_Static_Expression (Right_Opnd (Exp)) + then + Val := Expr_Value (Right_Opnd (Exp)); + + -- Typ is right operand + + elsif Is_Type_Ref (Right_Opnd (Exp)) + and then Is_OK_Static_Expression (Left_Opnd (Exp)) + then + Val := Expr_Value (Left_Opnd (Exp)); + + -- Invert sense of comparison + + case Op is + when N_Op_Gt => Op := N_Op_Lt; + when N_Op_Lt => Op := N_Op_Gt; + when N_Op_Ge => Op := N_Op_Le; + when N_Op_Le => Op := N_Op_Ge; + when others => null; + end case; + + -- Other cases are non-static else - Non_Static := True; - return; + raise Non_Static; 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. + -- Construct range according to comparison operation - if SLo < Lo or else SHi > Hi then - Non_Static := True; - return; - end if; + case Op is + when N_Op_Eq => + return RList'(1 => REnt'(Val, Val)); - -- If no Plist currently, create it + when N_Op_Ge => + return RList'(1 => REnt'(Val, THi)); - if No (Plist) then - Plist := New_List (Build_Range (SLo, SHi)); - return; + when N_Op_Gt => + return RList'(1 => REnt'(Val + 1, THi)); - -- Otherwise search Plist for insertion point + when N_Op_Le => + return RList'(1 => REnt'(TLo, Val)); - else - P := First (Plist); - loop - -- Case of inserting before current entry + when N_Op_Lt => + return RList'(1 => REnt'(TLo, Val - 1)); - if SHi < Lo_Val (P) - 1 then - Insert_Before (P, Build_Range (SLo, SHi)); - exit; + when N_Op_Ne => + return RList'(REnt'(TLo, Val - 1), + REnt'(Val + 1, THi)); + + when others => + raise Program_Error; + end case; - -- Case of belongs past current entry + -- Membership (IN) - elsif SLo > Hi_Val (P) + 1 then + when N_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; - -- End of list case + if Present (Right_Opnd (Exp)) then + return Membership_Entry (Right_Opnd (Exp)); + else + return Membership_Entries (First (Alternatives (Exp))); + end if; - if No (Next (P)) then - Append_To (Plist, Build_Range (SLo, SHi)); - exit; + -- Negative membership (NOT IN) - -- Else just move to next item on list + when N_Not_In => + if not Is_Type_Ref (Left_Opnd (Exp)) then + raise Non_Static; + end if; - else - Next (P); + if Present (Right_Opnd (Exp)) then + return not Membership_Entry (Right_Opnd (Exp)); + else + return not Membership_Entries (First (Alternatives (Exp))); + end if; + + -- Function call, may be call to static predicate + + when N_Function_Call => + if Is_Entity_Name (Name (Exp)) then + declare + Ent : constant Entity_Id := Entity (Name (Exp)); + begin + if Has_Predicates (Ent) then + return Stat_Pred (Etype (First_Formal (Ent))); end if; + end; + end if; - -- Case of extending current entyr, and in overlap cases - -- may also eat up entries past this one. + -- Other function call cases are non-static - else - declare - New_Lo : constant Uint := UI_Min (Lo_Val (P), SLo); - New_Hi : Uint := UI_Max (Hi_Val (P), SHi); + raise Non_Static; - begin - -- See if there are entries past us that we eat up + -- Qualified expression, dig out the expression - 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; + when N_Qualified_Expression => + return Get_RList (Expression (Exp)); - -- We now need to replace the current node P with - -- a new entry New_Lo .. New_Hi. + -- Any other node type is non-static - Insert_After (P, Build_Range (New_Lo, New_Hi)); - Remove (P); - exit; - end; - end if; - end loop; - end if; - end Process_Entry; + when others => + raise Non_Static; + end case; + end Get_RList; - -- Start of processing for Build_Static_Predicate + ------------ + -- Hi_Val -- + ------------ + function Hi_Val (N : Node_Id) return Uint is 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; + 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; - Lo := Expr_Value (Type_Low_Bound (Typ)); - Hi := Expr_Value (Type_High_Bound (Typ)); - - -- Check if we have membership predicate + ----------------- + -- Is_Type_Ref -- + ----------------- - if Nkind (Expr) = N_In then - Exp := Expr; + function Is_Type_Ref (N : Node_Id) return Boolean is + begin + return Nkind (N) = N_Identifier and then Chars (N) = Nam; + end Is_Type_Ref; - -- Allow qualified expression with membership predicate inside + ------------ + -- Lo_Val -- + ------------ - elsif Nkind (Expr) = N_Qualified_Expression - and then Nkind (Expression (Expr)) = N_In - then - Exp := Expression (Expr); + function Lo_Val (N : Node_Id) return Uint is + begin + 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; - -- Anything else cannot be a static predicate + ------------------------ + -- Membership_Entries -- + ------------------------ + function Membership_Entries (N : Node_Id) return RList is + begin + if No (Next (N)) then + return Membership_Entry (N); else - return; + return Membership_Entry (N) or Membership_Entries (Next (N)); end if; + end Membership_Entries; - -- We have a membership operation, so we have a potentially static - -- predicate, collect and canonicalize the entries in the list. + ---------------------- + -- Membership_Entry -- + ---------------------- - if Present (Right_Opnd (Exp)) then - Process_Entry (Right_Opnd (Exp)); + function Membership_Entry (N : Node_Id) return RList is + Val : Uint; + SLo : Uint; + SHi : Uint; - if Non_Static then - return; + 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 + raise Non_Static; + else + SLo := Expr_Value (Low_Bound (N)); + SHi := Expr_Value (High_Bound (N)); + return RList'(1 => REnt'(SLo, SHi)); end if; - else - Alt := First (Alternatives (Exp)); - while Present (Alt) loop - Process_Entry (Alt); + -- Static expression case - if Non_Static then - return; - end if; + elsif Is_Static_Expression (N) then + Val := Expr_Value (N); + return RList'(1 => REnt'(Val, Val)); - Next (Alt); - end loop; - end if; + -- Identifier (other than static expression) case - -- Processing was successful and all entries were static, so - -- now we can store the result as the predicate list. + else pragma Assert (Nkind (N) = N_Identifier); - Set_Static_Predicate (Typ, Plist); + -- Type case - -- The processing for static predicates coalesced ranges and also - -- eliminated duplicates. We might as well replace the alternatives - -- list of the right operand of the membership test with the static - -- predicate list, which will be more efficient. + if Is_Type (Entity (N)) then - declare - New_Alts : constant List_Id := New_List; - Old_Node : Node_Id; - New_Node : Node_Id; + -- If type has predicates, process them - begin - Old_Node := First (Plist); - while Present (Old_Node) loop - New_Node := New_Copy (Old_Node); + if Has_Predicates (Entity (N)) then + return Stat_Pred (Entity (N)); - if Nkind (New_Node) = N_Range then - Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); - Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); - end if; + -- For static subtype without predicates, get range - Append_To (New_Alts, New_Node); - Next (Old_Node); - end loop; + elsif Is_Static_Subtype (Entity (N)) then + SLo := Expr_Value (Type_Low_Bound (Entity (N))); + SHi := Expr_Value (Type_High_Bound (Entity (N))); + return RList'(1 => REnt'(SLo, SHi)); - -- Now update the membership test node + -- Any other type makes us non-static - pragma Assert (Nkind (Expr) = N_In); + else + raise Non_Static; + end if; + + -- Any other kind of identifier in predicate (e.g. a non-static + -- expression value) means this is not a static predicate. - if List_Length (New_Alts) = 1 then - Set_Right_Opnd (Expr, First (New_Alts)); - Set_Alternatives (Expr, No_List); else - Set_Alternatives (Expr, New_Alts); - Set_Right_Opnd (Expr, Empty); + raise Non_Static; end if; - end; - end Build_Static_Predicate; + end if; + end Membership_Entry; - -- Start of processing for Build_Predicate_Function + --------------- + -- Stat_Pred -- + --------------- - begin - -- Initialize for construction of statement list + function Stat_Pred (Typ : Entity_Id) return RList is + begin + -- Not static if type does not have static predicates - Expr := Empty; - FDecl := Empty; - FBody := Empty; + if not Has_Predicates (Typ) + or else No (Static_Predicate (Typ)) + then + raise Non_Static; + end if; - -- Return if already built or if type does not have predicates + -- Otherwise we convert the predicate list to a range list - if not Has_Predicates (Typ) - or else Present (Predicate_Function (Typ)) + declare + Result : RList (1 .. List_Length (Static_Predicate (Typ))); + P : Node_Id; + + begin + P := First (Static_Predicate (Typ)); + for J in Result'Range loop + Result (J) := REnt'(Lo_Val (P), Hi_Val (P)); + Next (P); + end loop; + + return Result; + end; + end Stat_Pred; + + -- 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; - -- Add Predicates for the current type + -- Get bounds of the type - Add_Predicates; + TLo := Expr_Value (Type_Low_Bound (Typ)); + THi := Expr_Value (Type_High_Bound (Typ)); - -- Add predicates for ancestor if present + -- Now analyze the expression to see if it is a static predicate declare - Atyp : constant Entity_Id := Nearest_Ancestor (Typ); + Ranges : constant RList := Get_RList (Expr); + -- Range list from expression if it is static + + Plist : List_Id; + begin - if Present (Atyp) then - Add_Call (Atyp); - end if; - end; + -- Convert range list into a form for the static predicate. In the + -- Ranges array, we just have raw ranges, these must be converted + -- to properly typed and analyzed static expressions or range nodes. - -- If we have predicates, build the function + Plist := New_List; - if Present (Expr) then + for J in Ranges'Range loop + declare + Lo : constant Uint := Ranges (J).Lo; + Hi : constant Uint := Ranges (J).Hi; - -- Deal with static predicate case + begin + if Lo = Hi then + Append_To (Plist, Build_Val (Lo)); + else + Append_To (Plist, Build_Range (Lo, Hi)); + end if; + end; + end loop; - Build_Static_Predicate; + -- Processing was successful and all entries were static, so now we + -- can store the result as the predicate list. - -- Build function declaration + Set_Static_Predicate (Typ, Plist); - 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); + -- The processing for static predicates put the expression into + -- canonical form as a series of ranges. It also eliminated + -- duplicates and collapsed and combined ranges. We might as well + -- replace the alternatives list of the right operand of the + -- membership test with the static predicate list, which will + -- usually be more efficient. - 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)); + declare + New_Alts : constant List_Id := New_List; + Old_Node : Node_Id; + New_Node : Node_Id; - FDecl := - Make_Subprogram_Declaration (Loc, - Specification => Spec); + begin + Old_Node := First (Plist); + while Present (Old_Node) loop + New_Node := New_Copy (Old_Node); - -- Build function body + if Nkind (New_Node) = N_Range then + Set_Low_Bound (New_Node, New_Copy (Low_Bound (Old_Node))); + Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node))); + end if; - SId := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Typ), "Predicate")); + Append_To (New_Alts, New_Node); + Next (Old_Node); + end loop; - 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)); + -- If empty list, replace by True - 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; + if Is_Empty_List (New_Alts) then + Rewrite (Expr, New_Occurrence_Of (Standard_True, Loc)); + + -- If singleton list, replace by simple membership test + + elsif List_Length (New_Alts) = 1 then + Rewrite (Expr, + Make_In (Loc, + Left_Opnd => Make_Identifier (Loc, Nam), + Right_Opnd => Relocate_Node (First (New_Alts)), + Alternatives => No_List)); + + -- If more than one range, replace by set membership test + + else + Rewrite (Expr, + Make_In (Loc, + Left_Opnd => Make_Identifier (Loc, Nam), + Right_Opnd => Empty, + Alternatives => New_Alts)); + end if; + end; + end; + + -- If non-static, return doing nothing + + exception + when Non_Static => + return; + end Build_Static_Predicate; ----------------------------------- -- Check_Constant_Address_Clause --