Commit 8190087e by Arnaud Charlet

[multiple changes]

2013-01-03  Thomas Quinot  <quinot@adacore.com>

	* gnat_rm.texi, freeze.adb (Check_Component_Storage_Order): Check that
	a record extension has the same scalar storage order as the parent type.

2013-01-03  Thomas Quinot  <quinot@adacore.com>

	* exp_ch4.adb: Add comment.

2013-01-03  Vincent Celier  <celier@adacore.com>

	* prj.adb: Minor spelling error correction in comment.

2013-01-03  Vincent Celier  <celier@adacore.com>

	* gnatcmd.adb (GNATCmd): If a single main has been specified
	as an absolute path, use its simple file name to find specific
	switches, instead of the absolute path.

2013-01-03  Javier Miranda  <miranda@adacore.com>

	* sem_warn.adb (Warn_On_Overlapping_Actuals): For overlapping
	parameters that are record types or array types generate warnings
	only compiling under -gnatw.i
	* opt.ads (Extensions_Allowed): Restore previous documentation.

2013-01-03  Vincent Celier  <celier@adacore.com>

	* prj-conf.adb (Do_Autoconf): If Target is specified in the
	main project, but not on the command line, use the Target in
	the project to invoke gprconfig in auto-configuration.
	* makeutl.ads (Default_Config_Name): New constant String.

2013-01-03  Arnaud Charlet  <charlet@adacore.com>

	* usage.adb: Minor: fix typo in usage.

2013-01-03  Thomas Quinot  <quinot@adacore.com>

	* sem_ch13.adb (Analyze_Record_Representation_Clause): Reject
	an illegal component clause for an inherited component in a
	record extension.

