+2017-04-28 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb, g-dyntab.adb, par-ch4.adb, sem_util.adb, sem_attr.adb,
+ gnat1drv.adb, exp_disp.adb, namet.adb, alloc.ads: Minor reformatting.
+
2017-04-28 Gary Dismukes <dismukes@adacore.com>
* exp_util.adb: Minor reformatting.
-- The comment shows the unit in which the table is defined
- All_Interp_Initial : constant := 1_000; -- Sem_Type
+ All_Interp_Initial : constant := 1_000; -- Sem_Type
All_Interp_Increment : constant := 100;
- Branches_Initial : constant := 1_000; -- Sem_Warn
+ Branches_Initial : constant := 1_000; -- Sem_Warn
Branches_Increment : constant := 100;
- Conditionals_Initial : constant := 1_000; -- Sem_Warn
+ Conditionals_Initial : constant := 1_000; -- Sem_Warn
Conditionals_Increment : constant := 100;
- Conditional_Stack_Initial : constant := 50; -- Sem_Warn
+ Conditional_Stack_Initial : constant := 50; -- Sem_Warn
Conditional_Stack_Increment : constant := 100;
- Elists_Initial : constant := 200; -- Elists
+ Elists_Initial : constant := 200; -- Elists
Elists_Increment : constant := 100;
- Elmts_Initial : constant := 1_200; -- Elists
+ Elmts_Initial : constant := 1_200; -- Elists
Elmts_Increment : constant := 100;
- File_Name_Chars_Initial : constant := 10_000; -- Osint
+ File_Name_Chars_Initial : constant := 10_000; -- Osint
File_Name_Chars_Increment : constant := 100;
- In_Out_Warnings_Initial : constant := 100; -- Sem_Warn
+ In_Out_Warnings_Initial : constant := 100; -- Sem_Warn
In_Out_Warnings_Increment : constant := 100;
- Ignored_Ghost_Units_Initial : constant := 20; -- Sem_Util
+ Ignored_Ghost_Units_Initial : constant := 20; -- Sem_Util
Ignored_Ghost_Units_Increment : constant := 50;
- Inlined_Initial : constant := 100; -- Inline
+ Inlined_Initial : constant := 100; -- Inline
Inlined_Increment : constant := 100;
- Inlined_Bodies_Initial : constant := 50; -- Inline
+ Inlined_Bodies_Initial : constant := 50; -- Inline
Inlined_Bodies_Increment : constant := 200;
- Interp_Map_Initial : constant := 200; -- Sem_Type
+ Interp_Map_Initial : constant := 200; -- Sem_Type
Interp_Map_Increment : constant := 100;
- Lines_Initial : constant := 500; -- Sinput
+ Lines_Initial : constant := 500; -- Sinput
Lines_Increment : constant := 150;
- Linker_Option_Lines_Initial : constant := 5; -- Lib
+ Linker_Option_Lines_Initial : constant := 5; -- Lib
Linker_Option_Lines_Increment : constant := 200;
- Lists_Initial : constant := 4_000; -- Nlists
+ Lists_Initial : constant := 4_000; -- Nlists
Lists_Increment : constant := 200;
- Load_Stack_Initial : constant := 10; -- Lib
+ Load_Stack_Initial : constant := 10; -- Lib
Load_Stack_Increment : constant := 100;
- Name_Chars_Initial : constant := 50_000; -- Namet
+ Name_Chars_Initial : constant := 50_000; -- Namet
Name_Chars_Increment : constant := 100;
- Name_Qualify_Units_Initial : constant := 200; -- Exp_Dbug
+ Name_Qualify_Units_Initial : constant := 200; -- Exp_Dbug
Name_Qualify_Units_Increment : constant := 300;
- Names_Initial : constant := 6_000; -- Namet
+ Names_Initial : constant := 6_000; -- Namet
Names_Increment : constant := 100;
Nodes_Initial : constant := 5_000_000; -- Atree
Nodes_Increment : constant := 100;
Nodes_Release_Threshold : constant := 100_000;
- Notes_Initial : constant := 100; -- Lib
+ Notes_Initial : constant := 100; -- Lib
Notes_Increment : constant := 200;
- Obsolescent_Warnings_Initial : constant := 50; -- Sem_Prag
+ Obsolescent_Warnings_Initial : constant := 50; -- Sem_Prag
Obsolescent_Warnings_Increment : constant := 200;
- Pending_Instantiations_Initial : constant := 10; -- Inline
+ Pending_Instantiations_Initial : constant := 10; -- Inline
Pending_Instantiations_Increment : constant := 100;
- Rep_Table_Initial : constant := 1000; -- Repinfo
+ Rep_Table_Initial : constant := 1000; -- Repinfo
Rep_Table_Increment : constant := 200;
- Scope_Stack_Initial : constant := 10; -- Sem
+ Scope_Stack_Initial : constant := 10; -- Sem
Scope_Stack_Increment : constant := 200;
- SFN_Table_Initial : constant := 10; -- Fname
+ SFN_Table_Initial : constant := 10; -- Fname
SFN_Table_Increment : constant := 200;
- Source_File_Initial : constant := 10; -- Sinput
+ Source_File_Initial : constant := 10; -- Sinput
Source_File_Increment : constant := 200;
- String_Chars_Initial : constant := 2_500; -- Stringt
+ String_Chars_Initial : constant := 2_500; -- Stringt
String_Chars_Increment : constant := 150;
- Strings_Initial : constant := 5_00; -- Stringt
+ Strings_Initial : constant := 5_00; -- Stringt
Strings_Increment : constant := 150;
- Successors_Initial : constant := 2_00; -- Inline
+ Successors_Initial : constant := 2_00; -- Inline
Successors_Increment : constant := 100;
- Udigits_Initial : constant := 10_000; -- Uintp
+ Udigits_Initial : constant := 10_000; -- Uintp
Udigits_Increment : constant := 100;
- Uints_Initial : constant := 5_000; -- Uintp
+ Uints_Initial : constant := 5_000; -- Uintp
Uints_Increment : constant := 100;
- Units_Initial : constant := 30; -- Lib
+ Units_Initial : constant := 30; -- Lib
Units_Increment : constant := 100;
- Ureals_Initial : constant := 200; -- Urealp
+ Ureals_Initial : constant := 200; -- Urealp
Ureals_Increment : constant := 100;
- Unreferenced_Entities_Initial : constant := 1_000; -- Sem_Warn
+ Unreferenced_Entities_Initial : constant := 1_000; -- Sem_Warn
Unreferenced_Entities_Increment : constant := 100;
- Warnings_Off_Pragmas_Initial : constant := 500; -- Sem_Warn
+ Warnings_Off_Pragmas_Initial : constant := 500; -- Sem_Warn
Warnings_Off_Pragmas_Increment : constant := 100;
- With_List_Initial : constant := 10; -- Features
+ With_List_Initial : constant := 10; -- Features
With_List_Increment : constant := 300;
- Xrefs_Initial : constant := 5_000; -- Cross-refs
+ Xrefs_Initial : constant := 5_000; -- Cross-refs
Xrefs_Increment : constant := 300;
- Drefs_Initial : constant := 5; -- Dereferences
+ Drefs_Initial : constant := 5; -- Dereferences
Drefs_Increment : constant := 1_000;
end Alloc;
Controlling_Tag : Node_Id;
procedure Build_Class_Wide_Check;
- -- If the denoted subprogram has a class-wide precondition, generate
- -- a check using that precondition before the dispatching call, because
+ -- If the denoted subprogram has a class-wide precondition, generate a
+ -- check using that precondition before the dispatching call, because
-- this is the only class-wide precondition that applies to the call.
function New_Value (From : Node_Id) return Node_Id;
----------------------------
procedure Build_Class_Wide_Check is
- Prec : Node_Id;
- Cond : Node_Id;
- Msg : Node_Id;
- Str_Loc : constant String := Build_Location_String (Loc);
-
function Replace_Formals (N : Node_Id) return Traverse_Result;
-- Replace occurrences of the formals of the subprogram by the
-- corresponding actuals in the call, given that this check is
Rewrite (N, New_Copy_Tree (A));
exit;
end if;
+
Next_Formal (F);
Next_Actual (A);
end loop;
end Replace_Formals;
procedure Update is new Traverse_Proc (Replace_Formals);
+
+ -- Local variables
+
+ Str_Loc : constant String := Build_Location_String (Loc);
+
+ Cond : Node_Id;
+ Msg : Node_Id;
+ Prec : Node_Id;
+
+ -- Start of processing for Build_Class_Wide_Check
+
begin
-- Locate class-wide precondition, if any
end if;
-- The expression for the precondition is analyzed within the
- -- generated pragma. The message text is the last parameter
- -- of the generated pragma, indicating source of precondition.
+ -- generated pragma. The message text is the last parameter of
+ -- the generated pragma, indicating source of precondition.
- Cond := New_Copy_Tree
- (Expression (First (Pragma_Argument_Associations (Prec))));
+ Cond :=
+ New_Copy_Tree
+ (Expression (First (Pragma_Argument_Associations (Prec))));
Update (Cond);
-- Build message indicating the failed precondition and the
Msg := Make_String_Literal (Loc, Name_Buffer (1 .. Name_Len));
Insert_Action (Call_Node,
- Make_If_Statement (Loc,
- Condition => Make_Op_Not (Loc, Cond),
- Then_Statements => New_List (
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of
- (RTE (RE_Raise_Assert_Failure), Loc),
- Parameter_Associations => New_List (Msg)))));
+ Make_If_Statement (Loc,
+ Condition => Make_Op_Not (Loc, Cond),
+ Then_Statements => New_List (
+ Make_Procedure_Call_Statement (Loc,
+ Name =>
+ New_Occurrence_Of (RTE (RE_Raise_Assert_Failure), Loc),
+ Parameter_Associations => New_List (Msg)))));
end if;
end Build_Class_Wide_Check;
if Present (New_E) then
Rewrite (N, New_Occurrence_Of (New_E, Sloc (N)));
- -- If the entity is an overridden primitive and we are not in
- -- GNATprove mode, we must build a wrapper for the current
+ -- If the entity is an overridden primitive and we are not
+ -- in GNATprove mode, we must build a wrapper for the current
-- inherited operation. If the reference is the prefix of an
-- attribute such as 'Result (or others ???) there is no need
-- for a wrapper: the condition is just rewritten in terms of
if Is_Subprogram (New_E)
and then Nkind (Parent (N)) /= N_Attribute_Reference
- and then not GNATprove_Mode
+ and then not GNATprove_Mode
then
Needs_Wrapper := True;
end if;
procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
pragma Assert (not T.Locked);
New_Last : constant Table_Last_Type := Last (T) + 1;
+
begin
if New_Last <= Last_Allocated (T) then
- -- fast path
+
+ -- Fast path
+
T.P.Last := New_Last;
T.Table (New_Last) := New_Val;
subtype Table_Length_Type is Table_Index_Type'Base
range 0 .. Table_Index_Type'Base'Last;
- Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T);
+ Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T);
Old_Allocated_Length : constant Table_Length_Type :=
Old_Last_Allocated - First + 1;
----------------------------
procedure Adjust_Global_Switches is
+ procedure SPARK_Library_Warning (Kind : String);
+ -- Issue a warning in GNATprove mode if the run-time library does not
+ -- fully support IEEE-754 floating-point semantics.
+
+ ---------------------------
+ -- SPARK_Library_Warning --
+ ---------------------------
+
+ procedure SPARK_Library_Warning (Kind : String) is
+ begin
+ Write_Line
+ ("warning: run-time library may be configured incorrectly");
+ Write_Line
+ ("warning: (SPARK analysis requires support for " & Kind & ')');
+ end SPARK_Library_Warning;
+
+ -- Start of processing for Adjust_Global_Switches
+
begin
-- -gnatd.M enables Relaxed_RM_Semantics
-- Detect that the runtime library support for floating-point numbers
-- may not be compatible with SPARK analysis of IEEE-754 floats.
- declare
- procedure SPARK_Library_Warning (Kind : String);
- -- Issue a warning in GNATprove mode if the run-time library does
- -- not fully support IEEE-754 floating-point semantics.
+ if Denorm_On_Target = False then
+ SPARK_Library_Warning ("float subnormals");
- procedure SPARK_Library_Warning (Kind : String) is
- begin
- Write_Line
- ("warning: run-time library may be configured incorrectly");
- Write_Line
- ("warning: (SPARK analysis requires support for " & Kind
- & ')');
- end SPARK_Library_Warning;
+ elsif Machine_Rounds_On_Target = False then
+ SPARK_Library_Warning ("float rounding");
- begin
- if Denorm_On_Target = False then
- SPARK_Library_Warning ("float subnormals");
- elsif Machine_Rounds_On_Target = False then
- SPARK_Library_Warning ("float rounding");
- elsif Signed_Zeros_On_Target = False then
- SPARK_Library_Warning ("signed zeros");
- end if;
- end;
+ elsif Signed_Zeros_On_Target = False then
+ SPARK_Library_Warning ("signed zeros");
+ end if;
end if;
-- Set Configurable_Run_Time mode if system.ads flag set or if the
procedure Append (Buf : in out Bounded_String; Id : Name_Id) is
pragma Assert (Id in Name_Entries.First .. Name_Entries.Last);
- Index : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
- Len : constant Short := Name_Entries.Table (Id).Name_Len;
+
+ Index : constant Int := Name_Entries.Table (Id).Name_Chars_Index;
+ Len : constant Short := Name_Entries.Table (Id).Name_Len;
Chars : Name_Chars.Table_Type renames
- Name_Chars.Table (Index + 1 .. Index + Int (Len));
+ Name_Chars.Table (Index + 1 .. Index + Int (Len));
begin
Append (Buf, String (Chars));
end Append;
--------------------
procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is
- C : Character;
- P : Natural;
+ C : Character;
+ P : Natural;
Temp : Bounded_String;
begin
-- Special handling for 'Image in Ada 2012, where
-- the attribute can be parameterless and its value
-- can be the prefix of a slice. Rewrite name as a
- -- a slice, Expr is its low bound.
+ -- slice, Expr is its low bound.
if Token = Tok_Dot_Dot
and then Attr_Name = Name_Image
when Attribute_Image =>
Check_SPARK_05_Restriction_On_Attribute;
- -- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img
- -- for scalar types, so that the prefix can be an object and not
- -- a type, and there is no need for an argument. Given this vote
- -- of confidence from the ARG, simplest is to transform this new
- -- usage of 'Image into a reference to 'Img.
+ -- AI12-00124-1 : The ARG has adopted the GNAT semantics of 'Img for
+ -- scalar types, so that the prefix can be an object and not a type,
+ -- and there is no need for an argument. Given the vote of confidence
+ -- from the ARG, simplest is to transform this new usage of 'Image
+ -- into a reference to 'Img.
if Ada_Version > Ada_2005
and then Is_Object_Reference (P)
Prefix => Relocate_Node (P),
Attribute_Name => Name_Img));
- -- If the attribute reference includes expressions, the
- -- only possible interpretation is as an indexing of the
- -- parameterless version of 'Image, so rewrite it accordingly.
+ -- If the attribute reference includes expressions, the only
+ -- possible interpretation is as an indexing of the parameterless
+ -- version of 'Image, so rewrite it accordingly.
else
Rewrite (N,
- Make_Indexed_Component (Loc,
- Prefix =>
- Make_Attribute_Reference (Loc,
- Prefix => Relocate_Node (P),
- Attribute_Name => Name_Img),
- Expressions => Expressions (N)));
+ Make_Indexed_Component (Loc,
+ Prefix =>
+ Make_Attribute_Reference (Loc,
+ Prefix => Relocate_Node (P),
+ Attribute_Name => Name_Img),
+ Expressions => Expressions (N)));
end if;
+
Analyze (N);
return;
S := Current_Scope;
while Present (S) and then S /= Standard_Standard loop
if Is_Generic_Instance (S) then
+
-- A child instance is always compiled in the context of a parent
-- instance. Nevertheless, the actuals are not analyzed in an
-- instance context. We detect this case by examining the current
projects / gcc.git / commitdiff