[multiple changes]
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. From-SVN: r198292
This commit is contained in:
Arnaud Charlet
parent
7be8338dbc
commit
8b404dac66
@ -1,3 +1,19 @@
|
||||
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
|
||||
|
||||
@ -74,6 +74,7 @@ with Sinfo; use Sinfo;
|
||||
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;
|
||||
@ -4117,6 +4118,476 @@ package body Exp_Ch6 is
|
||||
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 --
|
||||
-------------------------------
|
||||
|
||||
@ -6,7 +6,7 @@
|
||||
-- --
|
||||
-- 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- --
|
||||
@ -71,6 +71,17 @@ package Exp_Ch6 is
|
||||
-- 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
|
||||
|
||||
@ -992,6 +992,7 @@ consideration, the use of these pragmas should be minimized.
|
||||
* Pragma Optimize_Alignment::
|
||||
* Pragma Ordered::
|
||||
* Pragma Overflow_Mode::
|
||||
* Pragma Overriding_Renamings::
|
||||
* Pragma Partition_Elaboration_Policy::
|
||||
* Pragma Passive::
|
||||
* Pragma Persistent_BSS::
|
||||
@ -4698,6 +4699,25 @@ overflow checking, but does not affect the overflow mode.
|
||||
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
|
||||
@ -5205,6 +5225,7 @@ The Rational profile is intended to facilitate porting legacy code that
|
||||
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
|
||||
@ -6814,9 +6835,9 @@ This aspect is equivalent to pragma @code{Depends}.
|
||||
@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 =>
|
||||
@ -6833,9 +6854,13 @@ RATIONAL ::= [-] NUMERIC_LITERAL [/ NUMERIC_LITERAL]
|
||||
@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.
|
||||
@ -6864,15 +6889,19 @@ This aspect is applied to a type, which must be a numeric derived type
|
||||
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
|
||||
@ -6888,9 +6917,7 @@ package @code{System.Dim.Mks}:
|
||||
@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
|
||||
|
||||
@ -11228,11 +11228,6 @@ package body Sem_Ch6 is
|
||||
-- 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
|
||||
@ -11324,468 +11319,6 @@ package body Sem_Ch6 is
|
||||
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 --
|
||||
--------------
|
||||
@ -12288,7 +11821,11 @@ package body Sem_Ch6 is
|
||||
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);
|
||||
|
||||
@ -8909,10 +8909,13 @@ package body Sem_Util is
|
||||
-- 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)
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user