From b7f17b2062c6e07c4236e16d124e9f1dcd34447f Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 18 Oct 2010 10:10:51 +0000 Subject: [PATCH] einfo.ads, einfo.adb: New attribute PPC_Wrapper for entries and entry families. 2010-10-18 Ed Schonberg * einfo.ads, einfo.adb: New attribute PPC_Wrapper for entries and entry families. Denotes a procedure that performs pre/postcondition checks and then performs the entry call. * sem_res.adb (Resolve_Entry_Call): If the entry has pre/postconditions, replace call with a call to the PPC_Wrapper of the entry. * exp_ch9.adb (Build_PPC_Wrapper): new procedure. (Expand_N_Entry_Declaration, Expand_N_Protected_Type_Declaration): call Build_PPC_Wrapper for all entries in task and protected definitions. From-SVN: r165622 --- gcc/ada/ChangeLog | 12 +++ gcc/ada/einfo.adb | 42 +++++++--- gcc/ada/einfo.ads | 10 +++ gcc/ada/exp_ch9.adb | 196 ++++++++++++++++++++++++++++++++++++++++---- gcc/ada/sem_res.adb | 23 ++++++ 5 files changed, 256 insertions(+), 27 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e94ba7ffa38..cf709097483 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2010-10-18 Ed Schonberg + + * einfo.ads, einfo.adb: New attribute PPC_Wrapper for entries and entry + families. Denotes a procedure that performs pre/postcondition checks + and then performs the entry call. + * sem_res.adb (Resolve_Entry_Call): If the entry has + pre/postconditions, replace call with a call to the PPC_Wrapper of the + entry. + * exp_ch9.adb (Build_PPC_Wrapper): new procedure. + (Expand_N_Entry_Declaration, Expand_N_Protected_Type_Declaration): call + Build_PPC_Wrapper for all entries in task and protected definitions. + 2010-10-18 Tristan Gingold * init.c: Add __gnat_set_stack_guard_page and __gnat_set_stack_limit. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 1ffdbbb17fe..5675f79aa2b 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -214,6 +214,7 @@ package body Einfo is -- Interfaces Elist25 -- Debug_Renaming_Link Node25 -- DT_Offset_To_Top_Func Node25 + -- PPC_Wrapper Node25 -- Task_Body_Procedure Node25 -- Dispatch_Table_Wrappers Elist26 @@ -512,7 +513,6 @@ package body Einfo is -- OK_To_Rename Flag247 -- (unused) Flag232 - -- (unused) Flag248 -- (unused) Flag249 -- (unused) Flag250 @@ -2359,6 +2359,12 @@ package body Einfo is return Node8 (Id); end Postcondition_Proc; + function PPC_Wrapper (Id : E) return E is + begin + pragma Assert (Ekind_In (Id, E_Entry, E_Entry_Family)); + return Node25 (Id); + end PPC_Wrapper; + function Prival (Id : E) return E is begin pragma Assert (Is_Protected_Component (Id)); @@ -2582,7 +2588,7 @@ package body Einfo is function Spec_PPC_List (Id : E) return N is begin pragma Assert - (Ekind (Id) = E_Entry + (Ekind_In (Id, E_Entry, E_Entry_Family) or else Is_Subprogram (Id) or else Is_Generic_Subprogram (Id)); return Node24 (Id); @@ -4817,6 +4823,12 @@ package body Einfo is Set_Node8 (Id, V); end Set_Postcondition_Proc; + procedure Set_PPC_Wrapper (Id : E; V : E) is + begin + pragma Assert (Ekind_In (Id, E_Entry, E_Entry_Family)); + Set_Node25 (Id, V); + end Set_PPC_Wrapper; + procedure Set_Direct_Primitive_Operations (Id : E; V : L) is begin pragma Assert @@ -5057,7 +5069,7 @@ package body Einfo is procedure Set_Spec_PPC_List (Id : E; V : N) is begin pragma Assert - (Ekind_In (Id, E_Entry, E_Void) + (Ekind_In (Id, E_Entry, E_Entry_Family, E_Void) or else Is_Subprogram (Id) or else Is_Generic_Subprogram (Id)); Set_Node24 (Id, V); @@ -6575,16 +6587,6 @@ package body Einfo is return Ekind (Id); end Parameter_Mode; - --------------------- - -- Record_Rep_Item -- - --------------------- - - procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is - begin - Set_Next_Rep_Item (N, First_Rep_Item (E)); - Set_First_Rep_Item (E, N); - end Record_Rep_Item; - -------------------------- -- Primitive_Operations -- -------------------------- @@ -6603,6 +6605,16 @@ package body Einfo is end if; end Primitive_Operations; + --------------------- + -- Record_Rep_Item -- + --------------------- + + procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is + begin + Set_Next_Rep_Item (N, First_Rep_Item (E)); + Set_First_Rep_Item (E, N); + end Record_Rep_Item; + --------------- -- Root_Type -- --------------- @@ -8132,6 +8144,10 @@ package body Einfo is when E_Variable => Write_Str ("Debug_Renaming_Link"); + when E_Entry | + E_Entry_Family => + Write_Str ("PPC_Wrapper"); + when others => Write_Str ("Field25??"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 3abc37bdcc6..cbfa6325f1a 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -3211,6 +3211,11 @@ package Einfo is -- to generate the call to this procedure in case the expander inserts -- implicit return statements. +-- PPC_Wrapper (Node25) +-- Present in entries and entry families. Set only if pre- or post- +-- conditions are present. The precondition_wrapper body is the original +-- entry call, decorated with the given precondition for the entry. + -- Primitive_Operations (synthesized) -- Present in concurrent types, tagged record types and subtypes, tagged -- private types and tagged incomplete types. For concurrent types that @@ -4960,6 +4965,7 @@ package Einfo is -- Scope_Depth_Value (Uint22) -- Protection_Object (Node23) (protected kind) -- Spec_PPC_List (Node24) (for entry only) + -- PPC_Wrapper (Node25) -- Default_Expressions_Processed (Flag108) -- Entry_Accepted (Flag152) -- Is_AST_Entry (Flag132) (for entry only) @@ -6079,6 +6085,7 @@ package Einfo is function Packed_Array_Type (Id : E) return E; function Parent_Subtype (Id : E) return E; function Postcondition_Proc (Id : E) return E; + function PPC_Wrapper (Id : E) return E; function Direct_Primitive_Operations (Id : E) return L; function Prival (Id : E) return E; function Prival_Link (Id : E) return E; @@ -6649,6 +6656,7 @@ package Einfo is procedure Set_Packed_Array_Type (Id : E; V : E); procedure Set_Parent_Subtype (Id : E; V : E); procedure Set_Postcondition_Proc (Id : E; V : E); + procedure Set_PPC_Wrapper (Id : E; V : E); procedure Set_Direct_Primitive_Operations (Id : E; V : L); procedure Set_Prival (Id : E; V : E); procedure Set_Prival_Link (Id : E; V : E); @@ -7367,6 +7375,7 @@ package Einfo is pragma Inline (Parameter_Mode); pragma Inline (Parent_Subtype); pragma Inline (Postcondition_Proc); + pragma Inline (PPC_Wrapper); pragma Inline (Prival); pragma Inline (Prival_Link); pragma Inline (Private_Dependents); @@ -7757,6 +7766,7 @@ package Einfo is pragma Inline (Set_Packed_Array_Type); pragma Inline (Set_Parent_Subtype); pragma Inline (Set_Postcondition_Proc); + pragma Inline (Set_PPC_Wrapper); pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index dd392ec6249..c16ffba8c9b 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -162,6 +162,14 @@ package body Exp_Ch9 is -- : AnnN; -- end record; + procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id); + -- Build body of wrapper procedure for an entry or entry family that has + -- pre/postconditions. The body gathers the PPC's and expands them in the + -- usual way, and performs the entry call itself. This way preconditions + -- are evaluated before the call is queued. E is the entry in question, + -- and Decl is the enclosing synchronized type declaration at whose + -- freeze point the generated body is analyzed. + procedure Build_Wrapper_Bodies (Loc : Source_Ptr; Typ : Entity_Id; @@ -1568,6 +1576,147 @@ package body Exp_Ch9 is return Rec_Nam; end Build_Parameter_Block; + ----------------------- + -- Build_PPC_Wrapper -- + ----------------------- + + procedure Build_PPC_Wrapper (E : Entity_Id; Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (E); + Synch_Type : constant Entity_Id := Scope (E); + + Wrapper_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (E), 'E')); + -- the wrapper procedure name + + Wrapper_Body : Node_Id; + + Synch_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + Chars => New_External_Name (Chars (Scope (E)), 'A')); + -- The parameter that designates the synchronized object in the call + + Actuals : constant List_Id := New_List; + -- the actuals in the entry call. + + Entry_Call : constant Node_Id := + Make_Procedure_Call_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Synch_Id, Loc), + Selector_Name => New_Occurrence_Of (E, Loc)), + Parameter_Associations => Actuals); + + Decls : constant List_Id := New_List; + + Specs : List_Id; + -- The specification of the wrapper procedure + + begin + + -- Only build the wrapper if entry has pre/postconditions. + -- Should this be done unconditionally instead ??? + + declare + P : Node_Id; + + begin + P := Spec_PPC_List (E); + if No (P) then + return; + end if; + + -- Transfer ppc pragmas to the declarations of the wrapper + + while Present (P) loop + if Pragma_Name (P) = Name_Precondition + or else Pragma_Name (P) = Name_Postcondition + then + Append (Relocate_Node (P), Decls); + Set_Analyzed (Last (Decls), False); + end if; + + P := Next_Pragma (P); + end loop; + end; + + -- First formal is synchronized object + + Specs := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Synch_Id, + Out_Present => True, + In_Present => True, + Parameter_Type => New_Occurrence_Of (Scope (E), Loc))); + + -- Now add formals that match those of the entry, and build actuals + -- for the nested entry call. + + declare + Form : Entity_Id; + New_Form : Entity_Id; + Parm_Spec : Node_Id; + + begin + Form := First_Formal (E); + while Present (Form) loop + New_Form := Make_Defining_Identifier (Loc, Chars (Form)); + Parm_Spec := + Make_Parameter_Specification (Loc, + Defining_Identifier => New_Form, + Out_Present => Out_Present (Parent (Form)), + In_Present => In_Present (Parent (Form)), + Parameter_Type => New_Occurrence_Of (Etype (Form), Loc)); + + Append (Parm_Spec, Specs); + Append (New_Occurrence_Of (New_Form, Loc), Actuals); + Next_Formal (Form); + end loop; + end; + + -- Add renaming declarations for the discriminants of the enclosing + -- type, which may be visible in the preconditions. + + if Has_Discriminants (Synch_Type) then + declare + D : Entity_Id; + Decl : Node_Id; + + begin + D := First_Discriminant (Synch_Type); + while Present (D) loop + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, Chars (D)), + Subtype_Mark => New_Reference_To (Etype (D), Loc), + Name => + Make_Selected_Component (Loc, + Prefix => New_Reference_To (Synch_Id, Loc), + Selector_Name => Make_Identifier (Loc, Chars (D)))); + Prepend (Decl, Decls); + Next_Discriminant (D); + end loop; + end; + end if; + + Set_PPC_Wrapper (E, Wrapper_Id); + Wrapper_Body := + Make_Subprogram_Body (Loc, + Specification => + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Wrapper_Id, + Parameter_Specifications => Specs), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Entry_Call))); + + -- The wrapper body is analyzed when the enclosing type is frozen. + + Append_Freeze_Action (Defining_Entity (Decl), Wrapper_Body); + end Build_PPC_Wrapper; + -------------------------- -- Build_Wrapper_Bodies -- -------------------------- @@ -1613,11 +1762,11 @@ package body Exp_Ch9 is end if; declare - Actuals : List_Id := No_List; - Conv_Id : Node_Id; - First_Form : Node_Id; - Formal : Node_Id; - Nam : Node_Id; + Actuals : List_Id := No_List; + Conv_Id : Node_Id; + First_Form : Node_Id; + Formal : Node_Id; + Nam : Node_Id; begin -- Map formals to actuals. Use the list built for the wrapper @@ -1630,7 +1779,6 @@ package body Exp_Ch9 is if Present (Formal) then Actuals := New_List; - while Present (Formal) loop Append_To (Actuals, Make_Identifier (Loc, Chars => @@ -1653,9 +1801,9 @@ package body Exp_Ch9 is if Is_Controlling_Formal (First_Formal (Subp_Id)) then Prepend_To (Actuals, - Unchecked_Convert_To ( - Corresponding_Concurrent_Type (Obj_Typ), - Make_Identifier (Loc, Name_uO))); + Unchecked_Convert_To + (Corresponding_Concurrent_Type (Obj_Typ), + Make_Identifier (Loc, Name_uO))); else Prepend_To (Actuals, @@ -1685,11 +1833,9 @@ package body Exp_Ch9 is Nam := Make_Selected_Component (Loc, Prefix => - Unchecked_Convert_To ( - Corresponding_Concurrent_Type (Obj_Typ), - Conv_Id), - Selector_Name => - New_Reference_To (Subp_Id, Loc)); + Unchecked_Convert_To + (Corresponding_Concurrent_Type (Obj_Typ), Conv_Id), + Selector_Name => New_Reference_To (Subp_Id, Loc)); end if; -- Create the subprogram body. For a function, the call to the @@ -8050,6 +8196,10 @@ package body Exp_Ch9 is Insert_After (Current_Node, Sub); Analyze (Sub); + -- build wrapper procedure for pre/postconditions. + + Build_PPC_Wrapper (Comp_Id, N); + Set_Protected_Body_Subprogram (Defining_Identifier (Comp), Defining_Unit_Name (Specification (Sub))); @@ -10599,6 +10749,24 @@ package body Exp_Ch9 is -- any were declared. Expand_Previous_Access_Type (Tasktyp); + + -- Create wrappers for entries that have pre/postconditions + + declare + Ent : Entity_Id; + + begin + Ent := First_Entity (Tasktyp); + while Present (Ent) loop + if Ekind_In (Ent, E_Entry, E_Entry_Family) + and then Present (Spec_PPC_List (Ent)) + then + Build_PPC_Wrapper (Ent, N); + end if; + + Next_Entity (Ent); + end loop; + end; end Expand_N_Task_Type_Declaration; ------------------------------- diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 5955070260a..3ca9798f9c3 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6327,6 +6327,29 @@ package body Sem_Res is end; end if; + if Ekind_In (Nam, E_Entry, E_Entry_Family) + and then Present (PPC_Wrapper (Nam)) + and then Current_Scope /= PPC_Wrapper (Nam) + then + + -- Rewrite as call to the precondition wrapper, adding the + -- task object to the list of actuals. + + declare + New_Call : Node_Id; + New_Actuals : List_Id; + begin + New_Actuals := New_List (Obj); + Append_List (Parameter_Associations (N), New_Actuals); + New_Call := Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (PPC_Wrapper (Nam), Loc), + Parameter_Associations => New_Actuals); + Rewrite (N, New_Call); + Analyze_And_Resolve (N); + return; + end; + end if; + -- The operation name may have been overloaded. Order the actuals -- according to the formals of the resolved entity, and set the -- return type to that of the operation. -- 2.30.2