diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 33 | ||||
| -rw-r--r-- | gcc/ada/a-except-2005.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/a-except.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/atree.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/atree.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/atree.h | 1 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 12 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 31 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 329 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/sem_case.adb | 237 | ||||
| -rw-r--r-- | gcc/ada/sem_case.ads | 34 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 633 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch5.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 14 | ||||
| -rw-r--r-- | gcc/ada/types.ads | 2 |
19 files changed, 919 insertions, 517 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 8dbeb57..e5274a7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2010-10-22 Robert Dewar <dewar@adacore.com> + + * 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. + 2010-10-22 Jerome Lambourg <lambourg@adacore.com> * gnatlink.adb (Process_Binder_File): Remove CLI-specific code, now diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb index 7239696..cbf1e4d 100644 --- a/gcc/ada/a-except-2005.adb +++ b/gcc/ada/a-except-2005.adb @@ -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; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb index 8471dfe..e80e264 100644 --- a/gcc/ada/a-except.adb +++ b/gcc/ada/a-except.adb @@ -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; diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 957cca5..5426fab 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -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); diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads index 31b4391..51921cd 100644 --- a/gcc/ada/atree.ads +++ b/gcc/ada/atree.ads @@ -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); diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h index e6a429c..4cef407 100644 --- a/gcc/ada/atree.h +++ b/gcc/ada/atree.h @@ -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) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index ecc054d..5046397 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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 diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 30427a0..6b5a14a 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index e977bf9..f3de66c 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -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 diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 0867975..20a7829 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -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; diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index fc8806a..216d709 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -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,66 +993,48 @@ 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; + -- Now we can create the Choice_Table, since we know how long + -- it needs to be so we can allocate exactly the right length. - -- 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. + declare + Choice_Table : Choice_Table_Type (0 .. Num_Choices); - 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; + begin + -- Now copy the items we collected in the linked list into this + -- newly allocated table (leave entry 0 unused for sorting). + + 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; + + 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; - ----------------------- - -- 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 - - Choice := First (Get_Choices (Alt)); - while Present (Choice) loop - if Nkind (Choice) /= N_Others_Choice then - Count := Count + 1; - end if; - - Next (Choice); - end loop; - - Next_Non_Pragma (Alt); - end loop; - - return Count; - end Number_Of_Choices; - end Generic_Choices_Processing; end Sem_Case; diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads index 78ae7c6..ccee41f 100644 --- a/gcc/ada/sem_case.ads +++ b/gcc/ada/sem_case.ads @@ -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. -- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 58150a3..909fe8f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 -- ----------------------------------- diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 5322387..9371952 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; ---------------------------- diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index ac3fa03..45a4a21 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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 diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 692b179..79ff1d2 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -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); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4861fdc..ed34826 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 928d8bf..4031b24 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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; diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads index 6e496dd..ee2966c 100644 --- a/gcc/ada/types.ads +++ b/gcc/ada/types.ads @@ -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 |