Commit 4bfb35fd by Arnaud Charlet

[multiple changes]

2016-06-16  Ed Schonberg  <schonberg@adacore.com>

	* sem_util.adb (May_Be_Lvalue): An actual in an unexpanded
	attribute reference 'Read is an assignment and must be considered
	a modification of the object.

2016-06-16  Gary Dismukes  <dismukes@adacore.com>

	* einfo.adb: Minor editorial.

From-SVN: r237517
parent d1b83e62
2016-06-16 Ed Schonberg <schonberg@adacore.com> 2016-06-16 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (May_Be_Lvalue): An actual in an unexpanded
attribute reference 'Read is an assignment and must be considered
a modification of the object.
2016-06-16 Gary Dismukes <dismukes@adacore.com>
* einfo.adb: Minor editorial.
2016-06-16 Ed Schonberg <schonberg@adacore.com>
* sem_prag.adb (Overridden_Ancestor): Clean up code to use * sem_prag.adb (Overridden_Ancestor): Clean up code to use
controlling type of desired primitive rather than its scope, controlling type of desired primitive rather than its scope,
because the primitive that inherits the classwide condition may because the primitive that inherits the classwide condition may
......
...@@ -8567,7 +8567,7 @@ package body Einfo is ...@@ -8567,7 +8567,7 @@ package body Einfo is
Subp_Id : Entity_Id; Subp_Id : Entity_Id;
begin begin
-- Once set this attribute it cannot be reset -- Once set, this attribute cannot be reset
if No (V) then if No (V) then
pragma Assert (No (Default_Init_Cond_Procedure (Id))); pragma Assert (No (Default_Init_Cond_Procedure (Id)));
......
...@@ -1231,12 +1231,16 @@ package body Sem_Util is ...@@ -1231,12 +1231,16 @@ package body Sem_Util is
pragma Assert (Has_Default_Init_Cond (Typ)); pragma Assert (Has_Default_Init_Cond (Typ));
pragma Assert (Present (Prag)); pragma Assert (Present (Prag));
-- No action needed if the spec was not built or if the body was -- Nothing to do if the slec was not built. This occurs when the
-- already built. -- expression of the Default_Initial_Condition is missing or is
-- null.
if No (Proc_Id) if No (Proc_Id) then
or else return;
Present (Corresponding_Body (Unit_Declaration_Node (Proc_Id)))
-- Nothing to do if the body was already built
elsif Present (Corresponding_Body (Unit_Declaration_Node (Proc_Id)))
then then
return; return;
end if; end if;
...@@ -1368,6 +1372,7 @@ package body Sem_Util is ...@@ -1368,6 +1372,7 @@ package body Sem_Util is
Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
Args : List_Id;
Proc_Id : Entity_Id; Proc_Id : Entity_Id;
begin begin
...@@ -1378,20 +1383,23 @@ package body Sem_Util is ...@@ -1378,20 +1383,23 @@ package body Sem_Util is
pragma Assert (Has_Default_Init_Cond (Typ)); pragma Assert (Has_Default_Init_Cond (Typ));
pragma Assert (Present (Prag)); pragma Assert (Present (Prag));
Args := Pragma_Argument_Associations (Prag);
-- Nothing to do if default initial condition procedure already built -- Nothing to do if default initial condition procedure already built
if Present (Default_Init_Cond_Procedure (Typ)) then if Present (Default_Init_Cond_Procedure (Typ)) then
return; return;
-- The procedure must not be generated when DIC has one of these two -- Nothing to do if the default initial condition appears without an
-- forms: 1. Default_Initial_Condition => null -- expression.
-- 2. Default_Initial_Condition
elsif No (Pragma_Argument_Associations (Prag)) elsif No (Args) then
or else return;
Nkind (Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))))
= N_Null -- Nothing to do if the expression of the default initial condition is
then -- null.
elsif Nkind (Get_Pragma_Arg (First (Args))) = N_Null then
return; return;
end if; end if;
...@@ -15744,11 +15752,15 @@ package body Sem_Util is ...@@ -15744,11 +15752,15 @@ package body Sem_Util is
return N = Name (P); return N = Name (P);
-- Test prefix of component or attribute. Note that the prefix of an -- Test prefix of component or attribute. Note that the prefix of an
-- explicit or implicit dereference cannot be an l-value. -- explicit or implicit dereference cannot be an l-value. In the case
-- of a 'Read attribute, the reference can be an actual in the
-- argument list of the attribute.
when N_Attribute_Reference => when N_Attribute_Reference =>
return N = Prefix (P) return (N = Prefix (P)
and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)); and then Name_Implies_Lvalue_Prefix (Attribute_Name (P)))
or else
Attribute_Name (P) = Name_Read;
-- For an expanded name, the name is an lvalue if the expanded name -- For an expanded name, the name is an lvalue if the expanded name
-- is an lvalue, but the prefix is never an lvalue, since it is just -- is an lvalue, but the prefix is never an lvalue, since it is just
......
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