From-SVN: r194849
parent 6f5c2c4b
2013-01-03 Thomas Quinot <quinot@adacore.com>
* gnat_rm.texi, freeze.adb (Check_Component_Storage_Order): Check that
a record extension has the same scalar storage order as the parent type.
2013-01-03 Thomas Quinot <quinot@adacore.com>
* exp_ch4.adb: Add comment.
2013-01-03 Vincent Celier <celier@adacore.com>
* prj.adb: Minor spelling error correction in comment.
2013-01-03 Vincent Celier <celier@adacore.com>
* gnatcmd.adb (GNATCmd): If a single main has been specified
as an absolute path, use its simple file name to find specific
switches, instead of the absolute path.
2013-01-03 Javier Miranda <miranda@adacore.com>
* sem_warn.adb (Warn_On_Overlapping_Actuals): For overlapping
parameters that are record types or array types generate warnings
only compiling under -gnatw.i
* opt.ads (Extensions_Allowed): Restore previous documentation.
2013-01-03 Vincent Celier <celier@adacore.com>
* prj-conf.adb (Do_Autoconf): If Target is specified in the
main project, but not on the command line, use the Target in
the project to invoke gprconfig in auto-configuration.
* makeutl.ads (Default_Config_Name): New constant String.
2013-01-03 Arnaud Charlet <charlet@adacore.com>
* usage.adb: Minor: fix typo in usage.
2013-01-03 Thomas Quinot <quinot@adacore.com>
* sem_ch13.adb (Analyze_Record_Representation_Clause): Reject
an illegal component clause for an inherited component in a
record extension.
2013-01-03 Emmanuel Briot <briot@adacore.com> 2013-01-03 Emmanuel Briot <briot@adacore.com>
* xref_lib.adb (Parse_Identifier_Info): Fix handling of arrays, which * xref_lib.adb (Parse_Identifier_Info): Fix handling of arrays, which
......
...@@ -10693,6 +10693,9 @@ package body Exp_Ch4 is ...@@ -10693,6 +10693,9 @@ package body Exp_Ch4 is
then then
return Suitable_Element (Next_Entity (C)); return Suitable_Element (Next_Entity (C));
-- Below test for C /= Original_Record_Component (C) is dubious
-- if Typ is a constrained record subtype???
elsif Is_Tagged_Type (Typ) elsif Is_Tagged_Type (Typ)
and then C /= Original_Record_Component (C) and then C /= Original_Record_Component (C)
then then
......
...@@ -1094,13 +1094,25 @@ package body Freeze is ...@@ -1094,13 +1094,25 @@ package body Freeze is
Attribute_Scalar_Storage_Order); Attribute_Scalar_Storage_Order);
if Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then if Is_Record_Type (Comp_Type) or else Is_Array_Type (Comp_Type) then
if No (ADC) then if Present (Comp)
and then Chars (Comp) = Name_uParent
then
if Reverse_Storage_Order (Encl_Type)
/=
Reverse_Storage_Order (Comp_Type)
then
Error_Msg_N
("record extension must have same scalar storage order as "
& "parent", Err_Node);
end if;
elsif No (ADC) then
Error_Msg_N ("nested composite must have explicit scalar " Error_Msg_N ("nested composite must have explicit scalar "
& "storage order", Err_Node); & "storage order", Err_Node);
elsif (Reverse_Storage_Order (Encl_Type) elsif (Reverse_Storage_Order (Encl_Type)
/= /=
Reverse_Storage_Order (Etype (Comp_Type))) Reverse_Storage_Order (Comp_Type))
and then not Comp_Byte_Aligned and then not Comp_Byte_Aligned
then then
Error_Msg_N Error_Msg_N
......
...@@ -6852,6 +6852,9 @@ This means that if a @code{Scalar_Storage_Order} attribute definition ...@@ -6852,6 +6852,9 @@ This means that if a @code{Scalar_Storage_Order} attribute definition
clause is not confirming, then the type's @code{Bit_Order} shall be clause is not confirming, then the type's @code{Bit_Order} shall be
specified explicitly and set to the same value. specified explicitly and set to the same value.
For a record extension, the derived type shall have the same scalar storage
order as the parent type.
If a component of @var{S} has itself a record or array type, then it shall also If a component of @var{S} has itself a record or array type, then it shall also
have a @code{Scalar_Storage_Order} attribute definition clause. In addition, have a @code{Scalar_Storage_Order} attribute definition clause. In addition,
if the component does not start on a byte boundary, then the scalar storage if the component does not start on a byte boundary, then the scalar storage
......
...@@ -1999,7 +1999,19 @@ begin ...@@ -1999,7 +1999,19 @@ begin
In_Arrays => Element.Decl.Arrays, In_Arrays => Element.Decl.Arrays,
Shared => Project_Tree.Shared); Shared => Project_Tree.Shared);
Name_Len := 0; Name_Len := 0;
Add_Str_To_Name_Buffer (Main.all);
-- If the single main has been specified as an absolute
-- path, we use only the simple file name. If the
-- absolute path is incorrect, an error will be reported
-- by the underlying tool and it does not make a
-- difference what switches are used.
if Is_Absolute_Path (Main.all) then
Add_Str_To_Name_Buffer (File_Name (Main.all));
else
Add_Str_To_Name_Buffer (Main.all);
end if;
The_Switches := Prj.Util.Value_Of The_Switches := Prj.Util.Value_Of
(Index => Name_Find, (Index => Name_Find,
Src_Index => 0, Src_Index => 0,
......
...@@ -44,6 +44,10 @@ package Makeutl is ...@@ -44,6 +44,10 @@ package Makeutl is
type Fail_Proc is access procedure (S : String); type Fail_Proc is access procedure (S : String);
-- Pointer to procedure which outputs a failure message -- Pointer to procedure which outputs a failure message
Default_Config_Name : constant String := "default.cgpr";
-- Name of the configuration file used by gprbuild and generated by
-- gprconfig by default.
On_Windows : constant Boolean := Directory_Separator = '\'; On_Windows : constant Boolean := Directory_Separator = '\';
-- True when on Windows -- True when on Windows
......
...@@ -563,7 +563,7 @@ package Opt is ...@@ -563,7 +563,7 @@ package Opt is
Extensions_Allowed : Boolean := False; Extensions_Allowed : Boolean := False;
-- GNAT -- GNAT
-- Set to True by switch -gnatX if GNAT specific language extensions -- Set to True by switch -gnatX if GNAT specific language extensions
-- are allowed. -- are allowed. Currently there are no such defined extensions.
type External_Casing_Type is ( type External_Casing_Type is (
As_Is, -- External names cased as they appear in the Ada source As_Is, -- External names cased as they appear in the Ada source
......
...@@ -48,9 +48,6 @@ package body Prj.Conf is ...@@ -48,9 +48,6 @@ package body Prj.Conf is
Auto_Cgpr : constant String := "auto.cgpr"; Auto_Cgpr : constant String := "auto.cgpr";
Default_Name : constant String := "default.cgpr";
-- Default configuration file that will be used if found
Config_Project_Env_Var : constant String := "GPR_CONFIG"; Config_Project_Env_Var : constant String := "GPR_CONFIG";
-- Name of the environment variable that provides the name of the -- Name of the environment variable that provides the name of the
-- configuration file to use. -- configuration file to use.
...@@ -669,7 +666,7 @@ package body Prj.Conf is ...@@ -669,7 +666,7 @@ package body Prj.Conf is
Free (Tmp); Free (Tmp);
if T'Length = 0 then if T'Length = 0 then
return Default_Name; return Default_Config_Name;
else else
return T; return T;
end if; end if;
...@@ -1183,13 +1180,46 @@ package body Prj.Conf is ...@@ -1183,13 +1180,46 @@ package body Prj.Conf is
Arg_Last := 3; Arg_Last := 3;
else else
if Target_Name = "" then if Target_Name = "" then
if At_Least_One_Compiler_Command then
Args (4) := new String'("--target=all");
else -- Check if attribute Target is specified in the main
Args (4) := -- project, or in a project it extends. If it is, use this
new String'("--target=" & Normalized_Hostname); -- target to invoke gprconfig.
end if;
declare
Variable : Variable_Value;
Proj : Project_Id;
Tgt_Name : Name_Id := No_Name;
begin
Proj := Project;
Project_Loop :
while Proj /= No_Project loop
Variable :=
Value_Of (Name_Target, Proj.Decl.Attributes, Shared);
if Variable /= Nil_Variable_Value and then
not Variable.Default and then
Variable.Value /= No_Name
then
Tgt_Name := Variable.Value;
exit Project_Loop;
end if;
Proj := Proj.Extends;
end loop Project_Loop;
if Tgt_Name /= No_Name then
Args (4) :=
new String'("--target=" &
Get_Name_String (Tgt_Name));
elsif At_Least_One_Compiler_Command then
Args (4) := new String'("--target=all");
else
Args (4) :=
new String'("--target=" & Normalized_Hostname);
end if;
end;
else else
Args (4) := new String'("--target=" & Target_Name); Args (4) := new String'("--target=" & Target_Name);
......
...@@ -563,7 +563,7 @@ package body Prj is ...@@ -563,7 +563,7 @@ package body Prj is
new Ada.Containers.Ordered_Sets (Element_Type => Name_Id); new Ada.Containers.Ordered_Sets (Element_Type => Name_Id);
Seen_Name : Name_Id_Set.Set; Seen_Name : Name_Id_Set.Set;
-- This set is needed to ensure that we do not haandle the same -- This set is needed to ensure that we do not handle the same
-- project twice in the context of aggregate libraries. -- project twice in the context of aggregate libraries.
procedure Recursive_Check procedure Recursive_Check
......
...@@ -4663,10 +4663,34 @@ package body Sem_Ch13 is ...@@ -4663,10 +4663,34 @@ package body Sem_Ch13 is
Ocomp : Entity_Id; Ocomp : Entity_Id;
Posit : Uint; Posit : Uint;
Rectype : Entity_Id; Rectype : Entity_Id;
Recdef : Node_Id;
function Is_Inherited (Comp : Entity_Id) return Boolean;
-- True if Comp is an inherited component in a record extension
------------------
-- Is_Inherited --
------------------
function Is_Inherited (Comp : Entity_Id) return Boolean is
Comp_Base : Entity_Id;
begin
if Ekind (Rectype) = E_Record_Subtype then
Comp_Base := Original_Record_Component (Comp);
else
Comp_Base := Comp;
end if;
return Comp_Base /= Original_Record_Component (Comp_Base);
end Is_Inherited;
Is_Record_Extension : Boolean;
-- True if Rectype is a record extension
CR_Pragma : Node_Id := Empty; CR_Pragma : Node_Id := Empty;
-- Points to N_Pragma node if Complete_Representation pragma present -- Points to N_Pragma node if Complete_Representation pragma present
-- Start of processing for Analyze_Record_Representation_Clause
begin begin
if Ignore_Rep_Clauses then if Ignore_Rep_Clauses then
return; return;
...@@ -4706,6 +4730,14 @@ package body Sem_Ch13 is ...@@ -4706,6 +4730,14 @@ package body Sem_Ch13 is
return; return;
end if; end if;
-- We know we have a first subtype, now possibly go the the anonymous
-- base type to determine whether Rectype is a record extension.
Recdef := Type_Definition (Declaration_Node (Base_Type (Rectype)));
Is_Record_Extension :=
Nkind (Recdef) = N_Derived_Type_Definition
and then Present (Record_Extension_Part (Recdef));
if Present (Mod_Clause (N)) then if Present (Mod_Clause (N)) then
declare declare
Loc : constant Source_Ptr := Sloc (N); Loc : constant Source_Ptr := Sloc (N);
...@@ -4881,6 +4913,11 @@ package body Sem_Ch13 is ...@@ -4881,6 +4913,11 @@ package body Sem_Ch13 is
("cannot reference discriminant of unchecked union", ("cannot reference discriminant of unchecked union",
Component_Name (CC)); Component_Name (CC));
elsif Is_Record_Extension and then Is_Inherited (Comp) then
Error_Msg_NE
("component clause not allowed for inherited "
& "component&", CC, Comp);
elsif Present (Component_Clause (Comp)) then elsif Present (Component_Clause (Comp)) then
-- Diagnose duplicate rep clause, or check consistency -- Diagnose duplicate rep clause, or check consistency
...@@ -4908,10 +4945,11 @@ package body Sem_Ch13 is ...@@ -4908,10 +4945,11 @@ package body Sem_Ch13 is
Error_Msg_N Error_Msg_N
("component clause inconsistent " ("component clause inconsistent "
& "with representation of ancestor", CC); & "with representation of ancestor", CC);
elsif Warn_On_Redundant_Constructs then elsif Warn_On_Redundant_Constructs then
Error_Msg_N Error_Msg_N
("?r?redundant component clause " ("?r?redundant confirming component clause "
& "for inherited component!", CC); & "for component!", CC);
end if; end if;
end; end;
end if; end if;
...@@ -7346,7 +7384,7 @@ package body Sem_Ch13 is ...@@ -7346,7 +7384,7 @@ package body Sem_Ch13 is
begin begin
if Present (CC1) and then Present (CC2) then if Present (CC1) and then Present (CC2) then
-- Exclude odd case where we have two tag fields in the same -- Exclude odd case where we have two tag components in the same
-- record, both at location zero. This seems a bit strange, but -- record, both at location zero. This seems a bit strange, but
-- it seems to happen in some circumstances, perhaps on an error. -- it seems to happen in some circumstances, perhaps on an error.
...@@ -7387,7 +7425,7 @@ package body Sem_Ch13 is ...@@ -7387,7 +7425,7 @@ package body Sem_Ch13 is
procedure Find_Component is procedure Find_Component is
procedure Search_Component (R : Entity_Id); procedure Search_Component (R : Entity_Id);
-- Search components of R for a match. If found, Comp is set. -- Search components of R for a match. If found, Comp is set
---------------------- ----------------------
-- Search_Component -- -- Search_Component --
...@@ -7426,8 +7464,8 @@ package body Sem_Ch13 is ...@@ -7426,8 +7464,8 @@ package body Sem_Ch13 is
Search_Component (Rectype); Search_Component (Rectype);
-- If not found, maybe component of base type that is absent from -- If not found, maybe component of base type discriminant that is
-- statically constrained first subtype. -- absent from statically constrained first subtype.
if No (Comp) then if No (Comp) then
Search_Component (Base_Type (Rectype)); Search_Component (Base_Type (Rectype));
...@@ -7555,7 +7593,7 @@ package body Sem_Ch13 is ...@@ -7555,7 +7593,7 @@ package body Sem_Ch13 is
("bit number out of range of specified size", ("bit number out of range of specified size",
Last_Bit (CC)); Last_Bit (CC));
-- Check for overlap with tag field -- Check for overlap with tag component
else else
if Is_Tagged_Type (Rectype) if Is_Tagged_Type (Rectype)
......
...@@ -3293,8 +3293,7 @@ package body Sem_Warn is ...@@ -3293,8 +3293,7 @@ package body Sem_Warn is
Form1, Form2 : Entity_Id; Form1, Form2 : Entity_Id;
function Is_Covered_Formal (Formal : Node_Id) return Boolean; function Is_Covered_Formal (Formal : Node_Id) return Boolean;
-- Return True if Formal is covered by the Ada 2012 rule. Under -gnatX -- Return True if Formal is covered by the rule.
-- the rule is extended to cover record and array types.
function Refer_Same_Object (Act1, Act2 : Node_Id) return Boolean; function Refer_Same_Object (Act1, Act2 : Node_Id) return Boolean;
-- Two names are known to refer to the same object if the two names -- Two names are known to refer to the same object if the two names
...@@ -3321,24 +3320,12 @@ package body Sem_Warn is ...@@ -3321,24 +3320,12 @@ package body Sem_Warn is
function Is_Covered_Formal (Formal : Node_Id) return Boolean is function Is_Covered_Formal (Formal : Node_Id) return Boolean is
begin begin
-- Ada 2012 rule return
Ekind_In (Formal, E_Out_Parameter,
if not Extensions_Allowed then E_In_Out_Parameter)
return and then (Is_Elementary_Type (Etype (Formal))
Ekind_In (Formal, E_Out_Parameter, or else Is_Record_Type (Etype (Formal))
E_In_Out_Parameter) or else Is_Array_Type (Etype (Formal)));
and then Is_Elementary_Type (Etype (Formal));
-- Under -gnatX the rule is extended to cover array and record types
else
return
Ekind_In (Formal, E_Out_Parameter,
E_In_Out_Parameter)
and then (Is_Elementary_Type (Etype (Formal))
or else Is_Record_Type (Etype (Formal))
or else Is_Array_Type (Etype (Formal)));
end if;
end Is_Covered_Formal; end Is_Covered_Formal;
begin begin
...@@ -3360,7 +3347,8 @@ package body Sem_Warn is ...@@ -3360,7 +3347,8 @@ package body Sem_Warn is
-- there is no other name among the other parameters of mode in out or -- there is no other name among the other parameters of mode in out or
-- out to C that is known to denote the same object (RM 6.4.1(6.15/3)) -- out to C that is known to denote the same object (RM 6.4.1(6.15/3))
-- Under -gnatX the rule is extended to cover array and record types. -- Compiling under -gnatw.i we also report warnings on overlapping
-- parameters that are record types or array types.
Form1 := First_Formal (Subp); Form1 := First_Formal (Subp);
Act1 := First_Actual (N); Act1 := First_Actual (N);
...@@ -3401,10 +3389,21 @@ package body Sem_Warn is ...@@ -3401,10 +3389,21 @@ package body Sem_Warn is
then then
null; null;
-- Under Ada 2012 we only report warnings on overlapping
-- arrays and record types if compiling under -gnatw.i
elsif Ada_Version >= Ada_2012
and then not Is_Elementary_Type (Etype (Form1))
and then not Warn_On_Overlap
then
null;
-- Here we may need to issue message -- Here we may need to issue message
else else
Error_Msg_Warn := Ada_Version < Ada_2012; Error_Msg_Warn :=
Ada_Version < Ada_2012
or else not Is_Elementary_Type (Etype (Form1));
declare declare
Act : Node_Id; Act : Node_Id;
......
...@@ -502,7 +502,7 @@ begin ...@@ -502,7 +502,7 @@ begin
Write_Line (" L* turn off warnings for missing " & Write_Line (" L* turn off warnings for missing " &
"elaboration pragma"); "elaboration pragma");
Write_Line (" .l turn on info messages for inherited aspects"); Write_Line (" .l turn on info messages for inherited aspects");
Write_Line (" .L* turn off info messages for inherited aspects"); Write_Line (" .L* turn off info messages for inherited aspects");
Write_Line (" m+ turn on warnings for variable assigned " & Write_Line (" m+ turn on warnings for variable assigned " &
"but not read"); "but not read");
Write_Line (" M* turn off warnings for variable assigned " & Write_Line (" M* turn off warnings for variable assigned " &
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment