+2011-10-13 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch5.adb, sem_ch3.adb, impunit.adb, impunit.ads, sem_type.adb,
+ prj-proc.adb, exp_ch9.adb, s-regpat.adb, sem_ch10.adb, sem_prag.adb,
+ sem_ch12.adb, freeze.adb, sem_attr.adb, sem_attr.ads, gnatlink.adb,
+ par-ch6.adb, exp_ch6.adb, sem_ch4.adb, sem_ch6.adb, sem_ch8.adb,
+ par-util.adb, sem_ch13.adb, lib-xref.adb, g-trasym.adb, g-trasym.ads,
+ exp_aggr.adb, s-taprop-posix.adb: Minor reformatting.
+
+2011-10-13 Geert Bosch <bosch@adacore.com>
+
+ * s-gearop.adb: Minor comment additions.
+
2011-10-13 Fedor Rybin <frybin@adacore.com>
* gnat_ugn.texi: Add gnattest section.
-- active, if this is a preelaborable unit or a
-- predefined unit. This ensures that predefined
-- units get the same level of constant folding in
- -- Ada 95 and Ada 05, where their categorization
+ -- Ada 95 and Ada 2005, where their categorization
-- has changed.
declare
-- remain there.
pragma Assert (First_Entity (Scope (Loop_Id)) = Loop_Id);
-
Set_First_Entity (Scope (Loop_Id), Next_Entity (Loop_Id));
+
if Last_Entity (Scope (Loop_Id)) = Loop_Id then
Set_Last_Entity (Scope (Loop_Id), Empty);
end if;
Add_Extra_Actual_To_Call (Function_Call, Obj_Acc_Formal, Obj_Address);
end Add_Access_Actual_To_Build_In_Place_Call;
- --------------------------------------------------
+ ------------------------------------------------------
-- Add_Unconstrained_Actuals_To_Build_In_Place_Call --
- --------------------------------------------------
+ ------------------------------------------------------
procedure Add_Unconstrained_Actuals_To_Build_In_Place_Call
(Function_Call : Node_Id;
else
SS_Allocator := New_Copy_Tree (Heap_Allocator);
- -- The heap and pool allocators are marked
+ -- The heap and pool allocators are marked as
-- Comes_From_Source since they correspond to an
-- explicit user-written allocator (that is, it will
-- only be executed on behalf of callers that call the
- -- function as initialization for such an
- -- allocator). This prevents errors when
- -- No_Implicit_Heap_Allocations is in force.
+ -- function as initialization for such an allocator).
+ -- Prevents errors when No_Implicit_Heap_Allocations
+ -- is in force.
Set_Comes_From_Source (Heap_Allocator, True);
Set_Comes_From_Source (Pool_Allocator, True);
else
Add_Unconstrained_Actuals_To_Build_In_Place_Call
- (Func_Call,
- Function_Id,
- Alloc_Form => Secondary_Stack);
+ (Func_Call, Function_Id, Alloc_Form => Secondary_Stack);
Caller_Object := Empty;
Establish_Transient_Scope (Object_Decl, Sec_Stack => True);
Insert_Before (Context, Master_Decl);
Analyze (Master_Decl);
- -- Mark the enclosing scope and its associated construct as being task
- -- masters.
+ -- Mark enclosing scope and its associated construct as task masters
Set_Has_Master_Entity (Master_Scop);
if Nkind (Decl) = N_Subprogram_Renaming_Declaration then
if Error_Posted (Decl) then
Set_Has_Completion (E);
-
else
Build_And_Analyze_Renamed_Body (Decl, E, After);
end if;
-- Start of processing for Check_Current_Instance
begin
- -- In Ada 95, the (imprecise) rule is that the current instance of a
- -- limited type is aliased. In Ada 2005, limitedness must be
+ -- In Ada 95, the (imprecise) rule is that the current instance
+ -- of a limited type is aliased. In Ada 2005, limitedness must be
-- explicit: either a tagged type, or a limited record.
if Is_Limited_Type (Rec_Type)
if Nkind (Decl) = N_Full_Type_Declaration then
declare
Tdef : constant Node_Id := Type_Definition (Decl);
+
begin
if Nkind (Tdef) = N_Modular_Type_Definition then
declare
------------------------------------------------------------------------------
-- This is the default implementation for platforms where the full capability
--- is not supported. It returns tracebacks as lists of "0x..." strings
--- corresponding to the addresses.
+-- is not supported. It returns tracebacks as lists of LF separated strings of
+-- the form "0x..." corresponding to the addresses.
with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback;
with System.Address_Image;
else
declare
Img : String := System.Address_Image (Traceback (Traceback'First));
+
Result : String (1 .. (Img'Length + 3) * Traceback'Length);
Last : Natural := 0;
+
begin
for J in Traceback'Range loop
Img := System.Address_Image (Traceback (J));
-- OpenVMS Alpha and ia64
-- Windows
+-- Note: on targets other than those listed above, a dummy implementation of
+-- the body returns a series of LF separated strings of the form "0x..."
+-- corresponding to the addresses.
+
-- The routines provided in this package assume that your application has
-- been compiled with debugging information turned on, since this information
-- is used to build a symbolic traceback.
pragma Elaborate_Body;
function Symbolic_Traceback (Traceback : Tracebacks_Array) return String;
- -- Build a string containing a symbolic traceback of the given call chain
- --
+ -- Build a string containing a symbolic traceback of the given call chain.
-- Note: This procedure may be installed by Set_Trace_Decorator, to get a
-- symbolic traceback on all exceptions raised (see GNAT.Exception_Traces).
if Arg'Length > 8
and then
(Arg (Arg'First + 6 .. Arg'First + 8) = "rtp"
- or else Arg (Arg'Last - 2 .. Arg'Last) = "rtp")
+ or else Arg (Arg'Last - 2 .. Arg'Last) = "rtp")
then
Linker_Options.Increment_Last;
Linker_Options.Table (Linker_Options.Last) :=
-- The following is a giant string list containing the names of all non-
-- implementation internal files, i.e. the complete list of files for
-- internal units which a program may legitimately WITH when operating in
- -- either Ada 95 or Ada 05 mode.
+ -- either Ada 95 or Ada 2005 mode.
-- Note that this list should match the list of units documented in the
-- "GNAT Library" section of the GNAT Reference Manual. A unit listed here
-- This package contains data and functions used to determine if a given unit
-- is an internal unit intended only for use by the implementation and which
--- should not be directly WITH'ed by user code. It also checks for Ada 05
--- units that should only be WITH'ed in Ada 05 mode.
+-- should not be directly WITH'ed by user code. It also checks for Ada 2005
+-- units that should only be WITH'ed in Ada 2005 mode, and Ada 2012 units
+-- that should only be WITH'ed in Ada 2012 mode.
with Types; use Types;
Op := Ultimate_Alias (Old_E);
- -- Normal case of no alias present
- -- we omit generated primitives like tagged equality,
- -- that have no source representation.
+ -- Normal case of no alias present. We omit generated
+ -- primitives like tagged equality, that have no source
+ -- representation.
else
Op := Old_E;
Scope.Table (Scope.Last).Ecol := Start_Column;
Scope.Table (Scope.Last).Lreq := False;
- -- Ada 2005: scan leading NOT OVERRIDING indicator
+ -- Ada 2005: Scan leading NOT OVERRIDING indicator
if Token = Tok_Not then
Scan; -- past NOT
-- Note: we deliberately do not emit these warnings when operating in
-- Ada 83 mode because in that case we assume the user is building
- -- legacy code anyway.
+ -- legacy code anyway and is not interested in updating Ada versions.
end Check_Future_Keyword;
procedure Recursive_Process
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
+ Packages_To_Check : String_List_Access;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
procedure Process
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
+ Packages_To_Check : String_List_Access;
Success : out Boolean;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Env => Env,
+ Packages_To_Check => Packages_To_Check,
Reset_Tree => Reset_Tree);
if Project_Qualifier_Of
procedure Process_Project_Tree_Phase_1
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
+ Packages_To_Check : String_List_Access;
Success : out Boolean;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Recursive_Process
(Project => Project,
In_Tree => In_Tree,
+ Packages_To_Check => Packages_To_Check,
From_Project_Node => From_Project_Node,
From_Project_Node_Tree => From_Project_Node_Tree,
Env => Env,
procedure Recursive_Process
(In_Tree : Project_Tree_Ref;
Project : out Project_Id;
+ Packages_To_Check : String_List_Access;
From_Project_Node : Project_Node_Id;
From_Project_Node_Tree : Project_Node_Tree_Ref;
Env : in out Prj.Tree.Environment;
Recursive_Process
(In_Tree => In_Tree,
Project => New_Project,
+ Packages_To_Check => Packages_To_Check,
From_Project_Node =>
- Project_Node_Of
- (With_Clause, From_Project_Node_Tree),
+ Project_Node_Of (With_Clause, From_Project_Node_Tree),
From_Project_Node_Tree => From_Project_Node_Tree,
Env => Env,
Extended_By => No_Project);
Prj.Part.Parse
(In_Tree => From_Project_Node_Tree,
Project => Loaded_Project,
+ Packages_To_Check => Packages_To_Check,
Project_File_Name => Get_Name_String (List.Path),
Errout_Handling => Prj.Part.Never_Finalize,
Current_Directory => Get_Name_String (Project.Directory.Name),
Process_Project_Tree_Phase_1
(In_Tree => Tree,
Project => List.Project,
+ Packages_To_Check => Packages_To_Check,
Success => Success,
From_Project_Node => Loaded_Project,
From_Project_Node_Tree => From_Project_Node_Tree,
Process_Project_Tree_Phase_1
(In_Tree => Tree,
Project => List.Project,
+ Packages_To_Check => Packages_To_Check,
Success => Success,
From_Project_Node => Loaded_Project,
From_Project_Node_Tree => From_Project_Node_Tree,
Recursive_Process
(In_Tree => In_Tree,
Project => Project.Extends,
- From_Project_Node => Extended_Project_Of
- (Declaration_Node, From_Project_Node_Tree),
+ Packages_To_Check => Packages_To_Check,
+ From_Project_Node =>
+ Extended_Project_Of
+ (Declaration_Node, From_Project_Node_Tree),
From_Project_Node_Tree => From_Project_Node_Tree,
Env => Env,
Extended_By => Project);
Target : Integer;
Source : Integer;
Factor : Scalar);
- -- Needs comments ???
+ -- Elementary row operation that subtracts Factor * M (Source, <>) from
+ -- M (Target, <>)
procedure Sub_Row
(M : in out Matrix;
function "abs" (X : Scalar) return Scalar is
(if X < Zero then Zero - X else X);
+ -- The following are variations of the elementary matrix row operations:
+ -- row switching, row multiplication and row addition. Because in this
+ -- algorithm the addition factor is always a negated value, we chose to
+ -- use row subtraction instead. Similarly, instead of multiplying by
+ -- a reciprocal, we divide.
+
procedure Sub_Row
(M : in out Matrix;
Target : Integer;
Source : Integer;
Factor : Scalar);
- -- Needs commenting ???
+ -- Subtrace Factor * M (Source, <>) from M (Target, <>)
procedure Divide_Row
(M, N : in out Matrix;
Row : Integer;
Scale : Scalar);
- -- Needs commenting ???
+ -- Divide M (Row) and N (Row) by Scale, and update Det
procedure Switch_Row
(M, N : in out Matrix;
Row_1 : Integer;
Row_2 : Integer);
- -- Needs commenting ???
+ -- Exchange M (Row_1) and N (Row_1) with M (Row_2) and N (Row_2),
+ -- negating Det in the process.
-------------
-- Sub_Row --
end if;
end Switch_Row;
- I : Integer := M'First (1);
- -- Avoid use of I ???
+ Row : Integer := M'First (1);
-- Start of processing for Forward_Eliminate
for J in M'Range (2) loop
declare
- Max_I : Integer := I;
+ Max_Row : Integer := Row;
Max_Abs : Scalar := Zero;
begin
- -- Find best pivot in column J, starting in row I
+ -- Find best pivot in column J, starting in row Row
- for K in I .. M'Last (1) loop
+ for K in Row .. M'Last (1) loop
declare
New_Abs : constant Scalar := abs M (K, J);
begin
if Max_Abs < New_Abs then
Max_Abs := New_Abs;
- Max_I := K;
+ Max_Row := K;
end if;
end;
end loop;
if Zero < Max_Abs then
- Switch_Row (M, N, I, Max_I);
- Divide_Row (M, N, I, M (I, J));
+ Switch_Row (M, N, Row, Max_Row);
+ Divide_Row (M, N, Row, M (Row, J));
- for U in I + 1 .. M'Last (1) loop
- Sub_Row (N, U, I, M (U, J));
- Sub_Row (M, U, I, M (U, J));
+ for U in Row + 1 .. M'Last (1) loop
+ Sub_Row (N, U, Row, M (U, J));
+ Sub_Row (M, U, Row, M (U, J));
end loop;
- exit when I >= M'Last (1);
+ exit when Row >= M'Last (1);
- I := I + 1;
+ Row := Row + 1;
else
Det := Zero; -- Zero, but we don't have literals
Must_Have_Length => Dummy.Must_Have_Length,
Paren_Count => Dummy.Paren_Count,
Flags => Dummy.Flags,
- Program => Dummy.Program
- (Dummy.Program'First .. Dummy.Program'First + Size - 1));
+ Program =>
+ Dummy.Program
+ (Dummy.Program'First .. Dummy.Program'First + Size - 1));
else
-- We have to recompile now that we know the size
- -- ??? Can we use Ada 05's return construct ?
+ -- ??? Can we use Ada 2005's return construct ?
+
declare
Result : Pattern_Matcher (Size);
begin
Result := pthread_mutex_destroy (S.L'Access);
pragma Assert (Result = 0);
+ -- Storage_Error is propagated as intended if the allocation of the
+ -- underlying OS entities fails.
+
raise Storage_Error;
end if;
Result := pthread_condattr_destroy (Cond_Attr'Access);
pragma Assert (Result = 0);
+ -- Storage_Error is propagated as intended if the allocation of the
+ -- underlying OS entities fails.
+
raise Storage_Error;
end if;
procedure Check_Enum_Image is
Lit : Entity_Id;
+
begin
+ -- When an enumeration type appears in an attribute reference, all
+ -- literals of the type are marked as referenced. This must only be
+ -- done if the attribute reference appears in the current source.
+ -- Otherwise the information on references may differ between a
+ -- normal compilation and one that performs inlining.
+
if Is_Enumeration_Type (P_Base_Type)
and then In_Extended_Main_Code_Unit (N)
then
-- Case of enumeration type
+ -- When an enumeration type appears in an attribute reference, all
+ -- literals of the type are marked as referenced. This must only be
+ -- done if the attribute reference appears in the current source.
+ -- Otherwise the information on references may differ between a
+ -- normal compilation and one that performs inlining.
+
if Is_Enumeration_Type (P_Type)
and then In_Extended_Main_Code_Unit (N)
then
(Typ : Entity_Id;
Nam : TSS_Name_Type;
Partial_View : Entity_Id := Empty) return Boolean;
- -- For a limited type Typ, return True iff the given attribute is
- -- available. For Ada 05, availability is defined by 13.13.2(36/1). For Ada
- -- 95, an attribute is considered to be available if it has been specified
- -- using an attribute definition clause for the type, or for its full view,
- -- or for an ancestor of either. Parameter Partial_View is used only
- -- internally, when checking for an attribute definition clause that is not
- -- visible (Ada 95 only).
+ -- For a limited type Typ, return True if and only if the given attribute
+ -- is available. For Ada 2005, availability is defined by 13.13.2(36/1).
+ -- For Ada 95, an attribute is considered to be available if it has been
+ -- specified using an attribute definition clause for the type, or for its
+ -- full view, or for an ancestor of either. Parameter Partial_View is used
+ -- only internally, when checking for an attribute definition clause that
+ -- is not visible (Ada 95 only).
end Sem_Attr;
-- Limited_With_Clauses --
--------------------------
- -- Limited_With clauses are the mechanism chosen for Ada 05 to support
+ -- Limited_With clauses are the mechanism chosen for Ada 2005 to support
-- mutually recursive types declared in different units. A limited_with
-- clause that names package P in the context of unit U makes the types
-- declared in the visible part of P available within U, but with the
(T : Entity_Id;
Def : Node_Id)
is
- Loc : constant Source_Ptr := Sloc (Def);
- Base : constant Entity_Id :=
- New_Internal_Entity
- (E_Decimal_Fixed_Point_Type,
- Current_Scope,
- Sloc (Defining_Identifier (Parent (Def))), 'G');
+ Loc : constant Source_Ptr := Sloc (Def);
+
+ Base : constant Entity_Id :=
+ New_Internal_Entity
+ (E_Decimal_Fixed_Point_Type,
+ Current_Scope,
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
+
Int_Base : constant Entity_Id := Standard_Integer;
Delta_Val : constant Ureal := Ureal_1;
Digs_Val : constant Uint := Uint_6;
Base : constant Entity_Id :=
New_Internal_Entity
(E_Floating_Point_Type, Current_Scope,
- Sloc (Defining_Identifier (Parent (Def))), 'G');
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
+
begin
Enter_Name (T);
Set_Ekind (T, E_Enumeration_Subtype);
Base : constant Entity_Id :=
New_Internal_Entity
(E_Floating_Point_Type, Current_Scope,
- Sloc (Defining_Identifier (Parent (Def))), 'G');
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
begin
-- The various semantic attributes are taken from the predefined type
Base : constant Entity_Id :=
New_Internal_Entity
(E_Ordinary_Fixed_Point_Type, Current_Scope,
- Sloc (Defining_Identifier (Parent (Def))), 'G');
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
+
begin
-- The semantic attributes are set for completeness only, their values
-- will never be used, since all properties of the type are non-static.
is
Base : constant Entity_Id :=
New_Internal_Entity
- (E_Signed_Integer_Type,
- Current_Scope,
- Sloc (Defining_Identifier (Parent (Def))), 'G');
+ (E_Signed_Integer_Type,
+ Current_Scope,
+ Sloc (Defining_Identifier (Parent (Def))), 'G');
begin
Enter_Name (T);
-- No statements other than code statements, pragmas, and labels.
-- Again we allow certain internally generated statements.
+
-- In Ada 2012, qualified expressions are names, and the code
-- statement is initially parsed as a procedure call.
when N_Conditional_Expression =>
declare
Then_Expr : constant Node_Id :=
- Next
- (First (Expressions (Original_Node (Exp))));
+ Next (First (Expressions (Original_Node (Exp))));
Else_Expr : constant Node_Id := Next (Then_Expr);
-
begin
return OK_For_Limited_Init_In_05 (Typ, Then_Expr)
and then OK_For_Limited_Init_In_05 (Typ, Else_Expr);
-- of the high bound.
procedure Check_Universal_Expression (N : Node_Id);
- -- In Ada 83, reject bounds of a universal range that are not
- -- literals or entity names.
+ -- In Ada83, reject bounds of a universal range that are not literals or
+ -- entity names.
-----------------------
-- Check_Common_Type --
begin
Analyze (P);
- -- A call of the form A.B (X) may be an Ada 05 call, which is rewritten
- -- as B (A, X). If the rewriting is successful, the call has been
- -- analyzed and we just return.
+ -- A call of the form A.B (X) may be an Ada 2005 call, which is
+ -- rewritten as B (A, X). If the rewriting is successful, the call
+ -- has been analyzed and we just return.
if Nkind (P) = N_Selected_Component
and then Name (N) /= P
if not Is_Actual then
Error_Msg_N ("expect valid subprogram name in renaming", N);
-
else
Error_Msg_NE ("no visible subprogram for formal&", N, Nam);
end if;
Error_Msg_N ("Unchecked_Union must not be tagged", Typ);
return;
- else
- if not Has_Discriminants (Typ) then
- Error_Msg_N
- ("Unchecked_Union must have one discriminant", Typ);
- return;
- end if;
+ elsif not Has_Discriminants (Typ) then
+ Error_Msg_N
+ ("Unchecked_Union must have one discriminant", Typ);
+ return;
+
+ -- Note: in previous versions of GNAT we used to check for limited
+ -- types and give an error, but in fact the standard does allow
+ -- Unchecked_Union on limited types, so this check was removed.
+ -- Proceed with basic error checks completed
+
+ else
Discr := First_Discriminant (Typ);
while Present (Discr) loop
if No (Discriminant_Default_Value (Discr)) then
-- exclude the universal_fixed operator, which often causes ambiguities
-- in legacy code.
- -- Ditto in Ada 2012, where an ambiguity may arise for an operation on
- -- a partial view that is completed with a fixed point type. See
+ -- Ditto in Ada 2012, where an ambiguity may arise for an operation
+ -- on a partial view that is completed with a fixed point type. See
-- AI05-0020 and AI05-0209. The ambiguity is resolved in favor of the
-- user-defined subprogram so that a client of the package has the
-- same resulution as the body of the package.
projects / platform / upstream / linaro-gcc.git / commitdiff