+2013-04-25 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_ch6.adb: Add with and use clause for Stringt.
+ (Expand_Contract_Cases): Moved from sem_ch6. Add formal parameters
+ Decls and Stmts along with comments on their usage.
+ * exp_ch6.ads (Expand_Contract_Cases): Moved from sem_ch6.
+ * sem_ch6.adb (Expand_Contract_Cases): Moved to exp_ch6.
+ (Process_Contract_Cases): Update the call to Expand_Contract_Cases.
+
+2013-04-25 Ed Schonberg <schonberg@adacore.com>
+
+ * gnat_rm.texi: Minor editing, to clarify use of dimension aspects.
+ * sem_util.adb (Is_OK_Variable_For_Out_Formal): Reject an
+ aggregate for a packed type, which may be converted into an
+ unchecked conversion of an object.
+
2013-04-25 Robert Dewar <dewar@adacore.com>
* sem_prag.adb: Minor code reorganization (correct misspelling
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
+with Stringt; use Stringt;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
end if;
end Expand_Call;
+ ---------------------------
+ -- Expand_Contract_Cases --
+ ---------------------------
+
+ -- Pragma Contract_Cases is expanded in the following manner:
+
+ -- subprogram S is
+ -- Flag_1 : Boolean := False;
+ -- . . .
+ -- Flag_N : Boolean := False;
+ -- Flag_N+1 : Boolean := False; -- when "others" present
+ -- Count : Natural := 0;
+
+ -- <preconditions (if any)>
+
+ -- 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;
+
+ -- if Count = 0 then
+ -- raise Assertion_Error with "xxx contract cases incomplete";
+ -- <or>
+ -- Flag_N+1 := True; -- when "others" present
+
+ -- 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;
+
+ -- procedure _Postconditions is
+ -- begin
+ -- <postconditions (if any)>
+
+ -- 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;
+
+ 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);
+
+ 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
+
+ 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
+
+ function Declaration_Of (Id : Entity_Id) return Node_Id;
+ -- Given the entity Id of a boolean flag, generate:
+ -- Id : Boolean := False;
+
+ function Increment (Id : Entity_Id) return Node_Id;
+ -- Given the entity Id of a numerical variable, generate:
+ -- Id := Id + 1;
+
+ function Set (Id : Entity_Id) return Node_Id;
+ -- Given the entity Id of a boolean variable, generate:
+ -- Id := True;
+
+ ----------------------
+ -- Case_Guard_Error --
+ ----------------------
+
+ 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');
+
+ 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");
+
+ -- Generate:
+ -- New_Msg : constant String :=
+ -- (if Flag then
+ -- Msg & "case guard at Error_Loc evaluates to True"
+ -- else Msg);
+
+ Append_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => New_Msg,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_String, Loc),
+ Expression =>
+ Make_If_Expression (Loc,
+ Expressions => New_List (
+ New_Reference_To (Flag, Loc),
+
+ Make_Op_Concat (Loc,
+ Left_Opnd => New_Reference_To (Msg, Loc),
+ Right_Opnd => Make_String_Literal (Loc, End_String)),
+
+ New_Reference_To (Msg, Loc)))));
+
+ Msg := New_Msg;
+ end Case_Guard_Error;
+
+ -----------------------
+ -- Consequence_Error --
+ -----------------------
+
+ procedure Consequence_Error
+ (Checks : in out Node_Id;
+ Flag : Entity_Id;
+ Conseq : Node_Id)
+ is
+ Cond : Node_Id;
+ Error : Node_Id;
+
+ begin
+ -- Generate:
+ -- Flag and then not Conseq
+
+ Cond :=
+ Make_And_Then (Loc,
+ Left_Opnd => New_Reference_To (Flag, Loc),
+ Right_Opnd =>
+ Make_Op_Not (Loc,
+ Right_Opnd => Relocate_Node (Conseq)));
+
+ -- Generate:
+ -- raise Assertion_Error
+ -- with "failed contract case at Sloc (Conseq)";
+
+ Start_String;
+ Store_String_Chars ("failed contract case at ");
+ Store_String_Chars (Build_Location_String (Sloc (Conseq)));
+
+ Error :=
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (
+ Make_String_Literal (Loc, End_String)));
+
+ if No (Checks) then
+ Checks :=
+ Make_If_Statement (Loc,
+ Condition => Cond,
+ Then_Statements => New_List (Error));
+
+ else
+ if No (Elsif_Parts (Checks)) then
+ Set_Elsif_Parts (Checks, New_List);
+ end if;
+
+ Append_To (Elsif_Parts (Checks),
+ Make_Elsif_Part (Loc,
+ Condition => Cond,
+ Then_Statements => New_List (Error)));
+ end if;
+ end Consequence_Error;
+
+ --------------------
+ -- Declaration_Of --
+ --------------------
+
+ function Declaration_Of (Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Id,
+ Object_Definition => New_Reference_To (Standard_Boolean, Loc),
+ Expression => New_Reference_To (Standard_False, Loc));
+ end Declaration_Of;
+
+ ---------------
+ -- Increment --
+ ---------------
+
+ function Increment (Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Id, Loc),
+ Expression =>
+ Make_Op_Add (Loc,
+ Left_Opnd => New_Reference_To (Id, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)));
+ end Increment;
+
+ ---------
+ -- Set --
+ ---------
+
+ function Set (Id : Entity_Id) return Node_Id is
+ begin
+ return
+ Make_Assignment_Statement (Loc,
+ Name => New_Reference_To (Id, Loc),
+ Expression => New_Reference_To (Standard_True, Loc));
+ end Set;
+
+ -- Local variables
+
+ 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;
+ Error_Decls : List_Id;
+ Flag : Entity_Id;
+ Msg_Str : Entity_Id;
+ Multiple_PCs : Boolean;
+ Others_Flag : Entity_Id := Empty;
+ Post_Case : Node_Id;
+
+ -- Start of processing for Expand_Contract_Cases
+
+ begin
+ -- Do nothing if pragma is not enabled. If pragma is disabled, it has
+ -- already been rewritten as a Null statement.
+
+ if Is_Ignored (CCs) then
+ return;
+
+ -- Guard against malformed contract cases
+
+ elsif Nkind (Aggr) /= N_Aggregate then
+ return;
+ end if;
+
+ Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1;
+
+ -- Create the counter which tracks the number of case guards that
+ -- evaluate to True.
+
+ -- Count : Natural := 0;
+
+ Count := Make_Temporary (Loc, 'C');
+
+ Prepend_To (Decls,
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Count,
+ Object_Definition => New_Reference_To (Standard_Natural, Loc),
+ Expression => Make_Integer_Literal (Loc, 0)));
+
+ -- Create the base error message for multiple overlapping case guards
+
+ -- Msg_Str : constant String :=
+ -- "contract cases overlap for subprogram Subp_Id";
+
+ if Multiple_PCs then
+ Msg_Str := Make_Temporary (Loc, 'S');
+
+ Start_String;
+ Store_String_Chars ("contract cases overlap for subprogram ");
+ Store_String_Chars (Get_Name_String (Chars (Subp_Id)));
+
+ Error_Decls := New_List (
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Msg_Str,
+ Constant_Present => True,
+ Object_Definition => New_Reference_To (Standard_String, Loc),
+ Expression => Make_String_Literal (Loc, End_String)));
+ end if;
+
+ -- Process individual post cases
+
+ Post_Case := First (Component_Associations (Aggr));
+ while Present (Post_Case) loop
+ Case_Guard := First (Choices (Post_Case));
+ Conseq := Expression (Post_Case);
+
+ -- The "others" choice requires special processing
+
+ if Nkind (Case_Guard) = N_Others_Choice then
+ Others_Flag := Make_Temporary (Loc, 'F');
+ Prepend_To (Decls, Declaration_Of (Others_Flag));
+
+ -- Check possible overlap between a case guard and "others"
+
+ 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;
+
+ -- Check the corresponding consequence of "others"
+
+ Consequence_Error
+ (Checks => Conseq_Checks,
+ Flag => Others_Flag,
+ Conseq => Conseq);
+
+ -- Regular post case
+
+ else
+ -- Create the flag which tracks the state of its associated case
+ -- guard.
+
+ Flag := Make_Temporary (Loc, 'F');
+ Prepend_To (Decls, Declaration_Of (Flag));
+
+ -- The flag is set when the case guard is evaluated to True
+ -- if Case_Guard then
+ -- Flag := True;
+ -- Count := Count + 1;
+ -- end if;
+
+ Append_To (Decls,
+ Make_If_Statement (Loc,
+ Condition => Relocate_Node (Case_Guard),
+ Then_Statements => New_List (
+ Set (Flag),
+ Increment (Count))));
+
+ -- Check whether this case guard overlaps with another one
+
+ 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;
+
+ -- 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;
+
+ Next (Post_Case);
+ end loop;
+
+ -- 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.
+
+ -- Generate:
+ -- Flag := True;
+
+ if Present (Others_Flag) then
+ CG_Stmts := New_List (Set (Others_Flag));
+
+ -- Generate:
+ -- raise Assertion_Error with "xxx contract cases incomplete";
+
+ else
+ 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_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (
+ Make_String_Literal (Loc, End_String))));
+ end if;
+
+ CG_Checks :=
+ Make_If_Statement (Loc,
+ Condition =>
+ Make_Op_Eq (Loc,
+ Left_Opnd => New_Reference_To (Count, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 0)),
+ Then_Statements => CG_Stmts);
+
+ -- Detect a possible failure due to several case guards evaluating to
+ -- True.
+
+ -- Generate:
+ -- elsif Count > 0 then
+ -- declare
+ -- <Error_Decls>
+ -- begin
+ -- raise Assertion_Error with <Msg_Str>;
+ -- 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_Reference_To (Count, Loc),
+ Right_Opnd => Make_Integer_Literal (Loc, 1)),
+
+ 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_Reference_To
+ (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (
+ New_Reference_To (Msg_Str, Loc))))))))));
+ end if;
+
+ Append_To (Decls, CG_Checks);
+
+ -- Raise Assertion_Error when the corresponding consequence of a case
+ -- guard that evaluated to True fails.
+
+ if No (Stmts) then
+ Stmts := New_List;
+ end if;
+
+ Append_To (Stmts, Conseq_Checks);
+ end Expand_Contract_Cases;
+
-------------------------------
-- Expand_Ctrl_Function_Call --
-------------------------------
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- This procedure contains common processing for Expand_N_Function_Call,
-- Expand_N_Procedure_Statement, and Expand_N_Entry_Call.
+ procedure Expand_Contract_Cases
+ (CCs : Node_Id;
+ Subp_Id : Entity_Id;
+ Decls : List_Id;
+ Stmts : in out List_Id);
+ -- Given pragma Contract_Cases CCs, create the circuitry needed to evaluate
+ -- case guards and trigger consequence expressions. Subp_Id is the related
+ -- subprogram for which the pragma applies. Decls are the declarations of
+ -- Subp_Id's body. All generated code is added to list Stmts. If Stmts is
+ -- empty, a new list is created.
+
procedure Freeze_Subprogram (N : Node_Id);
-- generate the appropriate expansions related to Subprogram freeze
-- nodes (e.g. the filling of the corresponding Dispatch Table for
* Pragma Optimize_Alignment::
* Pragma Ordered::
* Pragma Overflow_Mode::
+* Pragma Overriding_Renamings::
* Pragma Partition_Elaboration_Policy::
* Pragma Passive::
* Pragma Persistent_BSS::
The pragma @code{Unsuppress (Overflow_Check)} unsuppresses (enables)
overflow checking, but does not affect the overflow mode.
+@node Pragma Overriding_Renamings
+@unnumberedsec Pragma Overriding_Renamings
+@findex Overriding_Renamings
+@cindex Rational profile
+@noindent
+Syntax:
+
+@smallexample @c ada
+pragma Overriding_Renamings;
+@end smallexample
+
+@noindent
+
+This is a GNAT pragma to simplify porting legacy code accepted by the Rational
+Ada compiler. In the presence of this pragma, a renaming declaration that
+renames an inherited operation declared in the same scope is legal, even though
+RM 8.3 (15) stipulates that an overridden operation is not visible within the
+declaration of the overriding operation.
+
@node Pragma Partition_Elaboration_Policy
@unnumberedsec Pragma Partition_Elaboration_Policy
@findex Partition_Elaboration_Policy
compiles with the Rational APEX compiler, even when the code includes non-
conforming Ada constructs. The profile enables the following three pragmas:
+
@itemize @bullet
@item pragma Implicit_Packing
@item pragma Overriding_Renamings
@unnumberedsec Aspect Dimension
@findex Dimension
@noindent
-The @code{Dimension} aspect is used to define a system of
-dimensions that will be used in subsequent subtype declarations with
-@code{Dimension} aspects that reference this system. The syntax is:
+The @code{Dimension} aspect is used to specify the dimensions of a given
+subtype of a dimensioned numeric type. The aspect also specifies a symbol
+used when doing formatted output of dimensioned quantities. The syntax is:
@smallexample @c ada
with Dimension =>
@end smallexample
@noindent
-This aspect can only be applied to a subtype where the parent type has
-a @code{Dimension_Systen} aspect. It specifies which units apply to
-the subtype, and the corresponding powers. For examples of the usage
+This aspect can only be applied to a subtype whose parent type has
+a @code{Dimension_Systen} aspect. The aspect must specify values for
+all dimensions of the system. The rational values are the powers of the
+corresponding dimensions that are used by the compiler to verify that
+physical (numeric) computations are dimensionally consistent. For example,
+the computation of a force must result in dimensions (L => 1, M => 1, T => -2).
+For further examples of the usage
of this aspect, see package @code{System.Dim.Mks}.
Note that when the dimensioned type is an integer type, then any
dimension value must be an integer literal.
will represent values within the dimension system. Each @code{DIMENSION}
corresponds to one particular dimension. A maximum of 7 dimensions may
be specified. @code{Unit_Name} is the name of the dimension (for example
-@code{Meter}). @code{Unit_Symbol} is the short hand used for quantities
+@code{Meter}). @code{Unit_Symbol} is the shorthand used for quantities
of this dimension (for example 'm' for Meter). @code{Dim_Symbol} gives
the identification within the dimension system (typically this is a
-single letter, e.g. 'L' standing for length for unit name Meter).
+single letter, e.g. 'L' standing for length for unit name Meter). The
+Unit_Smbol is used in formatted output of dimensioned quantities. The
+Dim_Symbol is used in error messages when numeric operations have
+inconsistent dimensions.
-Although the implementation allows multiple different dimension systems
-to be defined using this aspect, in practice, nearly all usage of the
-dimension system will use the standard definition in the run-time
-package @code{System.Dim.Mks}:
+GNAT provides the standard definition of the International MKS system in
+the run-time package @code{System.Dim.Mks}. You can easily define
+similar packages for cgs units or British units, and define conversion factors
+between values in different systems. The MKS system is characterized by the
+following aspect:
@smallexample @c ada
type Mks_Type is new Long_Long_Float
@end smallexample
@noindent
-which correspond to the standard 7-unit dimension system typically
-used in physical calculations. See section
-"Performing Dimensionality Analysis in GNAT" in the GNAT Users
+See section "Performing Dimensionality Analysis in GNAT" in the GNAT Users
Guide for detailed examples of use of the dimension system.
@node Aspect Favor_Top_Level
-- under the same visibility conditions as for other invariant checks,
-- the type invariant must be applied to the returned value.
- procedure Expand_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id);
- -- Given pragma Contract_Cases CCs, create the circuitry needed to
- -- evaluate case guards and trigger consequence expressions. Subp_Id
- -- denotes the related subprogram.
-
function Grab_PPC (Pspec : Entity_Id := Empty) return Node_Id;
-- Prag contains an analyzed precondition or postcondition pragma. This
-- function copies the pragma, changes it to the corresponding Check
end if;
end Check_Access_Invariants;
- ---------------------------
- -- Expand_Contract_Cases --
- ---------------------------
-
- -- Pragma Contract_Cases is expanded in the following manner:
-
- -- subprogram S is
- -- Flag_1 : Boolean := False;
- -- . . .
- -- Flag_N : Boolean := False;
- -- Flag_N+1 : Boolean := False; -- when "others" present
- -- Count : Natural := 0;
-
- -- <preconditions (if any)>
-
- -- 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;
-
- -- if Count = 0 then
- -- raise Assertion_Error with "xxx contract cases incomplete";
- -- <or>
- -- Flag_N+1 := True; -- when "others" present
-
- -- 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;
-
- -- procedure _Postconditions is
- -- begin
- -- <postconditions (if any)>
-
- -- 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;
-
- procedure Expand_Contract_Cases (CCs : Node_Id; Subp_Id : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (CCs);
-
- 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
-
- 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
-
- function Declaration_Of (Id : Entity_Id) return Node_Id;
- -- Given the entity Id of a boolean flag, generate:
- -- Id : Boolean := False;
-
- function Increment (Id : Entity_Id) return Node_Id;
- -- Given the entity Id of a numerical variable, generate:
- -- Id := Id + 1;
-
- function Set (Id : Entity_Id) return Node_Id;
- -- Given the entity Id of a boolean variable, generate:
- -- Id := True;
-
- ----------------------
- -- Case_Guard_Error --
- ----------------------
-
- 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');
-
- 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");
-
- -- Generate:
- -- New_Msg : constant String :=
- -- (if Flag then
- -- Msg & "case guard at Error_Loc evaluates to True"
- -- else Msg);
-
- Append_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => New_Msg,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Standard_String, Loc),
- Expression =>
- Make_If_Expression (Loc,
- Expressions => New_List (
- New_Reference_To (Flag, Loc),
-
- Make_Op_Concat (Loc,
- Left_Opnd => New_Reference_To (Msg, Loc),
- Right_Opnd => Make_String_Literal (Loc, End_String)),
-
- New_Reference_To (Msg, Loc)))));
-
- Msg := New_Msg;
- end Case_Guard_Error;
-
- -----------------------
- -- Consequence_Error --
- -----------------------
-
- procedure Consequence_Error
- (Checks : in out Node_Id;
- Flag : Entity_Id;
- Conseq : Node_Id)
- is
- Cond : Node_Id;
- Error : Node_Id;
-
- begin
- -- Generate:
- -- Flag and then not Conseq
-
- Cond :=
- Make_And_Then (Loc,
- Left_Opnd => New_Reference_To (Flag, Loc),
- Right_Opnd =>
- Make_Op_Not (Loc,
- Right_Opnd => Relocate_Node (Conseq)));
-
- -- Generate:
- -- raise Assertion_Error
- -- with "failed contract case at Sloc (Conseq)";
-
- Start_String;
- Store_String_Chars ("failed contract case at ");
- Store_String_Chars (Build_Location_String (Sloc (Conseq)));
-
- Error :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc, End_String)));
-
- if No (Checks) then
- Checks :=
- Make_If_Statement (Loc,
- Condition => Cond,
- Then_Statements => New_List (Error));
-
- else
- if No (Elsif_Parts (Checks)) then
- Set_Elsif_Parts (Checks, New_List);
- end if;
-
- Append_To (Elsif_Parts (Checks),
- Make_Elsif_Part (Loc,
- Condition => Cond,
- Then_Statements => New_List (Error)));
- end if;
- end Consequence_Error;
-
- --------------------
- -- Declaration_Of --
- --------------------
-
- function Declaration_Of (Id : Entity_Id) return Node_Id is
- begin
- return
- Make_Object_Declaration (Loc,
- Defining_Identifier => Id,
- Object_Definition =>
- New_Reference_To (Standard_Boolean, Loc),
- Expression =>
- New_Reference_To (Standard_False, Loc));
- end Declaration_Of;
-
- ---------------
- -- Increment --
- ---------------
-
- function Increment (Id : Entity_Id) return Node_Id is
- begin
- return
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Id, Loc),
- Expression =>
- Make_Op_Add (Loc,
- Left_Opnd => New_Reference_To (Id, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)));
- end Increment;
-
- ---------
- -- Set --
- ---------
-
- function Set (Id : Entity_Id) return Node_Id is
- begin
- return
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Id, Loc),
- Expression => New_Reference_To (Standard_True, Loc));
- end Set;
-
- -- Local variables
-
- Aggr : constant Node_Id :=
- Expression (First
- (Pragma_Argument_Associations (CCs)));
- Decls : constant List_Id := Declarations (N);
- Case_Guard : Node_Id;
- CG_Checks : Node_Id;
- CG_Stmts : List_Id;
- Conseq : Node_Id;
- Conseq_Checks : Node_Id := Empty;
- Count : Entity_Id;
- Error_Decls : List_Id;
- Flag : Entity_Id;
- Msg_Str : Entity_Id;
- Multiple_PCs : Boolean;
- Others_Flag : Entity_Id := Empty;
- Post_Case : Node_Id;
-
- -- Start of processing for Expand_Contract_Cases
-
- begin
- -- Do nothing if pragma is not enabled. If pragma is disabled, it has
- -- already been rewritten as a Null statement.
-
- if Is_Ignored (CCs) then
- return;
-
- -- Guard against malformed contract cases
-
- elsif Nkind (Aggr) /= N_Aggregate then
- return;
- end if;
-
- Multiple_PCs := List_Length (Component_Associations (Aggr)) > 1;
-
- -- Create the counter which tracks the number of case guards that
- -- evaluate to True.
-
- -- Count : Natural := 0;
-
- Count := Make_Temporary (Loc, 'C');
-
- Prepend_To (Decls,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Count,
- Object_Definition => New_Reference_To (Standard_Natural, Loc),
- Expression => Make_Integer_Literal (Loc, 0)));
-
- -- Create the base error message for multiple overlapping case
- -- guards.
-
- -- Msg_Str : constant String :=
- -- "contract cases overlap for subprogram Subp_Id";
-
- if Multiple_PCs then
- Msg_Str := Make_Temporary (Loc, 'S');
-
- Start_String;
- Store_String_Chars ("contract cases overlap for subprogram ");
- Store_String_Chars (Get_Name_String (Chars (Subp_Id)));
-
- Error_Decls := New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Msg_Str,
- Constant_Present => True,
- Object_Definition => New_Reference_To (Standard_String, Loc),
- Expression => Make_String_Literal (Loc, End_String)));
- end if;
-
- -- Process individual post cases
-
- Post_Case := First (Component_Associations (Aggr));
- while Present (Post_Case) loop
- Case_Guard := First (Choices (Post_Case));
- Conseq := Expression (Post_Case);
-
- -- The "others" choice requires special processing
-
- if Nkind (Case_Guard) = N_Others_Choice then
- Others_Flag := Make_Temporary (Loc, 'F');
- Prepend_To (Decls, Declaration_Of (Others_Flag));
-
- -- Check possible overlap between a case guard and "others"
-
- 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;
-
- -- Check the corresponding consequence of "others"
-
- Consequence_Error
- (Checks => Conseq_Checks,
- Flag => Others_Flag,
- Conseq => Conseq);
-
- -- Regular post case
-
- else
- -- Create the flag which tracks the state of its associated
- -- case guard.
-
- Flag := Make_Temporary (Loc, 'F');
- Prepend_To (Decls, Declaration_Of (Flag));
-
- -- The flag is set when the case guard is evaluated to True
- -- if Case_Guard then
- -- Flag := True;
- -- Count := Count + 1;
- -- end if;
-
- Append_To (Decls,
- Make_If_Statement (Loc,
- Condition => Relocate_Node (Case_Guard),
- Then_Statements => New_List (
- Set (Flag),
- Increment (Count))));
-
- -- Check whether this case guard overlaps with another one
-
- 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;
-
- -- The corresponding consequence of the case guard which
- -- evaluated to True must hold on exit from the subprogram.
-
- Consequence_Error (Conseq_Checks, Flag, Conseq);
- end if;
-
- Next (Post_Case);
- end loop;
-
- -- 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.
-
- -- Generate:
- -- Flag := True;
-
- if Present (Others_Flag) then
- CG_Stmts := New_List (Set (Others_Flag));
-
- -- Generate:
- -- raise Assertion_Error with "xxx contract cases incomplete";
-
- else
- 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_Reference_To (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (
- Make_String_Literal (Loc, End_String))));
- end if;
-
- CG_Checks :=
- Make_If_Statement (Loc,
- Condition =>
- Make_Op_Eq (Loc,
- Left_Opnd => New_Reference_To (Count, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 0)),
- Then_Statements => CG_Stmts);
-
- -- Detect a possible failure due to several case guards evaluating to
- -- True.
-
- -- Generate:
- -- elsif Count > 0 then
- -- declare
- -- <Error_Decls>
- -- begin
- -- raise Assertion_Error with <Msg_Str>;
- -- 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_Reference_To (Count, Loc),
- Right_Opnd => Make_Integer_Literal (Loc, 1)),
-
- 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_Reference_To
- (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (
- New_Reference_To (Msg_Str, Loc))))))))));
- end if;
-
- Append_To (Decls, CG_Checks);
-
- -- Raise Assertion_Error when the corresponding consequence of a case
- -- guard that evaluated to True fails.
-
- Append_Enabled_Item (Conseq_Checks, Plist);
- end Expand_Contract_Cases;
-
--------------
-- Grab_PPC --
--------------
Prag := Contract_Test_Cases (Contract (Spec));
loop
if Pragma_Name (Prag) = Name_Contract_Cases then
- Expand_Contract_Cases (Prag, Spec_Id);
+ Expand_Contract_Cases
+ (CCs => Prag,
+ Subp_Id => Spec_Id,
+ Decls => Declarations (N),
+ Stmts => Plist);
end if;
Prag := Next_Pragma (Prag);
-- parameters in cases where code generation is unaffected. We tell
-- source unchecked conversions by seeing if they are rewrites of an
-- original Unchecked_Conversion function call, or of an explicit
- -- conversion of a function call.
+ -- conversion of a function call or an aggregate (as may happen in the
+ -- expansion of a packed array aggregate).
elsif Nkind (AV) = N_Unchecked_Type_Conversion then
- if Nkind (Original_Node (AV)) = N_Function_Call then
+ if Nkind_In (Original_Node (AV),
+ N_Function_Call, N_Aggregate)
+ then
return False;
elsif Comes_From_Source (AV)
projects / platform / upstream / linaro-gcc.git / commitdiff