Commit 83e5da69 by Arnaud Charlet

[multiple changes]

2011-11-21  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb, sem_util.adb, sem_res.adb, sem_attr.adb: Minor
	reformatting.

2011-11-21  Arnaud Charlet  <charlet@adacore.com>

	* s-taprop-posix.adb (Create_Task): Use Unrestricted_Access
	to deal with fact that we properly detect the error if Access
	is used.

From-SVN: r181572
parent f460d8f3
2011-11-21 Robert Dewar <dewar@adacore.com>
* sem_ch3.adb, sem_util.adb, sem_res.adb, sem_attr.adb: Minor
reformatting.
2011-11-21 Arnaud Charlet <charlet@adacore.com>
* s-taprop-posix.adb (Create_Task): Use Unrestricted_Access
to deal with fact that we properly detect the error if Access
is used.
2011-11-21 Steve Baird <baird@adacore.com> 2011-11-21 Steve Baird <baird@adacore.com>
* sem_util.ads: Update comment describing function * sem_util.ads: Update comment describing function
......
...@@ -975,8 +975,14 @@ package body System.Task_Primitives.Operations is ...@@ -975,8 +975,14 @@ package body System.Task_Primitives.Operations is
-- do not need to manipulate caller's signal mask at this point. -- do not need to manipulate caller's signal mask at this point.
-- All tasks in RTS will have All_Tasks_Mask initially. -- All tasks in RTS will have All_Tasks_Mask initially.
-- Note: the use of Unrestricted_Access in the following call is needed
-- because otherwise we have an error of getting a access-to-volatile
-- value which points to a non-volatile object. But in this case it is
-- safe to do this, since we know we have no problems with aliasing and
-- Unrestricted_Access bypasses this check.
Result := pthread_create Result := pthread_create
(T.Common.LL.Thread'Access, (T.Common.LL.Thread'Unrestricted_Access,
Attributes'Access, Attributes'Access,
Thread_Body_Access (Wrapper), Thread_Body_Access (Wrapper),
To_Address (T)); To_Address (T));
......
...@@ -8642,10 +8642,10 @@ package body Sem_Attr is ...@@ -8642,10 +8642,10 @@ package body Sem_Attr is
end if; end if;
end if; end if;
-- Check the static accessibility rule of 3.10.2(28). -- Check the static accessibility rule of 3.10.2(28). Note that
-- Note that this check is not performed for the -- this check is not performed for the case of an anonymous
-- case of an anonymous access type, since the access -- access type, since the access attribute is always legal
-- attribute is always legal in such a context. -- in such a context.
if Attr_Id /= Attribute_Unchecked_Access if Attr_Id /= Attribute_Unchecked_Access
and then and then
......
...@@ -1897,7 +1897,8 @@ package body Sem_Ch3 is ...@@ -1897,7 +1897,8 @@ package body Sem_Ch3 is
-- components -- components
if Type_Access_Level (Etype (E)) > if Type_Access_Level (Etype (E)) >
Deepest_Type_Access_Level (T) then Deepest_Type_Access_Level (T)
then
Error_Msg_N Error_Msg_N
("expression has deeper access level than component " & ("expression has deeper access level than component " &
"(RM 3.10.2 (12.2))", E); "(RM 3.10.2 (12.2))", E);
......
...@@ -4095,10 +4095,10 @@ package body Sem_Res is ...@@ -4095,10 +4095,10 @@ package body Sem_Res is
-- object must not be deeper than that of the allocator's type. -- object must not be deeper than that of the allocator's type.
elsif Nkind (Disc_Exp) = N_Attribute_Reference elsif Nkind (Disc_Exp) = N_Attribute_Reference
and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) and then Get_Attribute_Id (Attribute_Name (Disc_Exp)) =
= Attribute_Access Attribute_Access
and then Object_Access_Level (Prefix (Disc_Exp)) and then Object_Access_Level (Prefix (Disc_Exp)) >
> Deepest_Type_Access_Level (Alloc_Typ) Deepest_Type_Access_Level (Alloc_Typ)
then then
Error_Msg_N Error_Msg_N
("prefix of attribute has deeper level than allocator type", ("prefix of attribute has deeper level than allocator type",
...@@ -4109,8 +4109,8 @@ package body Sem_Res is ...@@ -4109,8 +4109,8 @@ package body Sem_Res is
elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type elsif Ekind (Etype (Disc_Exp)) = E_Anonymous_Access_Type
and then Nkind (Disc_Exp) = N_Selected_Component and then Nkind (Disc_Exp) = N_Selected_Component
and then Object_Access_Level (Prefix (Disc_Exp)) and then Object_Access_Level (Prefix (Disc_Exp)) >
> Deepest_Type_Access_Level (Alloc_Typ) Deepest_Type_Access_Level (Alloc_Typ)
then then
Error_Msg_N Error_Msg_N
("access discriminant has deeper level than allocator type", ("access discriminant has deeper level than allocator type",
...@@ -4315,7 +4315,8 @@ package body Sem_Res is ...@@ -4315,7 +4315,8 @@ package body Sem_Res is
end if; end if;
if Type_Access_Level (Exp_Typ) > if Type_Access_Level (Exp_Typ) >
Deepest_Type_Access_Level (Typ) then Deepest_Type_Access_Level (Typ)
then
if In_Instance_Body then if In_Instance_Body then
Error_Msg_N ("?type in allocator has deeper level than" & Error_Msg_N ("?type in allocator has deeper level than" &
" designated class-wide type", E); " designated class-wide type", E);
...@@ -10359,13 +10360,15 @@ package body Sem_Res is ...@@ -10359,13 +10360,15 @@ package body Sem_Res is
Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type) Subtypes_Statically_Match (Target_Comp_Type, Opnd_Comp_Type)
then then
if Type_Access_Level (Target_Type) < if Type_Access_Level (Target_Type) <
Deepest_Type_Access_Level (Opnd_Type) Deepest_Type_Access_Level (Opnd_Type)
then then
if In_Instance_Body then if In_Instance_Body then
Error_Msg_N ("?source array type " & Error_Msg_N
"has deeper accessibility level than target", Operand); ("?source array type has " &
Error_Msg_N ("\?Program_Error will be raised at run time", "deeper accessibility level than target", Operand);
Operand); Error_Msg_N
("\?Program_Error will be raised at run time",
Operand);
Rewrite (N, Rewrite (N,
Make_Raise_Program_Error (Sloc (N), Make_Raise_Program_Error (Sloc (N),
Reason => PE_Accessibility_Check_Failed)); Reason => PE_Accessibility_Check_Failed));
...@@ -10375,8 +10378,9 @@ package body Sem_Res is ...@@ -10375,8 +10378,9 @@ package body Sem_Res is
-- Conversion not allowed because of accessibility levels -- Conversion not allowed because of accessibility levels
else else
Error_Msg_N ("source array type " & Error_Msg_N
"has deeper accessibility level than target", Operand); ("source array type has " &
"deeper accessibility level than target", Operand);
return False; return False;
end if; end if;
...@@ -10399,7 +10403,7 @@ package body Sem_Res is ...@@ -10399,7 +10403,7 @@ package body Sem_Res is
-- All of this is checked in Subtypes_Statically_Match. -- All of this is checked in Subtypes_Statically_Match.
if not Subtypes_Statically_Match if not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type) (Target_Comp_Type, Opnd_Comp_Type)
then then
Error_Msg_N Error_Msg_N
("component subtypes must statically match", Operand); ("component subtypes must statically match", Operand);
......
...@@ -2437,6 +2437,8 @@ package body Sem_Util is ...@@ -2437,6 +2437,8 @@ package body Sem_Util is
(Defining_Identifier (Defining_Identifier
(Associated_Node_For_Itype (Typ)))); (Associated_Node_For_Itype (Typ))));
-- For generic formal type, return Int'Last (infinite) (why ???)
elsif Is_Generic_Type (Root_Type (Typ)) then elsif Is_Generic_Type (Root_Type (Typ)) then
return UI_From_Int (Int'Last); return UI_From_Int (Int'Last);
...@@ -12717,6 +12719,8 @@ package body Sem_Util is ...@@ -12717,6 +12719,8 @@ package body Sem_Util is
end if; end if;
end if; end if;
-- Return library level for a generic formal type (why???)
if Is_Generic_Type (Root_Type (Btyp)) then if Is_Generic_Type (Root_Type (Btyp)) then
return Scope_Depth (Standard_Standard); return Scope_Depth (Standard_Standard);
end if; end if;
......
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