end if;
end Arg3;
- ---------------------------
- -- Expand_Contract_Cases --
- ---------------------------
-
- -- Pragma Contract_Cases is expanded in the following manner:
+ ---------------------
+ -- Expand_N_Pragma --
+ ---------------------
- -- subprogram S is
- -- Count : Natural := 0;
- -- Flag_1 : Boolean := False;
- -- . . .
- -- Flag_N : Boolean := False;
- -- Flag_N+1 : Boolean := False; -- when "others" present
- -- Pref_1 : ...;
- -- . . .
- -- Pref_M : ...;
+ procedure Expand_N_Pragma (N : Node_Id) is
+ Pname : constant Name_Id := Pragma_Name (N);
- -- <preconditions (if any)>
+ begin
+ -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that
+ -- the back end or the expander here does not get over-enthusiastic and
+ -- start processing such a pragma!
- -- -- Evaluate all case guards
+ if Get_Name_Table_Boolean3 (Pname) then
+ Rewrite (N, Make_Null_Statement (Sloc (N)));
+ return;
+ end if;
- -- if Case_Guard_1 then
- -- Flag_1 := True;
- -- Count := Count + 1;
- -- end if;
- -- . . .
- -- if Case_Guard_N then
- -- Flag_N := True;
- -- Count := Count + 1;
- -- end if;
+ -- Note: we may have a pragma whose Pragma_Identifier field is not a
+ -- recognized pragma, and we must ignore it at this stage.
- -- -- Emit errors depending on the number of case guards that
- -- -- evaluated to True.
+ if Is_Pragma_Name (Pname) then
+ case Get_Pragma_Id (Pname) is
- -- if Count = 0 then
- -- raise Assertion_Error with "xxx contract cases incomplete";
- -- <or>
- -- Flag_N+1 := True; -- when "others" present
+ -- Pragmas requiring special expander action
- -- elsif Count > 1 then
- -- declare
- -- Str0 : constant String :=
- -- "contract cases overlap for subprogram ABC";
- -- Str1 : constant String :=
- -- (if Flag_1 then
- -- Str0 & "case guard at xxx evaluates to True"
- -- else Str0);
- -- StrN : constant String :=
- -- (if Flag_N then
- -- StrN-1 & "case guard at xxx evaluates to True"
- -- else StrN-1);
- -- begin
- -- raise Assertion_Error with StrN;
- -- end;
- -- end if;
+ when Pragma_Abort_Defer =>
+ Expand_Pragma_Abort_Defer (N);
- -- -- Evaluate all attribute 'Old prefixes found in the selected
- -- -- consequence.
+ when Pragma_Check =>
+ Expand_Pragma_Check (N);
- -- if Flag_1 then
- -- Pref_1 := <prefix of 'Old found in Consequence_1>
- -- . . .
- -- elsif Flag_N then
- -- Pref_M := <prefix of 'Old found in Consequence_N>
- -- end if;
+ when Pragma_Common_Object =>
+ Expand_Pragma_Common_Object (N);
- -- procedure _Postconditions is
- -- begin
- -- <postconditions (if any)>
+ when Pragma_Import =>
+ Expand_Pragma_Import_Or_Interface (N);
- -- if Flag_1 and then not Consequence_1 then
- -- raise Assertion_Error with "failed contract case at xxx";
- -- end if;
- -- . . .
- -- if Flag_N[+1] and then not Consequence_N[+1] then
- -- raise Assertion_Error with "failed contract case at xxx";
- -- end if;
- -- end _Postconditions;
- -- begin
- -- . . .
- -- end S;
+ when Pragma_Inspection_Point =>
+ Expand_Pragma_Inspection_Point (N);
- procedure Expand_Contract_Cases
- (CCs : Node_Id;
- Subp_Id : Entity_Id;
- Decls : List_Id;
- Stmts : in out List_Id)
- is
- Loc : constant Source_Ptr := Sloc (CCs);
+ when Pragma_Interface =>
+ Expand_Pragma_Import_Or_Interface (N);
- procedure Case_Guard_Error
- (Decls : List_Id;
- Flag : Entity_Id;
- Error_Loc : Source_Ptr;
- Msg : in out Entity_Id);
- -- Given a declarative list Decls, status flag Flag, the location of the
- -- error and a string Msg, construct the following check:
- -- Msg : constant String :=
- -- (if Flag then
- -- Msg & "case guard at Error_Loc evaluates to True"
- -- else Msg);
- -- The resulting code is added to Decls
+ when Pragma_Interrupt_Priority =>
+ Expand_Pragma_Interrupt_Priority (N);
- procedure Consequence_Error
- (Checks : in out Node_Id;
- Flag : Entity_Id;
- Conseq : Node_Id);
- -- Given an if statement Checks, status flag Flag and a consequence
- -- Conseq, construct the following check:
- -- [els]if Flag and then not Conseq then
- -- raise Assertion_Error
- -- with "failed contract case at Sloc (Conseq)";
- -- [end if;]
- -- The resulting code is added to Checks
+ when Pragma_Loop_Variant =>
+ Expand_Pragma_Loop_Variant (N);
- function Declaration_Of (Id : Entity_Id) return Node_Id;
- -- Given the entity Id of a boolean flag, generate:
- -- Id : Boolean := False;
+ when Pragma_Psect_Object =>
+ Expand_Pragma_Psect_Object (N);
- procedure Expand_Attributes_In_Consequence
- (Decls : List_Id;
- Evals : in out Node_Id;
- Flag : Entity_Id;
- Conseq : Node_Id);
- -- Perform specialized expansion of all attribute 'Old references found
- -- in consequence Conseq such that at runtime only prefixes coming from
- -- the selected consequence are evaluated. Similarly expand attribute
- -- 'Result references by replacing them with identifier _result which
- -- resolves to the sole formal parameter of procedure _Postconditions.
- -- Any temporaries generated in the process are added to declarations
- -- Decls. Evals is a complex if statement tasked with the evaluation of
- -- all prefixes coming from a single selected consequence. Flag is the
- -- corresponding case guard flag. Conseq is the consequence expression.
+ when Pragma_Relative_Deadline =>
+ Expand_Pragma_Relative_Deadline (N);
- function Increment (Id : Entity_Id) return Node_Id;
- -- Given the entity Id of a numerical variable, generate:
- -- Id := Id + 1;
+ when Pragma_Suppress_Initialization =>
+ Expand_Pragma_Suppress_Initialization (N);
- function Set (Id : Entity_Id) return Node_Id;
- -- Given the entity Id of a boolean variable, generate:
- -- Id := True;
+ -- All other pragmas need no expander action
- ----------------------
- -- Case_Guard_Error --
- ----------------------
+ when others => null;
+ end case;
+ end if;
- procedure Case_Guard_Error
- (Decls : List_Id;
- Flag : Entity_Id;
- Error_Loc : Source_Ptr;
- Msg : in out Entity_Id)
- is
- New_Line : constant Character := Character'Val (10);
- New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S');
+ end Expand_N_Pragma;
- begin
- Start_String;
- Store_String_Char (New_Line);
- Store_String_Chars (" case guard at ");
- Store_String_Chars (Build_Location_String (Error_Loc));
- Store_String_Chars (" evaluates to True");
+ -------------------------------
+ -- Expand_Pragma_Abort_Defer --
+ -------------------------------
- -- Generate:
- -- New_Msg : constant String :=
- -- (if Flag then
- -- Msg & "case guard at Error_Loc evaluates to True"
- -- else Msg);
+ -- An Abort_Defer pragma appears as the first statement in a handled
+ -- statement sequence (right after the begin). It defers aborts for
+ -- the entire statement sequence, but not for any declarations or
+ -- handlers (if any) associated with this statement sequence.
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => New_Msg,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression =>
- Make_If_Expression (Loc,
- Expressions => New_List (
- New_Occurrence_Of (Flag, Loc),
+ -- The transformation is to transform
- Make_Op_Concat (Loc,
- Left_Opnd => New_Occurrence_Of (Msg, Loc),
- Right_Opnd => Make_String_Literal (Loc, End_String)),
+ -- pragma Abort_Defer;
+ -- statements;
- New_Occurrence_Of (Msg, Loc)))));
+ -- into
- Msg := New_Msg;
- end Case_Guard_Error;
+ -- begin
+ -- Abort_Defer.all;
+ -- statements
+ -- exception
+ -- when all others =>
+ -- Abort_Undefer.all;
+ -- raise;
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
- -----------------------
- -- Consequence_Error --
- -----------------------
+ procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ Stm : Node_Id;
+ Stms : List_Id;
+ HSS : Node_Id;
+ Blk : constant Entity_Id :=
+ New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
+ AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
- procedure Consequence_Error
- (Checks : in out Node_Id;
- Flag : Entity_Id;
- Conseq : Node_Id)
- is
- Cond : Node_Id;
- Error : Node_Id;
+ begin
+ Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
+ loop
+ Stm := Remove_Next (N);
+ exit when No (Stm);
+ Append (Stm, Stms);
+ end loop;
- begin
- -- Generate:
- -- Flag and then not Conseq
+ HSS :=
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stms,
+ At_End_Proc => New_Occurrence_Of (AUD, Loc));
- Cond :=
- Make_And_Then (Loc,
- Left_Opnd => New_Occurrence_Of (Flag, Loc),
- Right_Opnd =>
- Make_Op_Not (Loc,
- Right_Opnd => Relocate_Node (Conseq)));
+ -- Present the Abort_Undefer_Direct function to the backend so that it
+ -- can inline the call to the function.
- -- Generate:
- -- raise Assertion_Error
- -- with "failed contract case at Sloc (Conseq)";
+ Add_Inlined_Body (AUD, N);
- Start_String;
- Store_String_Chars ("failed contract case at ");
- Store_String_Chars (Build_Location_String (Sloc (Conseq)));
+ Rewrite (N,
+ Make_Block_Statement (Loc,
+ Handled_Statement_Sequence => HSS));
- Error :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc, End_String)));
+ Set_Scope (Blk, Current_Scope);
+ Set_Etype (Blk, Standard_Void_Type);
+ Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
+ Expand_At_End_Handler (HSS, Blk);
+ Analyze (N);
+ end Expand_Pragma_Abort_Defer;
- if No (Checks) then
- Checks :=
- Make_Implicit_If_Statement (CCs,
- Condition => Cond,
- Then_Statements => New_List (Error));
+ --------------------------
+ -- Expand_Pragma_Check --
+ --------------------------
- else
- if No (Elsif_Parts (Checks)) then
- Set_Elsif_Parts (Checks, New_List);
- end if;
+ procedure Expand_Pragma_Check (N : Node_Id) is
+ Cond : constant Node_Id := Arg2 (N);
+ Nam : constant Name_Id := Chars (Arg1 (N));
+ Msg : Node_Id;
- Append_To (Elsif_Parts (Checks),
- Make_Elsif_Part (Loc,
- Condition => Cond,
- Then_Statements => New_List (Error)));
- end if;
- end Consequence_Error;
+ Loc : constant Source_Ptr := Sloc (First_Node (Cond));
+ -- Source location used in the case of a failed assertion: point to the
+ -- failing condition, not Loc. Note that the source location of the
+ -- expression is not usually the best choice here, because it points to
+ -- the location of the topmost tree node, which may be an operator in
+ -- the middle of the source text of the expression. For example, it gets
+ -- located on the last AND keyword in a chain of boolean expressiond
+ -- AND'ed together. It is best to put the message on the first character
+ -- of the condition, which is the effect of the First_Node call here.
+ -- This source location is used to build the default exception message,
+ -- and also as the sloc of the call to the runtime subprogram raising
+ -- Assert_Failure, so that coverage analysis tools can relate the
+ -- call to the failed check.
- --------------------
- -- Declaration_Of --
- --------------------
+ begin
+ -- Nothing to do if pragma is ignored
- function Declaration_Of (Id : Entity_Id) return Node_Id is
- begin
- return
- Make_Object_Declaration (Loc,
- Defining_Identifier => Id,
- Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
- Expression => New_Occurrence_Of (Standard_False, Loc));
- end Declaration_Of;
+ if Is_Ignored (N) then
+ return;
+ end if;
- --------------------------------------
- -- Expand_Attributes_In_Consequence --
- --------------------------------------
+ -- Since this check is active, we rewrite the pragma into a
+ -- corresponding if statement, and then analyze the statement
- procedure Expand_Attributes_In_Consequence
- (Decls : List_Id;
- Evals : in out Node_Id;
- Flag : Entity_Id;
- Conseq : Node_Id)
- is
- Eval_Stmts : List_Id := No_List;
- -- The evaluation sequence expressed as assignment statements of all
- -- prefixes of attribute 'Old found in the current consequence.
+ -- The normal case expansion transforms:
- function Expand_Attributes (N : Node_Id) return Traverse_Result;
- -- Determine whether an arbitrary node denotes attribute 'Old or
- -- 'Result and if it does, perform all expansion-related actions.
+ -- pragma Check (name, condition [,message]);
- -----------------------
- -- Expand_Attributes --
- -----------------------
+ -- into
- function Expand_Attributes (N : Node_Id) return Traverse_Result is
- Decl : Node_Id;
- Pref : Node_Id;
- Temp : Entity_Id;
+ -- if not condition then
+ -- System.Assertions.Raise_Assert_Failure (Str);
+ -- end if;
- begin
- -- Attribute 'Old
+ -- where Str is the message if one is present, or the default of
+ -- name failed at file:line if no message is given (the "name failed
+ -- at" is omitted for name = Assertion, since it is redundant, given
+ -- that the name of the exception is Assert_Failure.)
- if Nkind (N) = N_Attribute_Reference
- and then Attribute_Name (N) = Name_Old
- then
- Pref := Prefix (N);
- Temp := Make_Temporary (Loc, 'T', Pref);
- Set_Etype (Temp, Etype (Pref));
+ -- Also, instead of "XXX failed at", we generate slightly
+ -- different messages for some of the contract assertions (see
+ -- code below for details).
- -- Generate a temporary to capture the value of the prefix:
- -- Temp : <Pref type>;
- -- Place that temporary at the beginning of declarations, to
- -- prevent anomalies in the GNATprove flow-analysis pass in
- -- the precondition procedure that follows.
+ -- An alternative expansion is used when the No_Exception_Propagation
+ -- restriction is active and there is a local Assert_Failure handler.
+ -- This is not a common combination of circumstances, but it occurs in
+ -- the context of Aunit and the zero footprint profile. In this case we
+ -- generate:
- Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Etype (Pref), Loc));
- Set_No_Initialization (Decl);
+ -- if not condition then
+ -- raise Assert_Failure;
+ -- end if;
- Prepend_To (Decls, Decl);
- Analyze (Decl);
+ -- This will then be transformed into a goto, and the local handler will
+ -- be able to handle the assert error (which would not be the case if a
+ -- call is made to the Raise_Assert_Failure procedure).
- -- Evaluate the prefix, generate:
- -- Temp := <Pref>;
+ -- We also generate the direct raise if the Suppress_Exception_Locations
+ -- is active, since we don't want to generate messages in this case.
- if No (Eval_Stmts) then
- Eval_Stmts := New_List;
- end if;
+ -- Note that the reason we do not always generate a direct raise is that
+ -- the form in which the procedure is called allows for more efficient
+ -- breakpointing of assertion errors.
- Append_To (Eval_Stmts,
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Temp, Loc),
- Expression => Pref));
+ -- Generate the appropriate if statement. Note that we consider this to
+ -- be an explicit conditional in the source, not an implicit if, so we
+ -- do not call Make_Implicit_If_Statement.
- -- Ensure that the prefix is valid
+ -- Case where we generate a direct raise
- if Validity_Checks_On and then Validity_Check_Operands then
- Ensure_Valid (Pref);
- end if;
+ if ((Debug_Flag_Dot_G
+ or else Restriction_Active (No_Exception_Propagation))
+ and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
+ or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
+ then
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Make_Op_Not (Loc, Right_Opnd => Cond),
+ Then_Statements => New_List (
+ Make_Raise_Statement (Loc,
+ Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc)))));
- -- Replace the original attribute 'Old by a reference to the
- -- generated temporary.
+ -- Case where we call the procedure
- Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ else
+ -- If we have a message given, use it
- -- Attribute 'Result
+ if Present (Arg3 (N)) then
+ Msg := Get_Pragma_Arg (Arg3 (N));
- elsif Is_Attribute_Result (N) then
- Rewrite (N, Make_Identifier (Loc, Name_uResult));
- end if;
+ -- Here we have no string, so prepare one
- return OK;
- end Expand_Attributes;
+ else
+ declare
+ Loc_Str : constant String := Build_Location_String (Loc);
- procedure Expand_Attributes_In is
- new Traverse_Proc (Expand_Attributes);
+ begin
+ Name_Len := 0;
- -- Start of processing for Expand_Attributes_In_Consequence
+ -- For Assert, we just use the location
- begin
- -- Inspect the consequence and expand any attribute 'Old and 'Result
- -- references found within.
+ if Nam = Name_Assert then
+ null;
- Expand_Attributes_In (Conseq);
+ -- For predicate, we generate the string "predicate failed at
+ -- yyy". We prefer all lower case for predicate.
- -- The consequence does not contain any attribute 'Old references
+ elsif Nam = Name_Predicate then
+ Add_Str_To_Name_Buffer ("predicate failed at ");
- if No (Eval_Stmts) then
- return;
- end if;
+ -- For special case of Precondition/Postcondition the string is
+ -- "failed xx from yy" where xx is precondition/postcondition
+ -- in all lower case. The reason for this different wording is
+ -- that the failure is not at the point of occurrence of the
+ -- pragma, unlike the other Check cases.
- -- Augment the machinery to trigger the evaluation of all prefixes
- -- found in the step above. If Eval is empty, then this is the first
- -- consequence to yield expansion of 'Old. Generate:
+ elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then
+ Get_Name_String (Nam);
+ Insert_Str_In_Name_Buffer ("failed ", 1);
+ Add_Str_To_Name_Buffer (" from ");
- -- if Flag then
- -- <evaluation statements>
- -- end if;
+ -- For special case of Invariant, the string is "failed
+ -- invariant from yy", to be consistent with the string that is
+ -- generated for the aspect case (the code later on checks for
+ -- this specific string to modify it in some cases, so this is
+ -- functionally important).
- if No (Evals) then
- Evals :=
- Make_Implicit_If_Statement (CCs,
- Condition => New_Occurrence_Of (Flag, Loc),
- Then_Statements => Eval_Stmts);
+ elsif Nam = Name_Invariant then
+ Add_Str_To_Name_Buffer ("failed invariant from ");
- -- Otherwise generate:
- -- elsif Flag then
- -- <evaluation statements>
- -- end if;
+ -- For all other checks, the string is "xxx failed at yyy"
+ -- where xxx is the check name with current source file casing.
- else
- if No (Elsif_Parts (Evals)) then
- Set_Elsif_Parts (Evals, New_List);
- end if;
+ else
+ Get_Name_String (Nam);
+ Set_Casing (Identifier_Casing (Current_Source_File));
+ Add_Str_To_Name_Buffer (" failed at ");
+ end if;
- Append_To (Elsif_Parts (Evals),
- Make_Elsif_Part (Loc,
- Condition => New_Occurrence_Of (Flag, Loc),
- Then_Statements => Eval_Stmts));
- end if;
- end Expand_Attributes_In_Consequence;
+ -- In all cases, add location string
- ---------------
- -- Increment --
- ---------------
+ Add_Str_To_Name_Buffer (Loc_Str);
- function Increment (Id : Entity_Id) return Node_Id is
- begin
- return
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Id, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Occurrence_Of (Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)));
- end Increment;
+ -- Build the message
- ---------
- -- Set --
- ---------
+ Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
+ end;
+ end if;
- function Set (Id : Entity_Id) return Node_Id is
- begin
- return
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (Id, Loc),
- Expression => New_Occurrence_Of (Standard_True, Loc));
- end Set;
+ -- Now rewrite as an if statement
- -- Local variables
+ Rewrite (N,
+ Make_If_Statement (Loc,
+ Condition => Make_Op_Not (Loc, Right_Opnd => Cond),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (Relocate_Node (Msg))))));
+ end if;
- Aggr : constant Node_Id :=
- Expression (First
- (Pragma_Argument_Associations (CCs)));
- Case_Guard : Node_Id;
- CG_Checks : Node_Id;
- CG_Stmts : List_Id;
- Conseq : Node_Id;
- Conseq_Checks : Node_Id := Empty;
- Count : Entity_Id;
- Count_Decl : Node_Id;
- Error_Decls : List_Id;
- Flag : Entity_Id;
- Flag_Decl : Node_Id;
- If_Stmt : Node_Id;
- Msg_Str : Entity_Id;
- Multiple_PCs : Boolean;
- Old_Evals : Node_Id := Empty;
- Others_Decl : Node_Id;
- Others_Flag : Entity_Id := Empty;
- Post_Case : Node_Id;
+ Analyze (N);
- -- Start of processing for Expand_Contract_Cases
+ -- If new condition is always false, give a warning
- begin
- -- Do nothing if pragma is not enabled. If pragma is disabled, it has
- -- already been rewritten as a Null statement.
+ if Warn_On_Assertion_Failure
+ and then Nkind (N) = N_Procedure_Call_Statement
+ and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
+ then
+ -- If original condition was a Standard.False, we assume that this is
+ -- indeed intended to raise assert error and no warning is required.
- if Is_Ignored (CCs) then
- return;
+ if Is_Entity_Name (Original_Node (Cond))
+ and then Entity (Original_Node (Cond)) = Standard_False
+ then
+ return;
- -- Guard against malformed contract cases
+ elsif Nam = Name_Assert then
+ Error_Msg_N ("?A?assertion will fail at run time", N);
+ else
- elsif Nkind (Aggr) /= N_Aggregate then
- return;
+ Error_Msg_N ("?A?check will fail at run time", N);
+ end if;
end if;
+ end Expand_Pragma_Check;
- Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1;
+ ---------------------------------
+ -- Expand_Pragma_Common_Object --
+ ---------------------------------
- -- Create the counter which tracks the number of case guards that
- -- evaluate to True.
+ -- Use a machine attribute to replicate semantic effect in DEC Ada
- -- Count : Natural := 0;
+ -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
- Count := Make_Temporary (Loc, 'C');
- Count_Decl :=
- Make_Object_Declaration (Loc,
- Defining_Identifier => Count,
- Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
- Expression => Make_Integer_Literal (Loc, 0));
+ -- For now we do nothing with the size attribute ???
- Prepend_To (Decls, Count_Decl);
- Analyze (Count_Decl);
+ -- Note: Psect_Object shares this processing
- -- Create the base error message for multiple overlapping case guards
+ procedure Expand_Pragma_Common_Object (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
- -- Msg_Str : constant String :=
- -- "contract cases overlap for subprogram Subp_Id";
+ Internal : constant Node_Id := Arg1 (N);
+ External : constant Node_Id := Arg2 (N);
- if Multiple_PCs then
- Msg_Str := Make_Temporary (Loc, 'S');
+ Psect : Node_Id;
+ -- Psect value upper cased as string literal
- Start_String;
- Store_String_Chars ("contract cases overlap for subprogram ");
- Store_String_Chars (Get_Name_String (Chars (Subp_Id)));
+ Iloc : constant Source_Ptr := Sloc (Internal);
+ Eloc : constant Source_Ptr := Sloc (External);
+ Ploc : Source_Ptr;
- Error_Decls := New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Msg_Str,
- Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Standard_String, Loc),
- Expression => Make_String_Literal (Loc, End_String)));
- end if;
+ begin
+ -- Acquire Psect value and fold to upper case
- -- Process individual post cases
+ if Present (External) then
+ if Nkind (External) = N_String_Literal then
+ String_To_Name_Buffer (Strval (External));
+ else
+ Get_Name_String (Chars (External));
+ end if;
- Post_Case := First (Component_Associations (Aggr));
- while Present (Post_Case) loop
- Case_Guard := First (Choices (Post_Case));
- Conseq := Expression (Post_Case);
+ Set_All_Upper_Case;
- -- The "others" choice requires special processing
+ Psect :=
+ Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
- if Nkind (Case_Guard) = N_Others_Choice then
- Others_Flag := Make_Temporary (Loc, 'F');
- Others_Decl := Declaration_Of (Others_Flag);
+ else
+ Get_Name_String (Chars (Internal));
+ Set_All_Upper_Case;
+ Psect :=
+ Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
+ end if;
- Prepend_To (Decls, Others_Decl);
- Analyze (Others_Decl);
+ Ploc := Sloc (Psect);
- -- Check possible overlap between a case guard and "others"
+ -- Insert the pragma
- if Multiple_PCs and Exception_Extra_Info then
- Case_Guard_Error
- (Decls => Error_Decls,
- Flag => Others_Flag,
- Error_Loc => Sloc (Case_Guard),
- Msg => Msg_Str);
- end if;
+ Insert_After_And_Analyze (N,
+ Make_Pragma (Loc,
+ Chars => Name_Machine_Attribute,
+ Pragma_Argument_Associations => New_List (
+ Make_Pragma_Argument_Association (Iloc,
+ Expression => New_Copy_Tree (Internal)),
+ Make_Pragma_Argument_Association (Eloc,
+ Expression =>
+ Make_String_Literal (Sloc => Ploc, Strval => "common_object")),
+ Make_Pragma_Argument_Association (Ploc,
+ Expression => New_Copy_Tree (Psect)))));
+ end Expand_Pragma_Common_Object;
- -- Inspect the consequence and perform special expansion of any
- -- attribute 'Old and 'Result references found within.
+ ----------------------------------
+ -- Expand_Pragma_Contract_Cases --
+ ----------------------------------
- Expand_Attributes_In_Consequence
- (Decls => Decls,
- Evals => Old_Evals,
- Flag => Others_Flag,
- Conseq => Conseq);
+ -- Pragma Contract_Cases is expanded in the following manner:
- -- Check the corresponding consequence of "others"
+ -- subprogram S is
+ -- Count : Natural := 0;
+ -- Flag_1 : Boolean := False;
+ -- . . .
+ -- Flag_N : Boolean := False;
+ -- Flag_N+1 : Boolean := False; -- when "others" present
+ -- Pref_1 : ...;
+ -- . . .
+ -- Pref_M : ...;
- Consequence_Error
- (Checks => Conseq_Checks,
- Flag => Others_Flag,
- Conseq => Conseq);
+ -- <preconditions (if any)>
- -- Regular post case
+ -- -- Evaluate all case guards
- else
- -- Create the flag which tracks the state of its associated case
- -- guard.
+ -- if Case_Guard_1 then
+ -- Flag_1 := True;
+ -- Count := Count + 1;
+ -- end if;
+ -- . . .
+ -- if Case_Guard_N then
+ -- Flag_N := True;
+ -- Count := Count + 1;
+ -- end if;
- Flag := Make_Temporary (Loc, 'F');
- Flag_Decl := Declaration_Of (Flag);
+ -- -- Emit errors depending on the number of case guards that
+ -- -- evaluated to True.
- Prepend_To (Decls, Flag_Decl);
- Analyze (Flag_Decl);
+ -- if Count = 0 then
+ -- raise Assertion_Error with "xxx contract cases incomplete";
+ -- <or>
+ -- Flag_N+1 := True; -- when "others" present
- -- The flag is set when the case guard is evaluated to True
- -- if Case_Guard then
- -- Flag := True;
- -- Count := Count + 1;
- -- end if;
+ -- elsif Count > 1 then
+ -- declare
+ -- Str0 : constant String :=
+ -- "contract cases overlap for subprogram ABC";
+ -- Str1 : constant String :=
+ -- (if Flag_1 then
+ -- Str0 & "case guard at xxx evaluates to True"
+ -- else Str0);
+ -- StrN : constant String :=
+ -- (if Flag_N then
+ -- StrN-1 & "case guard at xxx evaluates to True"
+ -- else StrN-1);
+ -- begin
+ -- raise Assertion_Error with StrN;
+ -- end;
+ -- end if;
- If_Stmt :=
- Make_Implicit_If_Statement (CCs,
- Condition => Relocate_Node (Case_Guard),
- Then_Statements => New_List (
- Set (Flag),
- Increment (Count)));
+ -- -- Evaluate all attribute 'Old prefixes found in the selected
+ -- -- consequence.
- Append_To (Decls, If_Stmt);
- Analyze (If_Stmt);
+ -- if Flag_1 then
+ -- Pref_1 := <prefix of 'Old found in Consequence_1>
+ -- . . .
+ -- elsif Flag_N then
+ -- Pref_M := <prefix of 'Old found in Consequence_N>
+ -- end if;
- -- Check whether this case guard overlaps with another one
+ -- procedure _Postconditions is
+ -- begin
+ -- <postconditions (if any)>
- if Multiple_PCs and Exception_Extra_Info then
- Case_Guard_Error
- (Decls => Error_Decls,
- Flag => Flag,
- Error_Loc => Sloc (Case_Guard),
- Msg => Msg_Str);
- end if;
+ -- if Flag_1 and then not Consequence_1 then
+ -- raise Assertion_Error with "failed contract case at xxx";
+ -- end if;
+ -- . . .
+ -- if Flag_N[+1] and then not Consequence_N[+1] then
+ -- raise Assertion_Error with "failed contract case at xxx";
+ -- end if;
+ -- end _Postconditions;
+ -- begin
+ -- . . .
+ -- end S;
- -- Inspect the consequence and perform special expansion of any
- -- attribute 'Old and 'Result references found within.
+ procedure Expand_Pragma_Contract_Cases
+ (CCs : Node_Id;
+ Subp_Id : Entity_Id;
+ Decls : List_Id;
+ Stmts : in out List_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (CCs);
- Expand_Attributes_In_Consequence
- (Decls => Decls,
- Evals => Old_Evals,
- Flag => Flag,
- Conseq => Conseq);
+ procedure Case_Guard_Error
+ (Decls : List_Id;
+ Flag : Entity_Id;
+ Error_Loc : Source_Ptr;
+ Msg : in out Entity_Id);
+ -- Given a declarative list Decls, status flag Flag, the location of the
+ -- error and a string Msg, construct the following check:
+ -- Msg : constant String :=
+ -- (if Flag then
+ -- Msg & "case guard at Error_Loc evaluates to True"
+ -- else Msg);
+ -- The resulting code is added to Decls
- -- The corresponding consequence of the case guard which evaluated
- -- to True must hold on exit from the subprogram.
+ procedure Consequence_Error
+ (Checks : in out Node_Id;
+ Flag : Entity_Id;
+ Conseq : Node_Id);
+ -- Given an if statement Checks, status flag Flag and a consequence
+ -- Conseq, construct the following check:
+ -- [els]if Flag and then not Conseq then
+ -- raise Assertion_Error
+ -- with "failed contract case at Sloc (Conseq)";
+ -- [end if;]
+ -- The resulting code is added to Checks
- Consequence_Error
- (Checks => Conseq_Checks,
- Flag => Flag,
- Conseq => Conseq);
- end if;
+ function Declaration_Of (Id : Entity_Id) return Node_Id;
+ -- Given the entity Id of a boolean flag, generate:
+ -- Id : Boolean := False;
- Next (Post_Case);
- end loop;
+ procedure Expand_Attributes_In_Consequence
+ (Decls : List_Id;
+ Evals : in out Node_Id;
+ Flag : Entity_Id;
+ Conseq : Node_Id);
+ -- Perform specialized expansion of all attribute 'Old references found
+ -- in consequence Conseq such that at runtime only prefixes coming from
+ -- the selected consequence are evaluated. Similarly expand attribute
+ -- 'Result references by replacing them with identifier _result which
+ -- resolves to the sole formal parameter of procedure _Postconditions.
+ -- Any temporaries generated in the process are added to declarations
+ -- Decls. Evals is a complex if statement tasked with the evaluation of
+ -- all prefixes coming from a single selected consequence. Flag is the
+ -- corresponding case guard flag. Conseq is the consequence expression.
- -- Raise Assertion_Error when none of the case guards evaluate to True.
- -- The only exception is when we have "others", in which case there is
- -- no error because "others" acts as a default True.
+ function Increment (Id : Entity_Id) return Node_Id;
+ -- Given the entity Id of a numerical variable, generate:
+ -- Id := Id + 1;
- -- Generate:
- -- Flag := True;
+ function Set (Id : Entity_Id) return Node_Id;
+ -- Given the entity Id of a boolean variable, generate:
+ -- Id := True;
- if Present (Others_Flag) then
- CG_Stmts := New_List (Set (Others_Flag));
+ ----------------------
+ -- Case_Guard_Error --
+ ----------------------
- -- Generate:
- -- raise Assertion_Error with "xxx contract cases incomplete";
+ procedure Case_Guard_Error
+ (Decls : List_Id;
+ Flag : Entity_Id;
+ Error_Loc : Source_Ptr;
+ Msg : in out Entity_Id)
+ is
+ New_Line : constant Character := Character'Val (10);
+ New_Msg : constant Entity_Id := Make_Temporary (Loc, 'S');
- else
+ begin
Start_String;
- Store_String_Chars (Build_Location_String (Loc));
- Store_String_Chars (" contract cases incomplete");
-
- CG_Stmts := New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc, End_String))));
- end if;
+ Store_String_Char (New_Line);
+ Store_String_Chars (" case guard at ");
+ Store_String_Chars (Build_Location_String (Error_Loc));
+ Store_String_Chars (" evaluates to True");
- CG_Checks :=
- Make_Implicit_If_Statement (CCs,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => New_Occurrence_Of (Count, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 0)),
- Then_Statements => CG_Stmts);
+ -- Generate:
+ -- New_Msg : constant String :=
+ -- (if Flag then
+ -- Msg & "case guard at Error_Loc evaluates to True"
+ -- else Msg);
- -- Detect a possible failure due to several case guards evaluating to
- -- True.
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => New_Msg,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression =>
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+ New_Occurrence_Of (Flag, Loc),
- -- Generate:
- -- elsif Count > 0 then
- -- declare
- -- <Error_Decls>
- -- begin
- -- raise Assertion_Error with <Msg_Str>;
- -- end if;
+ Make_Op_Concat (Loc,
+ Left_Opnd => New_Occurrence_Of (Msg, Loc),
+ Right_Opnd => Make_String_Literal (Loc, End_String)),
- if Multiple_PCs then
- Set_Elsif_Parts (CG_Checks, New_List (
- Make_Elsif_Part (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => New_Occurrence_Of (Count, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)),
+ New_Occurrence_Of (Msg, Loc)))));
- Then_Statements => New_List (
- Make_Block_Statement (Loc,
- Declarations => Error_Decls,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (
- New_Occurrence_Of (Msg_Str, Loc))))))))));
- end if;
+ Msg := New_Msg;
+ end Case_Guard_Error;
- Append_To (Decls, CG_Checks);
- Analyze (CG_Checks);
+ -----------------------
+ -- Consequence_Error --
+ -----------------------
- -- Once all case guards are evaluated and checked, evaluate any prefixes
- -- of attribute 'Old founds in the selected consequence.
+ procedure Consequence_Error
+ (Checks : in out Node_Id;
+ Flag : Entity_Id;
+ Conseq : Node_Id)
+ is
+ Cond : Node_Id;
+ Error : Node_Id;
- if Present (Old_Evals) then
- Append_To (Decls, Old_Evals);
- Analyze (Old_Evals);
- end if;
+ begin
+ -- Generate:
+ -- Flag and then not Conseq
- -- Raise Assertion_Error when the corresponding consequence of a case
- -- guard that evaluated to True fails.
+ Cond :=
+ Make_And_Then (Loc,
+ Left_Opnd => New_Occurrence_Of (Flag, Loc),
+ Right_Opnd =>
+ Make_Op_Not (Loc,
+ Right_Opnd => Relocate_Node (Conseq)));
- if No (Stmts) then
- Stmts := New_List;
- end if;
+ -- Generate:
+ -- raise Assertion_Error
+ -- with "failed contract case at Sloc (Conseq)";
- Append_To (Stmts, Conseq_Checks);
- end Expand_Contract_Cases;
+ Start_String;
+ Store_String_Chars ("failed contract case at ");
+ Store_String_Chars (Build_Location_String (Sloc (Conseq)));
- ---------------------
- -- Expand_N_Pragma --
- ---------------------
+ Error :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (
+ Make_String_Literal (Loc, End_String)));
- procedure Expand_N_Pragma (N : Node_Id) is
- Pname : constant Name_Id := Pragma_Name (N);
+ if No (Checks) then
+ Checks :=
+ Make_Implicit_If_Statement (CCs,
+ Condition => Cond,
+ Then_Statements => New_List (Error));
- begin
- -- Rewrite pragma ignored by Ignore_Pragma to null statement, so that/
- -- back end or the expander here does not get over-enthusiastic and
- -- start processing such a pragma!
+ else
+ if No (Elsif_Parts (Checks)) then
+ Set_Elsif_Parts (Checks, New_List);
+ end if;
- if Get_Name_Table_Boolean3 (Pname) then
- Rewrite (N, Make_Null_Statement (Sloc (N)));
- return;
- end if;
+ Append_To (Elsif_Parts (Checks),
+ Make_Elsif_Part (Loc,
+ Condition => Cond,
+ Then_Statements => New_List (Error)));
+ end if;
+ end Consequence_Error;
- -- Note: we may have a pragma whose Pragma_Identifier field is not a
- -- recognized pragma, and we must ignore it at this stage.
+ --------------------
+ -- Declaration_Of --
+ --------------------
- if Is_Pragma_Name (Pname) then
- case Get_Pragma_Id (Pname) is
+ function Declaration_Of (Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Id,
+ Object_Definition => New_Occurrence_Of (Standard_Boolean, Loc),
+ Expression => New_Occurrence_Of (Standard_False, Loc));
+ end Declaration_Of;
- -- Pragmas requiring special expander action
+ --------------------------------------
+ -- Expand_Attributes_In_Consequence --
+ --------------------------------------
- when Pragma_Abort_Defer =>
- Expand_Pragma_Abort_Defer (N);
+ procedure Expand_Attributes_In_Consequence
+ (Decls : List_Id;
+ Evals : in out Node_Id;
+ Flag : Entity_Id;
+ Conseq : Node_Id)
+ is
+ Eval_Stmts : List_Id := No_List;
+ -- The evaluation sequence expressed as assignment statements of all
+ -- prefixes of attribute 'Old found in the current consequence.
- when Pragma_Check =>
- Expand_Pragma_Check (N);
+ function Expand_Attributes (N : Node_Id) return Traverse_Result;
+ -- Determine whether an arbitrary node denotes attribute 'Old or
+ -- 'Result and if it does, perform all expansion-related actions.
- when Pragma_Common_Object =>
- Expand_Pragma_Common_Object (N);
+ -----------------------
+ -- Expand_Attributes --
+ -----------------------
- when Pragma_Import =>
- Expand_Pragma_Import_Or_Interface (N);
+ function Expand_Attributes (N : Node_Id) return Traverse_Result is
+ Decl : Node_Id;
+ Pref : Node_Id;
+ Temp : Entity_Id;
- when Pragma_Inspection_Point =>
- Expand_Pragma_Inspection_Point (N);
+ begin
+ -- Attribute 'Old
- when Pragma_Interface =>
- Expand_Pragma_Import_Or_Interface (N);
+ if Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) = Name_Old
+ then
+ Pref := Prefix (N);
+ Temp := Make_Temporary (Loc, 'T', Pref);
+ Set_Etype (Temp, Etype (Pref));
- when Pragma_Interrupt_Priority =>
- Expand_Pragma_Interrupt_Priority (N);
+ -- Generate a temporary to capture the value of the prefix:
+ -- Temp : <Pref type>;
+ -- Place that temporary at the beginning of declarations, to
+ -- prevent anomalies in the GNATprove flow-analysis pass in
+ -- the precondition procedure that follows.
- when Pragma_Loop_Variant =>
- Expand_Pragma_Loop_Variant (N);
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Pref), Loc));
+ Set_No_Initialization (Decl);
- when Pragma_Psect_Object =>
- Expand_Pragma_Psect_Object (N);
+ Prepend_To (Decls, Decl);
+ Analyze (Decl);
- when Pragma_Relative_Deadline =>
- Expand_Pragma_Relative_Deadline (N);
+ -- Evaluate the prefix, generate:
+ -- Temp := <Pref>;
- when Pragma_Suppress_Initialization =>
- Expand_Pragma_Suppress_Initialization (N);
+ if No (Eval_Stmts) then
+ Eval_Stmts := New_List;
+ end if;
- -- All other pragmas need no expander action
+ Append_To (Eval_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Temp, Loc),
+ Expression => Pref));
- when others => null;
- end case;
- end if;
+ -- Ensure that the prefix is valid
- end Expand_N_Pragma;
+ if Validity_Checks_On and then Validity_Check_Operands then
+ Ensure_Valid (Pref);
+ end if;
- -------------------------------
- -- Expand_Pragma_Abort_Defer --
- -------------------------------
+ -- Replace the original attribute 'Old by a reference to the
+ -- generated temporary.
- -- An Abort_Defer pragma appears as the first statement in a handled
- -- statement sequence (right after the begin). It defers aborts for
- -- the entire statement sequence, but not for any declarations or
- -- handlers (if any) associated with this statement sequence.
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
- -- The transformation is to transform
+ -- Attribute 'Result
- -- pragma Abort_Defer;
- -- statements;
+ elsif Is_Attribute_Result (N) then
+ Rewrite (N, Make_Identifier (Loc, Name_uResult));
+ end if;
- -- into
+ return OK;
+ end Expand_Attributes;
- -- begin
- -- Abort_Defer.all;
- -- statements
- -- exception
- -- when all others =>
- -- Abort_Undefer.all;
- -- raise;
- -- at end
- -- Abort_Undefer_Direct;
- -- end;
+ procedure Expand_Attributes_In is
+ new Traverse_Proc (Expand_Attributes);
- procedure Expand_Pragma_Abort_Defer (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
- Stm : Node_Id;
- Stms : List_Id;
- HSS : Node_Id;
- Blk : constant Entity_Id :=
- New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
- AUD : constant Entity_Id := RTE (RE_Abort_Undefer_Direct);
+ -- Start of processing for Expand_Attributes_In_Consequence
- begin
- Stms := New_List (Build_Runtime_Call (Loc, RE_Abort_Defer));
- loop
- Stm := Remove_Next (N);
- exit when No (Stm);
- Append (Stm, Stms);
- end loop;
+ begin
+ -- Inspect the consequence and expand any attribute 'Old and 'Result
+ -- references found within.
- HSS :=
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => Stms,
- At_End_Proc => New_Occurrence_Of (AUD, Loc));
+ Expand_Attributes_In (Conseq);
- -- Present the Abort_Undefer_Direct function to the backend so that it
- -- can inline the call to the function.
+ -- The consequence does not contain any attribute 'Old references
- Add_Inlined_Body (AUD, N);
+ if No (Eval_Stmts) then
+ return;
+ end if;
- Rewrite (N,
- Make_Block_Statement (Loc,
- Handled_Statement_Sequence => HSS));
+ -- Augment the machinery to trigger the evaluation of all prefixes
+ -- found in the step above. If Eval is empty, then this is the first
+ -- consequence to yield expansion of 'Old. Generate:
- Set_Scope (Blk, Current_Scope);
- Set_Etype (Blk, Standard_Void_Type);
- Set_Identifier (N, New_Occurrence_Of (Blk, Sloc (N)));
- Expand_At_End_Handler (HSS, Blk);
- Analyze (N);
- end Expand_Pragma_Abort_Defer;
+ -- if Flag then
+ -- <evaluation statements>
+ -- end if;
- --------------------------
- -- Expand_Pragma_Check --
- --------------------------
+ if No (Evals) then
+ Evals :=
+ Make_Implicit_If_Statement (CCs,
+ Condition => New_Occurrence_Of (Flag, Loc),
+ Then_Statements => Eval_Stmts);
- procedure Expand_Pragma_Check (N : Node_Id) is
- Cond : constant Node_Id := Arg2 (N);
- Nam : constant Name_Id := Chars (Arg1 (N));
- Msg : Node_Id;
+ -- Otherwise generate:
+ -- elsif Flag then
+ -- <evaluation statements>
+ -- end if;
- Loc : constant Source_Ptr := Sloc (First_Node (Cond));
- -- Source location used in the case of a failed assertion: point to the
- -- failing condition, not Loc. Note that the source location of the
- -- expression is not usually the best choice here, because it points to
- -- the location of the topmost tree node, which may be an operator in
- -- the middle of the source text of the expression. For example, it gets
- -- located on the last AND keyword in a chain of boolean expressiond
- -- AND'ed together. It is best to put the message on the first character
- -- of the condition, which is the effect of the First_Node call here.
- -- This source location is used to build the default exception message,
- -- and also as the sloc of the call to the runtime subprogram raising
- -- Assert_Failure, so that coverage analysis tools can relate the
- -- call to the failed check.
+ else
+ if No (Elsif_Parts (Evals)) then
+ Set_Elsif_Parts (Evals, New_List);
+ end if;
- begin
- -- Nothing to do if pragma is ignored
+ Append_To (Elsif_Parts (Evals),
+ Make_Elsif_Part (Loc,
+ Condition => New_Occurrence_Of (Flag, Loc),
+ Then_Statements => Eval_Stmts));
+ end if;
+ end Expand_Attributes_In_Consequence;
- if Is_Ignored (N) then
- return;
- end if;
+ ---------------
+ -- Increment --
+ ---------------
- -- Since this check is active, we rewrite the pragma into a
- -- corresponding if statement, and then analyze the statement
+ function Increment (Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Id, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Occurrence_Of (Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+ end Increment;
- -- The normal case expansion transforms:
+ ---------
+ -- Set --
+ ---------
- -- pragma Check (name, condition [,message]);
+ function Set (Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of (Id, Loc),
+ Expression => New_Occurrence_Of (Standard_True, Loc));
+ end Set;
- -- into
+ -- Local variables
- -- if not condition then
- -- System.Assertions.Raise_Assert_Failure (Str);
- -- end if;
+ Aggr : constant Node_Id :=
+ Expression (First
+ (Pragma_Argument_Associations (CCs)));
+ Case_Guard : Node_Id;
+ CG_Checks : Node_Id;
+ CG_Stmts : List_Id;
+ Conseq : Node_Id;
+ Conseq_Checks : Node_Id := Empty;
+ Count : Entity_Id;
+ Count_Decl : Node_Id;
+ Error_Decls : List_Id;
+ Flag : Entity_Id;
+ Flag_Decl : Node_Id;
+ If_Stmt : Node_Id;
+ Msg_Str : Entity_Id;
+ Multiple_PCs : Boolean;
+ Old_Evals : Node_Id := Empty;
+ Others_Decl : Node_Id;
+ Others_Flag : Entity_Id := Empty;
+ Post_Case : Node_Id;
- -- where Str is the message if one is present, or the default of
- -- name failed at file:line if no message is given (the "name failed
- -- at" is omitted for name = Assertion, since it is redundant, given
- -- that the name of the exception is Assert_Failure.)
+ -- Start of processing for Expand_Pragma_Contract_Cases
- -- Also, instead of "XXX failed at", we generate slightly
- -- different messages for some of the contract assertions (see
- -- code below for details).
+ begin
+ -- Do nothing if pragma is not enabled. If pragma is disabled, it has
+ -- already been rewritten as a Null statement.
- -- An alternative expansion is used when the No_Exception_Propagation
- -- restriction is active and there is a local Assert_Failure handler.
- -- This is not a common combination of circumstances, but it occurs in
- -- the context of Aunit and the zero footprint profile. In this case we
- -- generate:
+ if Is_Ignored (CCs) then
+ return;
- -- if not condition then
- -- raise Assert_Failure;
- -- end if;
+ -- Guard against malformed contract cases
- -- This will then be transformed into a goto, and the local handler will
- -- be able to handle the assert error (which would not be the case if a
- -- call is made to the Raise_Assert_Failure procedure).
+ elsif Nkind (Aggr) /= N_Aggregate then
+ return;
+ end if;
- -- We also generate the direct raise if the Suppress_Exception_Locations
- -- is active, since we don't want to generate messages in this case.
+ Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1;
- -- Note that the reason we do not always generate a direct raise is that
- -- the form in which the procedure is called allows for more efficient
- -- breakpointing of assertion errors.
+ -- Create the counter which tracks the number of case guards that
+ -- evaluate to True.
- -- Generate the appropriate if statement. Note that we consider this to
- -- be an explicit conditional in the source, not an implicit if, so we
- -- do not call Make_Implicit_If_Statement.
+ -- Count : Natural := 0;
- -- Case where we generate a direct raise
+ Count := Make_Temporary (Loc, 'C');
+ Count_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Count,
+ Object_Definition => New_Occurrence_Of (Standard_Natural, Loc),
+ Expression => Make_Integer_Literal (Loc, 0));
- if ((Debug_Flag_Dot_G
- or else Restriction_Active (No_Exception_Propagation))
- and then Present (Find_Local_Handler (RTE (RE_Assert_Failure), N)))
- or else (Opt.Exception_Locations_Suppressed and then No (Arg3 (N)))
- then
- Rewrite (N,
- Make_If_Statement (Loc,
- Condition => Make_Op_Not (Loc, Right_Opnd => Cond),
- Then_Statements => New_List (
- Make_Raise_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Assert_Failure), Loc)))));
+ Prepend_To (Decls, Count_Decl);
+ Analyze (Count_Decl);
- -- Case where we call the procedure
+ -- Create the base error message for multiple overlapping case guards
- else
- -- If we have a message given, use it
+ -- Msg_Str : constant String :=
+ -- "contract cases overlap for subprogram Subp_Id";
- if Present (Arg3 (N)) then
- Msg := Get_Pragma_Arg (Arg3 (N));
+ if Multiple_PCs then
+ Msg_Str := Make_Temporary (Loc, 'S');
- -- Here we have no string, so prepare one
+ Start_String;
+ Store_String_Chars ("contract cases overlap for subprogram ");
+ Store_String_Chars (Get_Name_String (Chars (Subp_Id)));
- else
- declare
- Loc_Str : constant String := Build_Location_String (Loc);
+ Error_Decls := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Msg_Str,
+ Constant_Present => True,
+ Object_Definition => New_Occurrence_Of (Standard_String, Loc),
+ Expression => Make_String_Literal (Loc, End_String)));
+ end if;
- begin
- Name_Len := 0;
+ -- Process individual post cases
- -- For Assert, we just use the location
+ Post_Case := First (Component_Associations (Aggr));
+ while Present (Post_Case) loop
+ Case_Guard := First (Choices (Post_Case));
+ Conseq := Expression (Post_Case);
- if Nam = Name_Assert then
- null;
+ -- The "others" choice requires special processing
- -- For predicate, we generate the string "predicate failed
- -- at yyy". We prefer all lower case for predicate.
+ if Nkind (Case_Guard) = N_Others_Choice then
+ Others_Flag := Make_Temporary (Loc, 'F');
+ Others_Decl := Declaration_Of (Others_Flag);
- elsif Nam = Name_Predicate then
- Add_Str_To_Name_Buffer ("predicate failed at ");
+ Prepend_To (Decls, Others_Decl);
+ Analyze (Others_Decl);
- -- For special case of Precondition/Postcondition the string is
- -- "failed xx from yy" where xx is precondition/postcondition
- -- in all lower case. The reason for this different wording is
- -- that the failure is not at the point of occurrence of the
- -- pragma, unlike the other Check cases.
+ -- Check possible overlap between a case guard and "others"
- elsif Nam_In (Nam, Name_Precondition, Name_Postcondition) then
- Get_Name_String (Nam);
- Insert_Str_In_Name_Buffer ("failed ", 1);
- Add_Str_To_Name_Buffer (" from ");
+ if Multiple_PCs and Exception_Extra_Info then
+ Case_Guard_Error
+ (Decls => Error_Decls,
+ Flag => Others_Flag,
+ Error_Loc => Sloc (Case_Guard),
+ Msg => Msg_Str);
+ end if;
- -- For special case of Invariant, the string is "failed
- -- invariant from yy", to be consistent with the string that is
- -- generated for the aspect case (the code later on checks for
- -- this specific string to modify it in some cases, so this is
- -- functionally important).
+ -- Inspect the consequence and perform special expansion of any
+ -- attribute 'Old and 'Result references found within.
- elsif Nam = Name_Invariant then
- Add_Str_To_Name_Buffer ("failed invariant from ");
+ Expand_Attributes_In_Consequence
+ (Decls => Decls,
+ Evals => Old_Evals,
+ Flag => Others_Flag,
+ Conseq => Conseq);
- -- For all other checks, the string is "xxx failed at yyy"
- -- where xxx is the check name with current source file casing.
+ -- Check the corresponding consequence of "others"
- else
- Get_Name_String (Nam);
- Set_Casing (Identifier_Casing (Current_Source_File));
- Add_Str_To_Name_Buffer (" failed at ");
- end if;
+ Consequence_Error
+ (Checks => Conseq_Checks,
+ Flag => Others_Flag,
+ Conseq => Conseq);
- -- In all cases, add location string
+ -- Regular post case
- Add_Str_To_Name_Buffer (Loc_Str);
+ else
+ -- Create the flag which tracks the state of its associated case
+ -- guard.
- -- Build the message
+ Flag := Make_Temporary (Loc, 'F');
+ Flag_Decl := Declaration_Of (Flag);
- Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
- end;
- end if;
+ Prepend_To (Decls, Flag_Decl);
+ Analyze (Flag_Decl);
- -- Now rewrite as an if statement
+ -- The flag is set when the case guard is evaluated to True
+ -- if Case_Guard then
+ -- Flag := True;
+ -- Count := Count + 1;
+ -- end if;
- Rewrite (N,
- Make_If_Statement (Loc,
- Condition => Make_Op_Not (Loc, Right_Opnd => Cond),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (Relocate_Node (Msg))))));
- end if;
+ If_Stmt :=
+ Make_Implicit_If_Statement (CCs,
+ Condition => Relocate_Node (Case_Guard),
+ Then_Statements => New_List (
+ Set (Flag),
+ Increment (Count)));
- Analyze (N);
+ Append_To (Decls, If_Stmt);
+ Analyze (If_Stmt);
- -- If new condition is always false, give a warning
+ -- Check whether this case guard overlaps with another one
- if Warn_On_Assertion_Failure
- and then Nkind (N) = N_Procedure_Call_Statement
- and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure)
- then
- -- If original condition was a Standard.False, we assume that this is
- -- indeed intended to raise assert error and no warning is required.
+ if Multiple_PCs and Exception_Extra_Info then
+ Case_Guard_Error
+ (Decls => Error_Decls,
+ Flag => Flag,
+ Error_Loc => Sloc (Case_Guard),
+ Msg => Msg_Str);
+ end if;
- if Is_Entity_Name (Original_Node (Cond))
- and then Entity (Original_Node (Cond)) = Standard_False
- then
- return;
+ -- Inspect the consequence and perform special expansion of any
+ -- attribute 'Old and 'Result references found within.
- elsif Nam = Name_Assert then
- Error_Msg_N ("?A?assertion will fail at run time", N);
- else
+ Expand_Attributes_In_Consequence
+ (Decls => Decls,
+ Evals => Old_Evals,
+ Flag => Flag,
+ Conseq => Conseq);
- Error_Msg_N ("?A?check will fail at run time", N);
+ -- The corresponding consequence of the case guard which evaluated
+ -- to True must hold on exit from the subprogram.
+
+ Consequence_Error
+ (Checks => Conseq_Checks,
+ Flag => Flag,
+ Conseq => Conseq);
end if;
- end if;
- end Expand_Pragma_Check;
- ---------------------------------
- -- Expand_Pragma_Common_Object --
- ---------------------------------
+ Next (Post_Case);
+ end loop;
- -- Use a machine attribute to replicate semantic effect in DEC Ada
+ -- Raise Assertion_Error when none of the case guards evaluate to True.
+ -- The only exception is when we have "others", in which case there is
+ -- no error because "others" acts as a default True.
- -- pragma Machine_Attribute (intern_name, "common_object", extern_name);
+ -- Generate:
+ -- Flag := True;
- -- For now we do nothing with the size attribute ???
+ if Present (Others_Flag) then
+ CG_Stmts := New_List (Set (Others_Flag));
- -- Note: Psect_Object shares this processing
+ -- Generate:
+ -- raise Assertion_Error with "xxx contract cases incomplete";
- procedure Expand_Pragma_Common_Object (N : Node_Id) is
- Loc : constant Source_Ptr := Sloc (N);
+ else
+ Start_String;
+ Store_String_Chars (Build_Location_String (Loc));
+ Store_String_Chars (" contract cases incomplete");
- Internal : constant Node_Id := Arg1 (N);
- External : constant Node_Id := Arg2 (N);
+ CG_Stmts := New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (
+ Make_String_Literal (Loc, End_String))));
+ end if;
- Psect : Node_Id;
- -- Psect value upper cased as string literal
+ CG_Checks :=
+ Make_Implicit_If_Statement (CCs,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Occurrence_Of (Count, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
+ Then_Statements => CG_Stmts);
- Iloc : constant Source_Ptr := Sloc (Internal);
- Eloc : constant Source_Ptr := Sloc (External);
- Ploc : Source_Ptr;
+ -- Detect a possible failure due to several case guards evaluating to
+ -- True.
- begin
- -- Acquire Psect value and fold to upper case
+ -- Generate:
+ -- elsif Count > 0 then
+ -- declare
+ -- <Error_Decls>
+ -- begin
+ -- raise Assertion_Error with <Msg_Str>;
+ -- end if;
- if Present (External) then
- if Nkind (External) = N_String_Literal then
- String_To_Name_Buffer (Strval (External));
- else
- Get_Name_String (Chars (External));
- end if;
+ if Multiple_PCs then
+ Set_Elsif_Parts (CG_Checks, New_List (
+ Make_Elsif_Part (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => New_Occurrence_Of (Count, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)),
- Set_All_Upper_Case;
+ Then_Statements => New_List (
+ Make_Block_Statement (Loc,
+ Declarations => Error_Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (
+ New_Occurrence_Of (Msg_Str, Loc))))))))));
+ end if;
- Psect :=
- Make_String_Literal (Eloc, Strval => String_From_Name_Buffer);
+ Append_To (Decls, CG_Checks);
+ Analyze (CG_Checks);
- else
- Get_Name_String (Chars (Internal));
- Set_All_Upper_Case;
- Psect :=
- Make_String_Literal (Iloc, Strval => String_From_Name_Buffer);
+ -- Once all case guards are evaluated and checked, evaluate any prefixes
+ -- of attribute 'Old founds in the selected consequence.
+
+ if Present (Old_Evals) then
+ Append_To (Decls, Old_Evals);
+ Analyze (Old_Evals);
end if;
- Ploc := Sloc (Psect);
+ -- Raise Assertion_Error when the corresponding consequence of a case
+ -- guard that evaluated to True fails.
- -- Insert the pragma
+ if No (Stmts) then
+ Stmts := New_List;
+ end if;
- Insert_After_And_Analyze (N,
- Make_Pragma (Loc,
- Chars => Name_Machine_Attribute,
- Pragma_Argument_Associations => New_List (
- Make_Pragma_Argument_Association (Iloc,
- Expression => New_Copy_Tree (Internal)),
- Make_Pragma_Argument_Association (Eloc,
- Expression =>
- Make_String_Literal (Sloc => Ploc, Strval => "common_object")),
- Make_Pragma_Argument_Association (Ploc,
- Expression => New_Copy_Tree (Psect)))));
- end Expand_Pragma_Common_Object;
+ Append_To (Stmts, Conseq_Checks);
+ end Expand_Pragma_Contract_Cases;
---------------------------------------
-- Expand_Pragma_Import_Or_Interface --
---------------------------------------
procedure Expand_Pragma_Import_Or_Interface (N : Node_Id) is
- Def_Id : Entity_Id;
+ Def_Id : Entity_Id;
begin
-- In Relaxed_RM_Semantics, support old Ada 83 style:
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Make_Identifier (Loc, Name_Initial_Condition)),
-
Make_Pragma_Argument_Association (Loc,
Expression => New_Copy_Tree (Expr))));
-- Are there other pragmas that may require this ???
Assoc := First (Pragma_Argument_Associations (N));
-
while Present (Assoc) loop
Expand (Expression (Assoc));
Next (Assoc);
procedure Expand_Pragma_Interrupt_Priority (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
-
begin
if No (Pragma_Argument_Associations (N)) then
Set_Pragma_Argument_Associations (N, New_List (
Make_Pragma_Argument_Association (Loc,
Expression =>
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (RTE (RE_Interrupt_Priority), Loc),
Attribute_Name => Name_Last))));
end if;
Last_Var : constant Node_Id := Last (Pragma_Argument_Associations (N));
- Curr_Assign : List_Id := No_List;
- Flag_Id : Entity_Id := Empty;
- If_Stmt : Node_Id := Empty;
- Old_Assign : List_Id := No_List;
+ Curr_Assign : List_Id := No_List;
+ Flag_Id : Entity_Id := Empty;
+ If_Stmt : Node_Id := Empty;
+ Old_Assign : List_Id := No_List;
Loop_Scop : Entity_Id;
Loop_Stmt : Node_Id;
Variant : Node_Id;
Left_Opnd =>
Make_Function_Call (Loc,
New_Occurrence_Of (RTE (RO_RT_To_Duration), Loc),
- New_List (Make_Function_Call (Loc,
- New_Occurrence_Of (RTE (RE_Clock), Loc)))),
+ New_List
+ (Make_Function_Call
+ (Loc, New_Occurrence_Of (RTE (RE_Clock), Loc)))),
Right_Opnd =>
Unchecked_Convert_To (Standard_Duration, Arg1 (N)))))));
projects / gcc.git / commitdiff