+2011-08-29 Yannick Moy <moy@adacore.com>
+
+ * exp_ch13.adb (Expand_N_Freeze_Entity): Do nothing in Alfa mode.
+ * exp_ch9.adb: Do not expand tasking constructs in Alfa mode.
+ * gnat1drv.adb (Adjust_Global_Switches): Suppress the expansion of
+ tagged types and dispatching calls in Alfa mode.
+
+2011-08-29 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch3.adb (Process_Discriminants): Add missing check to ensure that
+ we do not report an error on an Empty node.
+
+2011-08-29 Geert Bosch <bosch@adacore.com>
+
+ * Makefile.rtl (GNATRTL_NONTASKING_OBJECTS): Add a-nllrar.o,
+ a-nlrear.o and a-nurear.o.
+
+2011-08-29 Robert Dewar <dewar@adacore.com>
+
+ * freeze.adb: Minor code reorganization.
+ Minor reformatting.
+ * sem_util.adb, errout.adb, exp_ch11.adb, a-ngrear.adb, s-gearop.adb,
+ sem_ch6.adb: Minor reformatting
+
+2011-08-29 Tristan Gingold <gingold@adacore.com>
+
+ * s-except.ads, s-except.adb: Provide dummy body.
+
+2011-08-29 Yannick Moy <moy@adacore.com>
+
+ * sem_warn.adb (Within_Postcondition): Take into account the case of
+ an Ensures component in a Test_Case.
+
2011-08-29 Tristan Gingold <gingold@adacore.com>
* s-excdeb.ads, s-excdeb.adb: New files, created from s-except.
a-ngcoty$(objext) \
a-ngelfu$(objext) \
a-ngrear$(objext) \
+ a-nllrar$(objext) \
+ a-nlrear$(objext) \
+ a-nurear$(objext) \
a-nlcefu$(objext) \
a-nlcoty$(objext) \
a-nlelfu$(objext) \
function Is_Non_Zero (X : Real'Base) return Boolean is (X /= 0.0);
procedure Back_Substitute is new Ops.Back_Substitute
- (Scalar => Real'Base,
- Matrix => Real_Matrix,
- Is_Non_Zero => Is_Non_Zero);
+ (Scalar => Real'Base,
+ Matrix => Real_Matrix,
+ Is_Non_Zero => Is_Non_Zero);
function Diagonal is new Ops.Diagonal
- (Scalar => Real'Base,
- Vector => Real_Vector,
- Matrix => Real_Matrix);
+ (Scalar => Real'Base,
+ Vector => Real_Vector,
+ Matrix => Real_Matrix);
procedure Forward_Eliminate is new Ops.Forward_Eliminate
- (Scalar => Real'Base,
- Matrix => Real_Matrix,
- Zero => 0.0,
- One => 1.0);
+ (Scalar => Real'Base,
+ Matrix => Real_Matrix,
+ Zero => 0.0,
+ One => 1.0);
procedure Swap_Column is new Ops.Swap_Column
- (Scalar => Real'Base,
- Matrix => Real_Matrix);
+ (Scalar => Real'Base,
+ Matrix => Real_Matrix);
procedure Transpose is new Ops.Transpose
(Scalar => Real'Base,
-- Sort Values and associated Vectors by decreasing absolute value
procedure Swap (Left, Right : in out Real);
- -- Exchange Left and Right.
+ -- Exchange Left and Right
function Sqrt (X : Real) return Real;
-- Sqrt is implemented locally here, in order to avoid dragging in all of
if not (X > 0.0) then
if X = 0.0 then
return X;
-
else
raise Argument_Error;
end if;
for J in 1 .. 8 loop
Next := (Root + X / Root) / 2.0;
-
exit when Root = Next;
-
Root := Next;
end loop;
---------
function "+" (Right : Real_Vector) return Real_Vector
- renames Instantiations."+";
+ renames Instantiations."+";
function "+" (Right : Real_Matrix) return Real_Matrix
- renames Instantiations."+";
+ renames Instantiations."+";
function "+" (Left, Right : Real_Vector) return Real_Vector
- renames Instantiations."+";
+ renames Instantiations."+";
function "+" (Left, Right : Real_Matrix) return Real_Matrix
- renames Instantiations."+";
+ renames Instantiations."+";
---------
-- "-" --
---------
function "-" (Right : Real_Vector) return Real_Vector
- renames Instantiations."-";
+ renames Instantiations."-";
function "-" (Right : Real_Matrix) return Real_Matrix
- renames Instantiations."-";
+ renames Instantiations."-";
function "-" (Left, Right : Real_Vector) return Real_Vector
- renames Instantiations."-";
+ renames Instantiations."-";
function "-" (Left, Right : Real_Matrix) return Real_Matrix
renames Instantiations."-";
-- Scalar multiplication
function "*" (Left : Real'Base; Right : Real_Vector) return Real_Vector
- renames Instantiations."*";
+ renames Instantiations."*";
function "*" (Left : Real_Vector; Right : Real'Base) return Real_Vector
- renames Instantiations."*";
+ renames Instantiations."*";
function "*" (Left : Real'Base; Right : Real_Matrix) return Real_Matrix
- renames Instantiations."*";
+ renames Instantiations."*";
function "*" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix
- renames Instantiations."*";
+ renames Instantiations."*";
-- Vector multiplication
function "*" (Left, Right : Real_Vector) return Real'Base
- renames Instantiations."*";
+ renames Instantiations."*";
function "*" (Left, Right : Real_Vector) return Real_Matrix
- renames Instantiations."*";
+ renames Instantiations."*";
function "*" (Left : Real_Vector; Right : Real_Matrix) return Real_Vector
- renames Instantiations."*";
+ renames Instantiations."*";
function "*" (Left : Real_Matrix; Right : Real_Vector) return Real_Vector
- renames Instantiations."*";
+ renames Instantiations."*";
-- Matrix Multiplication
function "*" (Left, Right : Real_Matrix) return Real_Matrix
- renames Instantiations."*";
+ renames Instantiations."*";
---------
-- "/" --
---------
function "/" (Left : Real_Vector; Right : Real'Base) return Real_Vector
- renames Instantiations."/";
+ renames Instantiations."/";
function "/" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix
- renames Instantiations."/";
+ renames Instantiations."/";
-----------
-- "abs" --
-----------
function "abs" (Right : Real_Vector) return Real'Base
- renames Instantiations."abs";
+ renames Instantiations."abs";
function "abs" (Right : Real_Vector) return Real_Vector
- renames Instantiations."abs";
+ renames Instantiations."abs";
function "abs" (Right : Real_Matrix) return Real_Matrix
- renames Instantiations."abs";
+ renames Instantiations."abs";
-----------------
-- Determinant --
M : Real_Matrix := A;
B : Real_Matrix (A'Range (1), 1 .. 0);
R : Real'Base;
-
begin
Forward_Eliminate (M, B, R);
-
return R;
end Determinant;
begin
Jacobi (A, Values, Vectors, Compute_Vectors => False);
Sort_Eigensystem (Values, Vectors);
-
return Values;
end Eigenvalues;
-- values of type Real.
Max_Iterations : constant := 50;
-
N : constant Natural := Length (A);
subtype Square_Matrix is Real_Matrix (1 .. N, 1 .. N);
function Sum_Strict_Upper (M : Square_Matrix) return Real is
Sum : Real := 0.0;
+
begin
for Row in 1 .. N - 1 loop
for Col in Row + 1 .. N loop
(Values : in out Real_Vector;
Vectors : in out Real_Matrix)
is
-
procedure Swap (Left, Right : Integer);
-- Swap Values (Left) with Values (Right), and also swap the
-- corresponding eigenvectors. Note that lowerbounds may differ.
R : Real_Matrix (X'Range (2), X'Range (1));
begin
Transpose (X, R);
-
return R;
end Transpose;
elsif Msg = "size for& too small, minimum allowed is ^" then
-- Suppress "size too small" errors in CodePeer mode and ALFA mode,
- -- since pragma Pack is also ignored in this configuration.
+ -- since pragma Pack is also ignored in these configurations.
if CodePeer_Mode or ALFA_Mode then
return True;
-- does not have a choice parameter specification, then we provide one.
else
-
-- Bypass expansion to a run-time call when back-end exception
-- handling is active, unless the target is a VM or CodePeer.
Delete : Boolean := False;
begin
+ -- In formal verification mode, do not generate useless and confusing
+ -- expansion for freeze nodes.
+
+ if ALFA_Mode then
+ return;
+ end if;
+
-- If there are delayed aspect specifications, we insert them just
-- before the freeze node. They are already analyzed so we don't need
-- to reanalyze them (they were analyzed before the type was frozen),
------------------------------------
function Make_Set_Finalize_Address_Call
- (Loc : Source_Ptr;
- Typ : Entity_Id;
+ (Loc : Source_Ptr;
+ Typ : Entity_Id;
Ptr_Typ : Entity_Id) return Node_Id
is
Desig_Typ : constant Entity_Id :=
return
Make_Procedure_Call_Statement (Loc,
- Name =>
+ Name =>
New_Reference_To (RTE (RE_Set_Finalize_Address), Loc),
Parameter_Associations => New_List (
New_Reference_To (Finalization_Master (Ptr_Typ), Loc),
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Reference_To (TSS (Utyp, TSS_Finalize_Address), Loc),
Attribute_Name => Name_Unrestricted_Access)));
end Make_Set_Finalize_Address_Call;
Tasknm : Node_Id;
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
Aggr := Make_Aggregate (Loc, Component_Associations => New_List);
Count := 0;
-- Start of processing for Expand_N_Accept_Statement
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
-- If accept statement is not part of a list, then its parent must be
-- an accept alternative, and, as described above, we do not do any
-- expansion for such accept statements at this level.
T : Entity_Id; -- Additional status flag
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
Process_Statements_For_Controlled_Objects (Trig);
Process_Statements_For_Controlled_Objects (Abrt);
S : Entity_Id; -- Primitive operation slot
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
Process_Statements_For_Controlled_Objects (N);
if Ada_Version >= Ada_2005
procedure Expand_N_Delay_Relative_Statement (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
Rewrite (N,
Make_Procedure_Call_Statement (Loc,
Name => New_Reference_To (RTE (RO_CA_Delay_For), Loc),
Typ : Entity_Id;
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
if Is_RTE (Base_Type (Etype (Expression (N))), RO_CA_Time) then
Typ := RTE (RO_CA_Delay_Until);
else
procedure Expand_N_Entry_Body (N : Node_Id) is
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
-- Associate discriminals with the next protected operation body to be
-- expanded.
Index : Node_Id;
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
if No_Run_Time_Mode then
Error_Msg_CRT ("entry call", N);
return;
Acc_Ent : Entity_Id;
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
Formal := First_Formal (Entry_Ent);
Last_Decl := N;
-- Start of processing for Expand_N_Protected_Body
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
if No_Run_Time_Mode then
Error_Msg_CRT ("protected body", N);
return;
-- Start of processing for Expand_N_Protected_Type_Declaration
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
if Present (Corresponding_Record_Type (Prot_Typ)) then
return;
else
-- Start of processing for Expand_N_Requeue_Statement
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
-- Extract the components of the entry call
Extract_Entry (N, Concval, Ename, Index);
-- Start of processing for Expand_N_Selective_Accept
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
Process_Statements_For_Controlled_Objects (N);
-- First insert some declarations before the select. The first is:
-- Used to determine the proper location of wrapper body insertions
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
-- Add renaming declarations for discriminals and a declaration for the
-- entry family index (if applicable).
Decl_Stack : Node_Id;
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
-- If already expanded, nothing to do
if Present (Corresponding_Record_Type (Tasktyp)) then
S : Entity_Id; -- Primitive operation slot
begin
+ -- Do not expand tasking constructs in formal verification mode
+
+ if ALFA_Mode then
+ return;
+ end if;
+
-- Under the Ravenscar profile, timed entry calls are excluded. An error
-- was already reported on spec, so do not attempt to expand the call.
and then RM_Size (Rec) >= Scalar_Component_Total_RM_Size
-- Never do implicit packing in CodePeer or ALFA modes since
- -- we don't do any packing in this mode, since this generates
+ -- we don't do any packing in these modes, since this generates
-- over-complex code that confuses static analysis, and in
-- general, neither CodePeer not GNATprove care about the
-- internal representation of objects.
- and then not CodePeer_Mode
- and then not ALFA_Mode
+ and then not (CodePeer_Mode or ALFA_Mode)
then
-- If implicit packing enabled, do it
and then not Is_Limited_Composite (E)
and then not Is_Packed (Root_Type (E))
and then not Has_Component_Size_Clause (Root_Type (E))
- and then not CodePeer_Mode
- and then not ALFA_Mode
+ and then not (CodePeer_Mode or ALFA_Mode)
then
Get_Index_Bounds (First_Index (E), Lo, Hi);
Reset_Style_Check_Options;
- -- Suppress compiler warnings, since what we are
- -- interested in here is what formal verification can find out.
+ -- Suppress compiler warnings, since what we are interested in here
+ -- is what formal verification can find out.
Warning_Mode := Suppress;
-- Suppress the generation of name tables for enumerations
Global_Discard_Names := True;
+
+ -- Suppress the expansion of tagged types and dispatching calls
+
+ Tagged_Type_Expansion := False;
end if;
end Adjust_Global_Switches;
(CU : Node_Id;
Process : Node_Processing;
Inside_Stubs : Boolean);
+ -- This procedure is undocumented ???
procedure Traverse_All_Compilation_Units (Process : Node_Processing);
-- Call Process on all declarations through all compilation units
-- Hash table to keep the languages used in the project tree
IDE : constant Package_Id :=
- Value_Of (Name_Ide, Project.Decl.Packages, Shared);
+ Value_Of (Name_Ide, Project.Decl.Packages, Shared);
procedure Add_Config_Switches_For_Project
(Project : Project_Id;
Lang : Name_Id;
List : String_List_Id;
Elem : String_Element;
+
begin
if Might_Have_Sources (Project) then
Variable :=
procedure For_Every_Imported_Project is new For_Every_Project_Imported
(State => Integer, Action => Add_Config_Switches_For_Project);
+ -- Document this procedure ???
+
+ -- Local variables
Name : Name_Id;
Count : Natural;
Variable : Variable_Value;
Dummy : Integer := 0;
+ -- Start of processing for Get_Config_Switches
+
begin
For_Every_Imported_Project
(By => Project,
Count := 1;
Name := Language_Htable.Get_First;
while Name /= No_Name loop
+
-- Check if IDE'Compiler_Command is declared for the language.
-- If it is, use its value to invoke gprconfig.
-- --
------------------------------------------------------------------------------
-pragma No_Body;
+-- This package does not require a body, since it is a package renaming. We
+-- provide a dummy file containing a No_Body pragma so that previous versions
+-- of the body (which did exist) will not interfere.
+
+-- pragma No_Body;
+
+-- The above pragma is commented out, since for now we can't use No_Body in
+-- a unit marked as a Compiler_Unit, since this requires GNAT 6.1, and we
+-- do not yet require this for bootstrapping. So instead we use a dummy Taft
+-- amendment type to require the body:
+
+package body System.Exceptions is
+ type Require_Body is new Integer;
+end System.Exceptions;
-- Visible copy to allow Ada.Exceptions to know the exception model.
private
+ type Require_Body;
+ -- Dummy Taft-amendment type to make it legal (and required) to provide
+ -- a body for this package.
+ --
+ -- We do this because this unit used to have a body in earlier versions
+ -- of GNAT, and it causes various bootstrap path problems etc if we remove
+ -- a body, since we may pick up old unwanted bodies.
+ --
+ -- Note: we use this standard Ada method of requiring a body rather
+ -- than the cleaner pragma No_Body because System.Exceptions is a compiler
+ -- unit, and older bootstrap compilers do not support pragma No_Body. This
+ -- type can be removed, and s-except.adb can be replaced by a source
+ -- containing just that pragma, when we decide to move to a 2008 compiler
+ -- as the minimal bootstrap compiler version. ???
+
ZCX_By_Default : constant Boolean := System.ZCX_By_Default;
Foreign_Exception : exception;
procedure Back_Substitute (M, N : in out Matrix) is
pragma Assert (M'First (1) = N'First (1) and then
M'Last (1) = N'Last (1));
+
Max_Col : Integer := M'Last (2);
procedure Sub_Row
Target : Integer;
Source : Integer;
Factor : Scalar);
+ -- Needs comments ???
procedure Sub_Row
(M : in out Matrix;
Target : Integer;
Source : Integer;
- Factor : Scalar) is
+ Factor : Scalar)
+ is
begin
for J in M'Range (2) loop
M (Target, J) := M (Target, J) - Factor * M (Source, J);
end loop;
end Sub_Row;
+ -- Start of processing for Back_Substitute
+
begin
for Row in reverse M'Range (1) loop
Find_Non_Zero : for Col in M'First (2) .. Max_Col loop
if Is_Non_Zero (M (Row, Col)) then
+
-- Found first non-zero element, so subtract a multiple
-- of this row from all higher rows, to reduce all other
-- elements in this column to zero.
Target : Integer;
Source : Integer;
Factor : Scalar);
+ -- Needs commenting ???
procedure Divide_Row
(M, N : in out Matrix;
Row : Integer;
Scale : Scalar);
+ -- Needs commenting ???
procedure Switch_Row
(M, N : in out Matrix;
Row_1 : Integer;
Row_2 : Integer);
+ -- Needs commenting ???
-------------
-- Sub_Row --
(M : in out Matrix;
Target : Integer;
Source : Integer;
- Factor : Scalar) is
+ Factor : Scalar)
+ is
begin
for J in M'Range (2) loop
M (Target, J) := M (Target, J) - Factor * M (Source, J);
Y := T;
end Swap;
+ -- Start of processing for Switch_Row
+
begin
if Row_1 /= Row_2 then
Det := Zero - Det;
end if;
end Switch_Row;
- I : Integer := M'First (1);
+ I : Integer := M'First (1);
+ -- Avoid use of I ???
+
+ -- Start of processing for Forward_Eliminate
- begin -- Forward_Eliminate
+ begin
Det := One;
for J in M'Range (2) loop
declare
Max_I : Integer := I;
Max_Abs : Scalar := Zero;
+
begin
- -- Find best pivot in column J, starting in row I.
+ -- Find best pivot in column J, starting in row I
+
for K in I .. M'Last (1) loop
declare
New_Abs : constant Scalar := abs M (K, J);
return Result_Matrix
is
R : Result_Matrix (Left'Range (1), Left'Range (2));
+
begin
if Left'Length (1) /= Right'Length (1)
or else Left'Length (2) /= Right'Length (2)
for K in R'Range (2) loop
declare
S : Result_Scalar := Zero;
+
begin
for M in Left'Range (2) loop
S := S + Left (J, M)
for J in Left'Range (1) loop
declare
S : Result_Scalar := Zero;
+
begin
for K in Left'Range (2) loop
S := S + Left (J, K) * Right (K - Left'First (2) + Right'First);
-- worst, and therefore defaults are not allowed if the parent is
-- a generic formal private type (see ACATS B370001).
- if Is_Access_Type (Discr_Type) then
+ if Is_Access_Type (Discr_Type) and then Default_Present then
if Ekind (Discr_Type) /= E_Anonymous_Access_Type
- or else not Default_Present
or else Is_Limited_Record (Current_Scope)
or else Is_Concurrent_Type (Current_Scope)
or else Is_Concurrent_Record_Type (Current_Scope)
function Controlling_Formal (Prim : Entity_Id) return Entity_Id;
-- Return the controlling formal of Prim
+ ------------------------
+ -- Controlling_Formal --
+ ------------------------
+
function Controlling_Formal (Prim : Entity_Id) return Entity_Id is
E : Entity_Id := First_Entity (Prim);
+
begin
while Present (E) loop
if Is_Formal (E) and then Is_Controlling_Formal (E) then
--------------------------------------------------
function Is_Subprogram_Stub_Without_Prior_Declaration
- (N : Node_Id) return Boolean is
-
+ (N : Node_Id) return Boolean
+ is
begin
-- A subprogram stub without prior declaration serves as declaration for
-- the actual subprogram body. As such, it has an attached defining
SE : constant Entity_Id := Scope (E);
function Within_Postcondition return Boolean;
- -- Returns True iff N is within a Precondition
+ -- Returns True iff N is within a Postcondition or
+ -- Ensures component in a Test_Case.
--------------------------
-- Within_Postcondition --
--------------------------
function Within_Postcondition return Boolean is
- Nod : Node_Id;
+ Nod, P : Node_Id;
begin
Nod := Parent (N);
and then Pragma_Name (Nod) = Name_Postcondition
then
return True;
+
+ elsif Present (Parent (Nod)) then
+ P := Parent (Nod);
+
+ if Nkind (P) = N_Pragma
+ and then Pragma_Name (P) = Name_Test_Case
+ and then
+ Nod = Get_Ensures_From_Test_Case_Pragma (P)
+ then
+ return True;
+ end if;
end if;
Nod := Parent (Nod);
end if;
-- One more check, don't bother if we are within a
- -- postcondition pragma, since the expression occurs
- -- in a place unrelated to the actual test.
+ -- postcondition, since the expression occurs in a
+ -- place unrelated to the actual test.
if not Within_Postcondition then
projects / thirdparty / gcc.git / commitdiff
