+2014-11-07 Arnaud Charlet <charlet@adacore.com>
+
+ * debug.adb, snames.adb-tmpl (Is_Keyword_Name): Consider 'overriding'
+ a keyword in Ada 95 mode when -gnatd.D is used.
+ * gnat_ugn.texi: Document -gnatd.D.
+
+2014-11-07 Vasiliy Fofanov <fofanov@adacore.com>
+
+ * gnatls.adb: Lower severity of the program's return value in
+ some common cases.
+
+2014-11-07 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch10.adb (Decorate_Type): The limited view of a tagged
+ type has an empty list of primitive operations.
+
+2014-11-07 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb (Analyze_Object_Declaration): Update references to SPARK
+ RM.
+ (Process_Full_View): Update references to SPARK RM.
+ * sem_ch6.adb (Analyze_Generic_Subprogram_Body): Update references
+ to SPARK RM.
+ (Analyze_Subprogram_Body_Helper): Update references
+ to SPARK RM.
+ * sem_ch7.adb (Analyze_Package_Body_Helper): Update references
+ to SPARK RM.
+ * sem_prag.adb (Check_Ghost_Constituent): Update references to
+ SPARK RM.
+ * sem_res.adb (Check_Ghost_Policy): Update references to SPARK RM.
+ (Resolve_Actuals): Ensure that the actual parameter of a Ghost
+ subprogram whose formal is of mode IN OUT or OUT is Ghost.
+ * sem_util.adb (Check_Ghost_Completion): Update references to
+ SPARK RM.
+
+2014-11-07 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch7.adb (Make_Final_Call): If type of designated object is
+ derived from that of the formal of the Deep_Finalize procedure,
+ add an unchecked conversion to prevent spurious type error.
+
+2014-11-07 Robert Dewar <dewar@adacore.com>
+
+ * table.adb, inline.adb, einfo.adb, gnat1drv.adb, exp_ch13.adb,
+ exp_fixd.adb, prj-conf.adb, exp_strm.adb, a-cofove.adb, exp_ch3.ads:
+ Minor reformatting.
+
+2014-11-07 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch12.adb, sem_ch13.adb, prj-tree.adb: Minor reformatting.
+
2014-11-07 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb (Set_Is_Checked_Ghost_Entity,
------------------------------------------------------------------------------
with Ada.Containers.Generic_Array_Sort;
-with Unchecked_Deallocation;
+with Ada.Unchecked_Deallocation;
+
with System; use type System.Address;
package body Ada.Containers.Formal_Vectors is
type Elements_Array_Ptr_Const is access constant Elements_Array;
procedure Free is
- new Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr);
+ new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr);
function Elems (Container : in out Vector) return Elements_Array_Ptr;
function Elemsc
-- d.A Read/write Aspect_Specifications hash table to tree
-- d.B
-- d.C Generate concatenation call, do not generate inline code
- -- d.D
+ -- d.D Disable errors on use of overriding keyword in Ada 95 mode
-- d.E Turn selected errors into warnings
-- d.F Debug mode for GNATprove
-- d.G Ignore calls through generic formal parameters for elaboration
-- d.C Generate call to System.Concat_n.Str_Concat_n routines in cases
-- where we would normally generate inline concatenation code.
+ -- d.D For compatibility with some Ada 95 compilers implementing only
+ -- one feature of Ada 2005 (overriding keyword), disable errors on use
+ -- of overriding keyword in Ada 95 mode.
+
-- d.E Turn selected errors into warnings. This debug switch causes a
-- specific set of error messages into warnings. Setting this switch
-- causes Opt.Error_To_Warning to be set to True. The intention is
-- Has_Static_Predicate Flag269
-- Stores_Attribute_Old_Prefix Flag270
- -- (Has_Protected) Flag271
- -- (SSO_Set_Low_By_Default) Flag272
- -- (SSO_Set_High_By_Default) Flag273
+ -- Has_Protected Flag271
+ -- SSO_Set_Low_By_Default Flag272
+ -- SSO_Set_High_By_Default Flag273
-- Is_Generic_Actual_Subprogram Flag274
-- No_Predicate_On_Actual Flag275
-- No_Dynamic_Predicate_On_Actual Flag276
Apply_Address_Clause_Check (E, N);
end if;
- -- Analyze actions in freeze node, if any.
+ -- Analyze actions in freeze node, if any
if Present (Actions (N)) then
declare
function Make_Tag_Assignment (N : Node_Id) return Node_Id;
-- An object declaration that has an initialization for a tagged object
-- requires a separate reassignment of the tag of the given type, because
- -- the expression may include an unchecked conversion. This tag
- -- assignment is inserted after the declaration, but if the object has
- -- an address clause the assignment is handled as part of the freezing
- -- of the object, see Check_Address_Clause.
+ -- the expression may include an unchecked conversion. This tag assignment
+ -- is inserted after the declaration, but if the object has an address
+ -- clause the assignment is handled as part of the freezing of the object,
+ -- see Check_Address_Clause.
function Needs_Simple_Initialization
(T : Entity_Id;
Set_Etype (Arg, Ftyp);
return Arg;
+ -- Otherwise, introduce a conversion when the designated object
+ -- has a type derived from the formal of the controlled routine.
+
+ elsif Is_Private_Type (Ftyp)
+ and then Present (Atyp)
+ and then Is_Derived_Type (Underlying_Type (Base_Type (Atyp)))
+ then
+ return Unchecked_Convert_To (Ftyp, Arg);
+
else
return Arg;
end if;
-- Generate:
-- [Deep_]Finalize (Obj_Ref);
+ -- Set type of dereference, so that proper conversion are
+ -- generated when operation is inherited.
Obj_Ref := New_Occurrence_Of (Obj_Id, Loc);
if Is_Access_Type (Obj_Typ) then
Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
+ Set_Etype (Obj_Ref, Directly_Designated_Type (Obj_Typ));
end if;
Append_To (Stmts,
-- to construct.
if Has_Discriminants (Typ)
- and then
- No (Discriminant_Default_Value (First_Discriminant (Typ)))
+ and then No (Discriminant_Default_Value (First_Discriminant (Typ)))
and then not Is_Constrained (Underlying_Type (B_Typ))
then
Discr := First_Discriminant (B_Typ);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
- Object_Definition =>
+ Object_Definition =>
New_Occurrence_Of (Etype (Discr), Loc));
-- If this is an access discriminant, do not perform default
Append_To (Decls, Decl);
Append_To (Decls,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Etype (Discr), Loc),
+ Prefix => New_Occurrence_Of (Etype (Discr), Loc),
Attribute_Name => Name_Read,
- Expressions => New_List (
+ Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Cn))));
Odef :=
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (B_Typ, Loc),
- Constraint =>
+ Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constr));
-- because those are written by 'Write.
if Has_Discriminants (Typ)
- and then
- No (Discriminant_Default_Value (First_Discriminant (Typ)))
+ and then No (Discriminant_Default_Value (First_Discriminant (Typ)))
then
Disc := First_Discriminant (Typ);
-
while Present (Disc) loop
-- If the type is an unchecked union, it must have default
Append_To (Stms,
Make_Attribute_Reference (Loc,
- Prefix =>
+ Prefix =>
New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
Attribute_Name => Name_Write,
- Expressions => New_List (
+ Expressions => New_List (
Make_Identifier (Loc, Name_S),
Disc_Ref)));
Append_To (Stms,
Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Typ, Loc),
+ Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Write,
- Expressions => New_List (
+ Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))));
Append_To (Result,
Make_Case_Statement (Loc,
- Expression => D_Ref,
+ Expression => D_Ref,
Alternatives => Alts));
end if;
return
Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Field_Typ, Loc),
+ Prefix => New_Occurrence_Of (Field_Typ, Loc),
Attribute_Name => Nam,
- Expressions => New_List (
+ Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
- Parameter_Type =>
+ Parameter_Type =>
Make_Access_Definition (Loc,
Null_Exclusion_Present => True,
- Subtype_Mark => New_Occurrence_Of (
- Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
Result_Definition => New_Occurrence_Of (Typ, Loc));
Decl :=
Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Decls,
+ Specification => Spec,
+ Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
- Parameter_Type =>
+ Parameter_Type =>
Make_Access_Definition (Loc,
Null_Exclusion_Present => True,
- Subtype_Mark => New_Occurrence_Of (
- Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
+ Subtype_Mark =>
+ New_Occurrence_Of
+ (Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
Decl :=
Make_Subprogram_Body (Loc,
- Specification => Spec,
- Declarations => Empty_List,
+ Specification => Spec,
+ Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
-- SPARK version of the expander.
-- On the contrary, we need to enable explicitly all language checks,
- -- as they may have been marked as suppressed by the use of switch
- -- -gnatp
+ -- as they may have been suppressed by the use of switch -gnatp.
Suppress_Options.Suppress := (others => False);
@cindex @option{-gnat95} (@command{gcc})
Enforce Ada 95 restrictions.
+Note: for compatibility with some Ada 95 compilers which support only
+the @code{overriding} keyword of Ada 2005, the @option{-gnatd.D} switch can
+be used along with @option{-gnat95} to achieve a similar effect with GNAT.
+
+@option{-gnatd.D} instructs GNAT to consider @code{overriding} as a keyword
+and handle its associated semantic checks, even in Ada 95 mode.
+
@item -gnat05
@cindex @option{-gnat05} (@command{gcc})
Allow full Ada 2005 features.
("Default runtime not available. Use --RTS= with a valid runtime");
Write_Eol;
Write_Eol;
+ Exit_Status := E_Warnings;
end if;
Write_Str ("Source Search Path:");
Usage;
else
Try_Help;
+ Exit_Status := E_Fatal;
end if;
end if;
- Exit_Program (E_Fatal);
+ Exit_Program (Exit_Status);
end if;
Initialize_ALI;
end if;
Last_Inlined := E;
+
else
Register_Backend_Not_Inlined_Subprogram (E);
end if;
D := First (Decls);
while Present (D) loop
+
-- First declarations universally excluded
if Nkind (D) = N_Package_Declaration then
if Selected_Target /= null and then
Selected_Target.all /= ""
+
then
Args (4) :=
new String'("--target=" & Selected_Target.all);
Arg_Last := 4;
+
elsif Normalized_Hostname /= "" then
if At_Least_One_Compiler_Command then
- Args (4) :=
- new String'("--target=all");
+ Args (4) := new String'("--target=all");
else
- Args (4) :=
- new String'("--target=" & Normalized_Hostname);
+ Args (4) := new String'("--target=" & Normalized_Hostname);
end if;
Arg_Last := 4;
Implicit_Project : Boolean := False;
On_New_Tree_Loaded : Prj.Proc.Tree_Loaded_Callback := null)
is
- Success : Boolean := False;
+ Success : Boolean := False;
Target_Try_Again : Boolean := True;
Config_Try_Again : Boolean;
Update_Ignore_Missing_With (Env.Flags, True);
- Automatically_Generated := False;
- -- If in fact the config file is automatically generated,
+ -- Note: If in fact the config file is automatically generated, then
-- Automatically_Generated will be set to True after invocation of
-- Process_Project_And_Apply_Config.
- -- Record Target_Value and Target_Origin.
+ Automatically_Generated := False;
+
+ -- Record Target_Value and Target_Origin
if Target_Name = "" then
Opt.Target_Value := new String'(Normalized_Hostname);
Tree : Project_Tree_Ref;
With_State : in out State)
is
- Lang_Id : Language_Ptr;
+ Lang_Id : Language_Ptr;
Compiler_Root : Compiler_Root_Ptr;
- Runtime_Root : Runtime_Root_Ptr;
- Comp_Driver : String_Access;
- Comp_Dir : String_Access;
+ Runtime_Root : Runtime_Root_Ptr;
+ Comp_Driver : String_Access;
+ Comp_Dir : String_Access;
Prefix : String_Access;
pragma Unreferenced (Tree);
declare
Runtime : constant String :=
- Runtime_Name_For (Lang_Id.Name);
- Root : String_Access;
+ Runtime_Name_For (Lang_Id.Name);
+ Root : String_Access;
+
begin
if Runtime'Length > 0 then
if Is_Absolute_Path (Runtime) then
begin
pragma Assert
(Present (Node)
- and then
- In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
+ and then In_Tree.Project_Nodes.Table (Node).Kind = N_Project);
In_Tree.Project_Nodes.Table (Node).Display_Name := To;
end Set_Display_Name_Of;
Init_Size_Align (Ent);
-- A tagged type and its corresponding shadow entity share one common
- -- class-wide type.
+ -- class-wide type. The list of primitive operations for the shadow
+ -- entity is empty.
if Is_Tagged then
Set_Is_Tagged_Type (Ent);
+ Set_Direct_Primitive_Operations (Ent, New_Elmt_List);
if No (Class_Wide_Type (Ent)) then
CW_Typ :=
ASN : Node_Id;
begin
- ASN := Make_Aspect_Specification (Loc,
- Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool),
- Expression => New_Copy (Default_Pool));
+ ASN :=
+ Make_Aspect_Specification (Loc,
+ Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool),
+ Expression => New_Copy (Default_Pool));
if No (Aspect_Specifications (Specification (N))) then
Set_Aspect_Specifications (Specification (N), New_List (ASN));
ASN2 := First (Aspect_Specifications (Gen_Spec));
while Present (ASN2) loop
- if Chars (Identifier (ASN2))
- = Name_Default_Storage_Pool
+ if Chars (Identifier (ASN2)) =
+ Name_Default_Storage_Pool
then
Remove (ASN2);
exit;
begin
-- If rep_clauses are to be ignored, no need for legality checks. In
- -- particular, no need to pester user about rep clauses that violate
- -- the rule on constant addresses, given that these clauses will be
- -- removed by Freeze before they reach the back end.
- -- Similarly in CodePeer mode, we want to relax these checks.
+ -- particular, no need to pester user about rep clauses that violate the
+ -- rule on constant addresses, given that these clauses will be removed
+ -- by Freeze before they reach the back end. Similarly in CodePeer mode,
+ -- we want to relax these checks.
if not Ignore_Rep_Clauses and not CodePeer_Mode then
Check_Expr_Constants (Expr);
-- The Ghost policy in effect at the point of declaration
-- and at the point of completion must match
- -- (SPARK RM 6.9(14)).
+ -- (SPARK RM 6.9(15)).
if Present (Prev_Entity)
and then Is_Ghost_Entity (Prev_Entity)
Set_Is_Ghost_Entity (Id);
-- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
+ -- point of completion must match (SPARK RM 6.9(16)).
if Present (Prev_Entity) and then Is_Ghost_Entity (Prev_Entity) then
Check_Ghost_Completion (Prev_Entity, Id);
Set_Is_Ghost_Entity (Full_T);
-- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
+ -- point of completion must match (SPARK RM 6.9(15)).
Check_Ghost_Completion (Priv_T, Full_T);
Set_Is_Ghost_Entity (Body_Id);
-- The Ghost policy in effect at the point of declaration and at
- -- the point of completion must match (SPARK RM 6.9(14)).
+ -- the point of completion must match (SPARK RM 6.9(15)).
Check_Ghost_Completion (Gen_Id, Body_Id);
end if;
Set_Is_Ghost_Entity (Body_Id);
-- The Ghost policy in effect at the point of declaration and
- -- at the point of completion must match (SPARK RM 6.9(14)).
+ -- at the point of completion must match (SPARK RM 6.9(15)).
Check_Ghost_Completion (Spec_Id, Body_Id);
end if;
Set_Is_Ghost_Entity (Body_Id);
-- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
+ -- point of completion must match (SPARK RM 6.9(15)).
Check_Ghost_Completion (Spec_Id, Body_Id);
end if;
-- The Ghost policy in effect at the point of abstract
-- state declaration and constituent must match
- -- (SPARK RM 6.9(15)).
+ -- (SPARK RM 6.9(16)).
if Is_Checked_Ghost_Entity (State_Id)
and then Is_Ignored_Ghost_Entity (Constit_Id)
begin
-- The Ghost policy in effect a the point of declaration and at the
- -- point of use must match (SPARK RM 6.9(13)).
+ -- point of use must match (SPARK RM 6.9(14)).
if Is_Checked_Ghost_Entity (Id) and then Policy = Name_Ignore then
Error_Msg_Sloc := Sloc (Err_N);
("\subprogram & has Extensions_Visible True", A, Nam);
end if;
+ -- The actual parameter of a Ghost subprogram whose formal is of
+ -- mode IN OUT or OUT must be a Ghost variable (SPARK RM 6.9(13)).
+
+ if Is_Ghost_Entity (Nam)
+ and then Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter)
+ and then Is_Entity_Name (A)
+ and then Present (Entity (A))
+ and then not Is_Ghost_Entity (Entity (A))
+ then
+ Error_Msg_NE
+ ("non-ghost variable & cannot appear as actual in call to "
+ & "ghost procedure", A, Entity (A));
+
+ if Ekind (F) = E_In_Out_Parameter then
+ Error_Msg_N ("\corresponding formal has mode `IN OUT`", A);
+ else
+ Error_Msg_N ("\corresponding formal has mode OUT", A);
+ end if;
+ end if;
+
Next_Actual (A);
-- Case where actual is not present
begin
-- The Ghost policy in effect at the point of declaration and at the
- -- point of completion must match (SPARK RM 6.9(14)).
+ -- point of completion must match (SPARK RM 6.9(15)).
if Is_Checked_Ghost_Entity (Partial_View)
and then Policy = Name_Ignore
-- --
------------------------------------------------------------------------------
+with Debug; use Debug;
with Opt; use Opt;
with Table;
with Types; use Types;
and then (Ada_Version >= Ada_95
or else N not in Ada_95_Reserved_Words)
and then (Ada_Version >= Ada_2005
- or else N not in Ada_2005_Reserved_Words)
+ or else N not in Ada_2005_Reserved_Words
+ or else (Debug_Flag_Dot_DD and then N = Name_Overriding))
+ -- Accept 'overriding' keywords if -gnatd.D is used,
+ -- for compatibility with Ada 95 compilers implementing
+ -- only this Ada 2005 extension.
and then (Ada_Version >= Ada_2012
or else N not in Ada_2012_Reserved_Words);
end Is_Keyword_Name;
Tree_Read_Data
(Tree_Get_Table_Address,
(Last_Val - Int (First) + 1) *
+
+ -- Note the importance of parenthesizing the following division
+ -- to avoid the possibility of intermediate overflow.
+
(Table_Type'Component_Size / Storage_Unit));
end Tree_Read;
projects / gcc.git / commitdiff