diff options
Diffstat (limited to 'gcc/ada/exp_ch6.adb')
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 387 |
1 files changed, 374 insertions, 13 deletions
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7717fa7..ffd1475 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -73,8 +73,10 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinfo.Nodes; use Sinfo.Nodes; with Sinfo.Utils; use Sinfo.Utils; +with Sinput; use Sinput; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Tbuild; use Tbuild; with Uintp; use Uintp; with Validsw; use Validsw; @@ -4065,7 +4067,7 @@ package body Exp_Ch6 is end; end if; - -- If the formal is class wide and the actual is an aggregate, force + -- If the formal is class-wide and the actual is an aggregate, force -- evaluation so that the back end who does not know about class-wide -- type, does not generate a temporary of the wrong size. @@ -4250,6 +4252,16 @@ package body Exp_Ch6 is Expand_Interface_Actuals (Call_Node); end if; + -- Install class-wide preconditions runtime check when this is a + -- dispatching primitive that has or inherits class-wide preconditions; + -- otherwise no runtime check is installed. + + if Nkind (Call_Node) in N_Subprogram_Call + and then Is_Dispatching_Operation (Subp) + then + Install_Class_Preconditions_Check (Call_Node); + end if; + -- Deals with Dispatch_Call if we still have a call, before expanding -- extra actuals since this will be done on the re-analysis of the -- dispatching call. Note that we do not try to shorten the actual list @@ -7855,18 +7867,6 @@ package body Exp_Ch6 is -- returned type may not be known yet (for private types). Compute_Returns_By_Ref (Subp); - - -- When freezing a null procedure, analyze its delayed aspects now - -- because we may not have reached the end of the declarative list when - -- delayed aspects are normally analyzed. This ensures that dispatching - -- calls are properly rewritten when the generated _Postcondition - -- procedure is analyzed in the null procedure body. - - if Nkind (Parent (Subp)) = N_Procedure_Specification - and then Null_Present (Parent (Subp)) - then - Analyze_Entry_Or_Subprogram_Contract (Subp); - end if; end Freeze_Subprogram; -------------------------- @@ -8101,6 +8101,367 @@ package body Exp_Ch6 is end if; end Insert_Post_Call_Actions; + --------------------------------------- + -- Install_Class_Preconditions_Check -- + --------------------------------------- + + procedure Install_Class_Preconditions_Check (Call_Node : Node_Id) is + Loc : constant Source_Ptr := Sloc (Call_Node); + + function Build_Dynamic_Check_Helper_Call return Node_Id; + -- Build call to the helper runtime function of the nearest ancestor + -- of the target subprogram that dynamically evaluates the merged + -- or-else preconditions. + + function Build_Error_Message (Subp_Id : Entity_Id) return Node_Id; + -- Build message associated with the class-wide precondition of Subp_Id + -- indicating the call that caused it. + + function Build_Static_Check_Helper_Call return Node_Id; + -- Build call to the helper runtime function of the nearest ancestor + -- of the target subprogram that dynamically evaluates the merged + -- or-else preconditions. + + function Class_Preconditions_Subprogram + (Spec_Id : Entity_Id; + Dynamic : Boolean) return Node_Id; + -- Return the nearest ancestor of Spec_Id defining a helper function + -- that evaluates a combined or-else expression containing all the + -- inherited class-wide preconditions; Dynamic enables searching for + -- the helper that dynamically evaluates preconditions using dispatching + -- calls; if False it searches for the helper that statically evaluates + -- preconditions; return Empty when not available (which means that no + -- preconditions check is required). + + ------------------------------------- + -- Build_Dynamic_Check_Helper_Call -- + ------------------------------------- + + function Build_Dynamic_Check_Helper_Call return Node_Id is + Spec_Id : constant Entity_Id := Entity (Name (Call_Node)); + CW_Subp : constant Entity_Id := + Class_Preconditions_Subprogram (Spec_Id, + Dynamic => True); + Helper_Id : constant Entity_Id := + Dynamic_Call_Helper (CW_Subp); + Actuals : constant List_Id := New_List; + A : Node_Id := First_Actual (Call_Node); + F : Entity_Id := First_Formal (Helper_Id); + + begin + while Present (A) loop + + -- Ensure that the evaluation of the actuals will not produce + -- side effects. + + Remove_Side_Effects (A); + + Append_To (Actuals, New_Copy_Tree (A)); + Next_Formal (F); + Next_Actual (A); + end loop; + + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Helper_Id, Loc), + Parameter_Associations => Actuals); + end Build_Dynamic_Check_Helper_Call; + + ------------------------- + -- Build_Error_Message -- + ------------------------- + + function Build_Error_Message (Subp_Id : Entity_Id) return Node_Id is + + procedure Append_Message + (Id : Entity_Id; + Is_First : in out Boolean); + -- Build the fragment of the message associated with subprogram Id; + -- Is_First facilitates identifying continuation messages. + + -------------------- + -- Append_Message -- + -------------------- + + procedure Append_Message + (Id : Entity_Id; + Is_First : in out Boolean) + is + Prag : constant Node_Id := Get_Class_Wide_Pragma (Id, + Pragma_Precondition); + Msg : Node_Id; + Str_Id : String_Id; + + begin + if No (Prag) or else Is_Ignored (Prag) then + return; + end if; + + Msg := Expression (Last (Pragma_Argument_Associations (Prag))); + Str_Id := Strval (Msg); + + if Is_First then + Is_First := False; + + Append (Global_Name_Buffer, Strval (Msg)); + + if Id /= Subp_Id + and then Name_Buffer (1 .. 19) = "failed precondition" + then + Insert_Str_In_Name_Buffer ("inherited ", 8); + end if; + + else + declare + Str : constant String := To_String (Str_Id); + From_Idx : Integer; + + begin + Append (Global_Name_Buffer, ASCII.LF); + Append (Global_Name_Buffer, " or "); + + From_Idx := Name_Len; + Append (Global_Name_Buffer, Str_Id); + + if Str (1 .. 19) = "failed precondition" then + Insert_Str_In_Name_Buffer ("inherited ", From_Idx + 8); + end if; + end; + end if; + end Append_Message; + + -- Local variables + + Str_Loc : constant String := Build_Location_String (Loc); + Subps : constant Subprogram_List := + Inherited_Subprograms (Subp_Id); + Is_First : Boolean := True; + + -- Start of processing for Build_Error_Message + + begin + Name_Len := 0; + Append_Message (Subp_Id, Is_First); + + for Index in Subps'Range loop + Append_Message (Subps (Index), Is_First); + end loop; + + if Present (Controlling_Argument (Call_Node)) then + Append (Global_Name_Buffer, " in dispatching call at "); + else + Append (Global_Name_Buffer, " in call at "); + end if; + + Append (Global_Name_Buffer, Str_Loc); + + return Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len)); + end Build_Error_Message; + + ------------------------------------ + -- Build_Static_Check_Helper_Call -- + ------------------------------------ + + function Build_Static_Check_Helper_Call return Node_Id is + Actuals : constant List_Id := New_List; + A : Node_Id; + Helper_Id : Entity_Id; + F : Entity_Id; + CW_Subp : Entity_Id; + Spec_Id : constant Entity_Id := Entity (Name (Call_Node)); + + begin + -- The target is the wrapper built to support inheriting body but + -- overriding pre/postconditions (AI12-0195). + + if Is_Dispatch_Table_Wrapper (Spec_Id) then + CW_Subp := Spec_Id; + + -- Common case + + else + CW_Subp := Class_Preconditions_Subprogram (Spec_Id, + Dynamic => False); + end if; + + Helper_Id := Static_Call_Helper (CW_Subp); + + F := First_Formal (Helper_Id); + A := First_Actual (Call_Node); + while Present (A) loop + + -- Ensure that the evaluation of the actuals will not produce + -- side effects. + + Remove_Side_Effects (A); + + if Is_Controlling_Actual (A) + and then Etype (F) /= Etype (A) + then + Append_To (Actuals, + Make_Unchecked_Type_Conversion (Loc, + New_Occurrence_Of (Etype (F), Loc), + New_Copy_Tree (A))); + else + Append_To (Actuals, New_Copy_Tree (A)); + end if; + + Next_Formal (F); + Next_Actual (A); + end loop; + + return + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Helper_Id, Loc), + Parameter_Associations => Actuals); + end Build_Static_Check_Helper_Call; + + ------------------------------------ + -- Class_Preconditions_Subprogram -- + ------------------------------------ + + function Class_Preconditions_Subprogram + (Spec_Id : Entity_Id; + Dynamic : Boolean) return Node_Id + is + Subp_Id : constant Entity_Id := Ultimate_Alias (Spec_Id); + + begin + -- Prevent cascaded errors + + if not Is_Dispatching_Operation (Subp_Id) then + return Empty; + + -- No need to search if this subprogram has the helper we are + -- searching + + elsif Dynamic then + if Present (Dynamic_Call_Helper (Subp_Id)) then + return Subp_Id; + end if; + else + if Present (Static_Call_Helper (Subp_Id)) then + return Subp_Id; + end if; + end if; + + -- Process inherited subprograms looking for class-wide + -- preconditions. + + declare + Subps : constant Subprogram_List := + Inherited_Subprograms (Subp_Id); + Subp_Id : Entity_Id; + + begin + for Index in Subps'Range loop + Subp_Id := Subps (Index); + + if Present (Alias (Subp_Id)) then + Subp_Id := Ultimate_Alias (Subp_Id); + end if; + + -- Wrappers of class-wide pre/postconditions reference the + -- parent primitive that has the inherited contract. + + if Is_Wrapper (Subp_Id) + and then Present (LSP_Subprogram (Subp_Id)) + then + Subp_Id := LSP_Subprogram (Subp_Id); + end if; + + if Dynamic then + if Present (Dynamic_Call_Helper (Subp_Id)) then + return Subp_Id; + end if; + else + if Present (Static_Call_Helper (Subp_Id)) then + return Subp_Id; + end if; + end if; + end loop; + end; + + return Empty; + end Class_Preconditions_Subprogram; + + -- Local variables + + Dynamic_Check : constant Boolean := + Present (Controlling_Argument (Call_Node)); + Class_Subp : Entity_Id; + Cond : Node_Id; + Subp : Entity_Id; + + -- Start of processing for Install_Class_Preconditions_Check + + begin + -- Do not expand the check if we are compiling under restriction + -- No_Dispatching_Calls; the semantic analyzer has previously + -- notified the violation of this restriction. + + if Dynamic_Check + and then Restriction_Active (No_Dispatching_Calls) + then + return; + + -- Class-wide precondition check not needed in interface thunks since + -- they are installed in the dispatching call that caused invoking the + -- thunk. + + elsif Is_Thunk (Current_Scope) then + return; + end if; + + Subp := Entity (Name (Call_Node)); + + -- No check needed for this subprogram call if no class-wide + -- preconditions apply (or if the unique available preconditions + -- are ignored preconditions). + + Class_Subp := Class_Preconditions_Subprogram (Subp, Dynamic_Check); + + if No (Class_Subp) + or else No (Class_Preconditions (Class_Subp)) + then + return; + end if; + + -- Build and install the check + + if Dynamic_Check then + Cond := Build_Dynamic_Check_Helper_Call; + else + Cond := Build_Static_Check_Helper_Call; + end if; + + if Exception_Locations_Suppressed then + Insert_Action (Call_Node, + Make_If_Statement (Loc, + Condition => Make_Op_Not (Loc, Cond), + Then_Statements => New_List ( + Make_Raise_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Assert_Failure), Loc))))); + + -- Failed check with message indicating the failed precondition and the + -- call that caused it. + + else + Insert_Action (Call_Node, + Make_If_Statement (Loc, + Condition => Make_Op_Not (Loc, Cond), + Then_Statements => New_List ( + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of + (RTE (RE_Raise_Assert_Failure), Loc), + Parameter_Associations => + New_List (Build_Error_Message (Subp)))))); + end if; + end Install_Class_Preconditions_Check; + ----------------------------------- -- Is_Build_In_Place_Result_Type -- ----------------------------------- |