+2011-08-30 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch5.adb, sem_ch3.adb, sem_ch5.adb, einfo.adb, checks.adb,
+ sem_util.adb, sem_util.ads, sem_res.adb, s-stposu.adb, sem_attr.adb,
+ exp_ch4.adb, exp_ch6.adb, lib-xref-alfa.adb,
+ sem_ch8.adb, sem_disp.adb, exp_ch3.adb: Minor reformatting
+
+2011-08-30 Robert Dewar <dewar@adacore.com>
+
+ * gnat_rm.texi: Add section on C.6(16) implementation advice for pragma
+ volatile.
+
2011-08-30 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch3.adb (Expand_Freeze_Array_Type): Correct the call to
Insert_Node : Node_Id)
is
Loc : constant Source_Ptr := Sloc (N);
- Param_Ent : Entity_Id := Param_Entity (N);
+ Param_Ent : Entity_Id := Param_Entity (N);
Param_Level : Node_Id;
Type_Level : Node_Id;
then
Param_Ent := Entity (N);
while Present (Renamed_Object (Param_Ent)) loop
+
-- Renamed_Object must return an Entity_Name here
-- because of preceding "Present (E_E_A (...))" test.
elsif Present (Param_Ent)
and then Present (Extra_Accessibility (Param_Ent))
and then UI_Gt (Object_Access_Level (N),
- Deepest_Type_Access_Level (Typ))
+ Deepest_Type_Access_Level (Typ))
and then not Accessibility_Checks_Suppressed (Param_Ent)
and then not Accessibility_Checks_Suppressed (Typ)
then
Param_Level :=
New_Occurrence_Of (Extra_Accessibility (Param_Ent), Loc);
- Type_Level := Make_Integer_Literal (Loc,
- Deepest_Type_Access_Level (Typ));
+ Type_Level :=
+ Make_Integer_Literal (Loc, Deepest_Type_Access_Level (Typ));
-- Raise Program_Error if the accessibility level of the access
-- parameter is deeper than the level of the target access type.
Set_Uint14 (Id, No_Uint); -- Normalized_Position
end Init_Component_Location;
+ ----------------------------
+ -- Init_Object_Size_Align --
+ ----------------------------
+
+ procedure Init_Object_Size_Align (Id : E) is
+ begin
+ Set_Uint12 (Id, Uint_0); -- Esize
+ Set_Uint14 (Id, Uint_0); -- Alignment
+ end Init_Object_Size_Align;
+
---------------
-- Init_Size --
---------------
procedure Init_Size (Id : E; V : Int) is
begin
- Set_Uint12 (Id, UI_From_Int (V)); -- Esize
pragma Assert (not Is_Object (Id));
+ Set_Uint12 (Id, UI_From_Int (V)); -- Esize
Set_Uint13 (Id, UI_From_Int (V)); -- RM_Size
end Init_Size;
procedure Init_Size_Align (Id : E) is
begin
- Set_Uint12 (Id, Uint_0); -- Esize
pragma Assert (not Is_Object (Id));
+ Set_Uint12 (Id, Uint_0); -- Esize
Set_Uint13 (Id, Uint_0); -- RM_Size
Set_Uint14 (Id, Uint_0); -- Alignment
end Init_Size_Align;
- ----------------------------
- -- Init_Object_Size_Align --
- ----------------------------
-
- procedure Init_Object_Size_Align (Id : E) is
- begin
- Set_Uint12 (Id, Uint_0); -- Esize
- Set_Uint14 (Id, Uint_0); -- Alignment
- end Init_Object_Size_Align;
-
----------------------------------------------
-- Type Representation Attribute Predicates --
----------------------------------------------
Loc : constant Source_Ptr := Sloc (N);
Level : constant Entity_Id :=
- Make_Defining_Identifier (Sloc (N),
- Chars => New_External_Name (Chars (Def_Id),
- Suffix => "L"));
+ Make_Defining_Identifier (Sloc (N),
+ Chars =>
+ New_External_Name (Chars (Def_Id), Suffix => "L"));
+
Level_Expr : Node_Id;
Level_Decl : Node_Id;
+
begin
Set_Ekind (Level, Ekind (Def_Id));
Set_Etype (Level, Standard_Natural);
Set_Scope (Level, Scope (Def_Id));
if No (Expr) then
- Level_Expr := Make_Integer_Literal (Loc,
- -- accessibility level of null
- Intval => Scope_Depth (Standard_Standard));
+
+ -- Set accessibility level of null
+
+ Level_Expr :=
+ Make_Integer_Literal (Loc, Scope_Depth (Standard_Standard));
+
else
Level_Expr := Dynamic_Accessibility_Level (Expr);
end if;
-- declaration. Detect anonymous access-to-controlled components.
Has_AACC := False;
+
Comp := First_Component (Def_Id);
while Present (Comp) loop
Comp_Typ := Etype (Comp);
then
Set_Has_Controlled_Component (Def_Id);
- -- Non self-referential anonymous access-to-controlled component
+ -- Non-self-referential anonymous access-to-controlled component
elsif Ekind (Comp_Typ) = E_Anonymous_Access_Type
and then Needs_Finalization (Designated_Type (Comp_Typ))
while Present (Comp) loop
Comp_Typ := Etype (Comp);
- -- A non self-referential anonymous access-to-controlled
+ -- A non-self-referential anonymous access-to-controlled
-- component.
if Ekind (Comp_Typ) = E_Anonymous_Access_Type
end if;
-- For access-to-controlled types (including class-wide types and
- -- Taft-amendment types which potentially have controlled
+ -- Taft-amendment types, which potentially have controlled
-- components), expand the list controller object that will store
- -- the dynamically allocated objects. Do not do this
- -- transformation for expander-generated access types, but do it
- -- for types that are the full view of types derived from other
- -- private types. Also suppress the list controller in the case
- -- of a designated type with convention Java, since this is used
- -- when binding to Java API specs, where there's no equivalent of
- -- a finalization list and we don't want to pull in the
- -- finalization support if not needed.
+ -- the dynamically allocated objects. Don't do this transformation
+ -- for expander-generated access types, but do it for types that
+ -- are the full view of types derived from other private types.
+ -- Also suppress the list controller in the case of a designated
+ -- type with convention Java, since this is used when binding to
+ -- Java API specs, where there's no equivalent of a finalization
+ -- list and we don't want to pull in the finalization support if
+ -- not needed.
if not Comes_From_Source (Def_Id)
and then not Has_Private_Declaration (Def_Id)
New_N : Node_Id;
Param_Level : Node_Id;
Type_Level : Node_Id;
+
begin
if Is_Entity_Name (Lop) then
Expr_Entity := Param_Entity (Lop);
+
if not Present (Expr_Entity) then
Expr_Entity := Entity (Lop);
end if;
else
if Present (Expr_Entity)
- and then Present
- (Effective_Extra_Accessibility (Expr_Entity))
- and then UI_Gt
- (Object_Access_Level (Lop),
- Type_Access_Level (Rtyp))
+ and then
+ Present
+ (Effective_Extra_Accessibility (Expr_Entity))
+ and then UI_Gt (Object_Access_Level (Lop),
+ Type_Access_Level (Rtyp))
then
Param_Level :=
New_Occurrence_Of
Apply_Constraint_Check (Rhs, Etype (Lhs));
end if;
- -- Ada 2012 (AI05-148): Update current accessibility level if
- -- Rhs is a stand-alone obj of an anonymous access type.
+ -- Ada 2012 (AI05-148): Update current accessibility level if Rhs is a
+ -- stand-alone obj of an anonymous access type.
if Is_Access_Type (Typ)
and then Is_Entity_Name (Lhs)
function Lhs_Entity return Entity_Id is
Result : Entity_Id := Entity (Lhs);
+
begin
while Present (Renamed_Object (Result)) loop
+
-- Renamed_Object must return an Entity_Name here
-- because of preceding "Present (E_E_A (...))" test.
Result := Entity (Renamed_Object (Result));
end loop;
+
return Result;
end Lhs_Entity;
+ -- Local Declarations
+
Access_Check : constant Node_Id :=
- Make_Raise_Program_Error (Loc,
- Condition =>
- Make_Op_Gt (Loc,
- Left_Opnd => Dynamic_Accessibility_Level (Rhs),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Scope_Depth (Enclosing_Dynamic_Scope (Lhs_Entity)))),
- Reason => PE_Accessibility_Check_Failed);
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd =>
+ Dynamic_Accessibility_Level (Rhs),
+ Right_Opnd =>
+ Make_Integer_Literal (Loc,
+ Intval =>
+ Scope_Depth
+ (Enclosing_Dynamic_Scope
+ (Lhs_Entity)))),
+ Reason => PE_Accessibility_Check_Failed);
Access_Level_Update : constant Node_Id :=
- Make_Assignment_Statement (Loc,
- Name => New_Occurrence_Of (
- Effective_Extra_Accessibility (Entity (Lhs)), Loc),
- Expression => Dynamic_Accessibility_Level (Rhs));
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Occurrence_Of
+ (Effective_Extra_Accessibility
+ (Entity (Lhs)), Loc),
+ Expression =>
+ Dynamic_Accessibility_Level (Rhs));
+
begin
if not Accessibility_Checks_Suppressed (Entity (Lhs)) then
Insert_Action (N, Access_Check);
end if;
+
Insert_Action (N, Access_Level_Update);
end;
end if;
if Is_Access_Type (E_Formal)
and then Is_Entity_Name (Lhs)
- and then Present (Effective_Extra_Accessibility
- (Entity (Lhs)))
+ and then
+ Present (Effective_Extra_Accessibility (Entity (Lhs)))
then
-- Copyback target is an Ada 2012 stand-alone object
-- of an anonymous access type
pragma Assert (Ada_Version >= Ada_2012);
if Type_Access_Level (E_Formal) >
- Object_Access_Level (Lhs) then
- Append_To (Post_Call, Make_Raise_Program_Error (Loc,
- Reason => PE_Accessibility_Check_Failed));
+ Object_Access_Level (Lhs)
+ then
+ Append_To (Post_Call,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Accessibility_Check_Failed));
end if;
Append_To (Post_Call,
Name => Lhs,
Expression => Expr));
- -- We would like to somehow suppress generation of
- -- the extra_accessibility assignment generated by
- -- the expansion of the above assignment statement.
- -- It's not a correctness issue because the following
- -- assignment renders it dead, but generating back-to-back
- -- assignments to the same target is undesirable. ???
+ -- We would like to somehow suppress generation of the
+ -- extra_accessibility assignment generated by the expansion
+ -- of the above assignment statement. It's not a correctness
+ -- issue because the following assignment renders it dead,
+ -- but generating back-to-back assignments to the same
+ -- target is undesirable. ???
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
Effective_Extra_Accessibility (Entity (Lhs)), Loc),
Expression => Make_Integer_Literal (Loc,
Type_Access_Level (E_Formal))));
+
else
Append_To (Post_Call,
Make_Assignment_Statement (Loc,
-- For X'Access, pass on the level of the prefix X
when Attribute_Access =>
+
-- If this is an Access attribute applied to the
-- the current instance object passed to a type
-- initialization procedure, then use the level
and then Ekind (Formal) /= E_Out_Parameter
and then Nkind (Prev) /= N_Raise_Constraint_Error
and then (Known_Null (Prev)
- or else not Can_Never_Be_Null (Etype (Prev)))
+ or else not Can_Never_Be_Null (Etype (Prev)))
then
Install_Null_Excluding_Check (Prev);
end if;
if Validity_Checks_On then
if (Ekind (Formal) = E_In_Parameter
- and then Validity_Check_In_Params)
+ and then Validity_Check_In_Params)
or else
(Ekind (Formal) = E_In_Out_Parameter
- and then Validity_Check_In_Out_Params)
+ and then Validity_Check_In_Out_Params)
then
-- If the actual is an indexed component of a packed type (or
-- is an indexed or selected component whose prefix recursively
to initialize large arrays.
@unnumberedsec C.5(8): Pragma @code{Discard_Names}
-
@sp 1
@cartouche
If the pragma applies to an entity, then the implementation should
@end cartouche
Followed.
+@cindex pragma Volatile
+@findex Volatile
+@unnumberedsec C.6(16): Definition of effect of pragma Volatile
+@sp 1
+@cartouche
+All tasks of the program (on all processors) that read or update volatile
+variables see the same order of updates to the variables.
+@end cartouche
+
+The semantics for pragma volatile is that provided by the gcc back-end for
+implementation of volatile in C or C++. On some targets this may meet the
+serialization requirement stated above. On other targets this implementation
+advice is not followed.
+
@cindex Package @code{Task_Attributes}
@findex Task_Attributes
@unnumberedsec C.7.2(30): The Package Task_Attributes
-- --
------------------------------------------------------------------------------
-with ALFA; use ALFA;
-with Einfo; use Einfo;
-with Nmake; use Nmake;
+with ALFA; use ALFA;
+with Einfo; use Einfo;
+with Nmake; use Nmake;
with Put_ALFA;
+
with GNAT.HTable;
separate (Lib.Xref)
Heap : Entity_Id;
- -- Start of processing for Add_ALFA_Xrefs
- begin
+ -- Start of processing for Add_ALFA_Xrefs
+ begin
for J in ALFA_Scope_Table.First .. ALFA_Scope_Table.Last loop
Set_Scope_Num (N => ALFA_Scope_Table.Table (J).Scope_Entity,
Num => ALFA_Scope_Table.Table (J).Scope_Num);
Line => Int (Get_Logical_Line_Number (XE.Loc)),
Rtype => XE.Typ,
Col => Int (Get_Column_Number (XE.Loc))));
+
else
ALFA_Xref_Table.Append (
(Entity_Name => Cur_Entity_Name,
Addr := N_Addr + Header_And_Padding;
-- Homogeneous masters service the following:
- --
+
-- 1) Allocations on / Deallocations from regular pools
-- 2) Named access types
-- 3) Most cases of anonymous access types usage
end if;
-- Heterogeneous masters service the following:
- --
+
-- 1) Allocations on / Deallocations from subpools
-- 2) Certain cases of anonymous access types usage
if Ada_Version >= Ada_2005
and then (Is_Local_Anonymous_Access (Btyp)
- -- Handle cases where Btyp is the
- -- anonymous access type of an Ada 2012
- -- stand-alone object.
+ -- Handle cases where Btyp is the
+ -- anonymous access type of an Ada 2012
+ -- stand-alone object.
- or else Nkind (Associated_Node_For_Itype
- (Btyp)) = N_Object_Declaration)
+ or else Nkind (Associated_Node_For_Itype (Btyp)) =
+ N_Object_Declaration)
and then Object_Access_Level (P)
> Deepest_Type_Access_Level (Btyp)
and then Attr_Id = Attribute_Access
elsif Def_Kind = N_Access_Definition then
T := Access_Definition (Related_Nod, Obj_Def);
- Set_Is_Local_Anonymous_Access (T, V => (Ada_Version < Ada_2012)
- or else (Nkind (P) /= N_Object_Declaration)
- or else Is_Library_Level_Entity (Defining_Identifier (P)));
+ Set_Is_Local_Anonymous_Access
+ (T,
+ V => (Ada_Version < Ada_2012)
+ or else (Nkind (P) /= N_Object_Declaration)
+ or else Is_Library_Level_Entity (Defining_Identifier (P)));
-- Otherwise, the object definition is just a subtype_mark
-- of an anonymous access type.
or else (Ekind (T1) = E_Anonymous_Access_Type
- and then Nkind (Associated_Node_For_Itype (T1))
- = N_Object_Declaration)
+ and then Nkind (Associated_Node_For_Itype (T1)) =
+ N_Object_Declaration)
then
Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
end if;
Set_Ekind (Id, E_Variable);
+
+ -- Initialize the object size and alignment. Note that we used to call
+ -- Init_Size_Align here, but that's wrong for objects which have only
+ -- an Esize, not an RM_Size field!
+
Init_Object_Size_Align (Id);
if T = Any_Type or else Etype (Nam) = Any_Type then
Typ := Etype (Subp);
end if;
+ -- The following should be better commented, especially since
+ -- we just added several new conditions here ???
+
if Comes_From_Source (Subp)
and then Is_Interface (Typ)
and then not Is_Class_Wide_Type (Typ)
and then Is_Dispatching_Operation (Entity (Selector_Name (N)))
then
Analyze_Selected_Component (N);
+
if Nkind (N) /= N_Selected_Component then
return;
end if;
Report_Errs : Boolean := True) return Boolean
is
Target_Type : constant Entity_Id := Base_Type (Target);
- Opnd_Type : Entity_Id := Etype (Operand);
+ Opnd_Type : Entity_Id := Etype (Operand);
function Conversion_Check
(Valid : Boolean;
Msg : String) return Boolean;
-- Little routine to post Msg if Valid is False, returns Valid value
+ -- The following are badly named, this kind of overloading is actively
+ -- confusing in reading code, please rename to something like
+ -- Error_Msg_N_If_Reporting ???
+
procedure Error_Msg_N (Msg : String; N : Node_Or_Entity_Id);
-- If Report_Errs, then calls Errout.Error_Msg_N with its arguments
if Ekind (Target_Type) /= E_Anonymous_Access_Type then
if Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
-
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
-- will be generated by Expand_N_Type_Conversion.
Operand);
Error_Msg_N
("\?Program_Error will be raised at run time", Operand);
+
else
Error_Msg_N
("cannot convert local pointer to non-local access type",
if Ekind (Target_Type) /= E_Anonymous_Access_Type
or else Is_Local_Anonymous_Access (Target_Type)
or else Nkind (Associated_Node_For_Itype (Target_Type)) =
- N_Object_Declaration
+ N_Object_Declaration
then
-- Ada 2012 (AI05-0149): Perform legality checking on implicit
-- conversions from an anonymous access type to a named general
-- implicit conversion is disallowed (by RM12-8.6(27.1/3)).
elsif Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
Error_Msg_N
("implicit conversion of anonymous access value " &
end if;
elsif Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
-
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
-- will be generated by Expand_N_Type_Conversion.
if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) >
- Deepest_Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
-- In an instance, this is a run-time check, but one we know
-- will fail, so generate an appropriate warning. The raise
-- Check the static accessibility rule of 4.6(20)
if Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
+ Deepest_Type_Access_Level (Target_Type)
then
Error_Msg_N
("operand type has deeper accessibility level than target",
and then not Is_Local_Anonymous_Access (Typ)
and then Nkind (Associated_Node_For_Itype (Typ)) = N_Object_Declaration
then
- -- Typ is the type of an Ada 2012 stand-alone object of an
- -- anonymous access type.
+ -- Typ is the type of an Ada 2012 stand-alone object of an anonymous
+ -- access type.
+
+ return
+ Scope_Depth (Enclosing_Dynamic_Scope
+ (Defining_Identifier
+ (Associated_Node_For_Itype (Typ))));
- return Scope_Depth (Enclosing_Dynamic_Scope (Defining_Identifier (
- Associated_Node_For_Itype (Typ))));
else
return Type_Access_Level (Typ);
end if;
-- from a library package which is not within any subprogram.
function Deepest_Type_Access_Level (Typ : Entity_Id) return Uint;
- -- Same as Type_Access_Level, except that if the
- -- type is the type of an Ada 2012 stand-alone object of an
- -- anonymous access type, then return the static accesssibility level
- -- of the object. In that case, the dynamic accessibility level
- -- of the object may take on values in a range. The low bound of
- -- of that range is returned by Type_Access_Level; this
- -- function yields the high bound of that range.
+ -- Same as Type_Access_Level, except that if the type is the type of an Ada
+ -- 2012 stand-alone object of an anonymous access type, then return the
+ -- static accesssibility level of the object. In that case, the dynamic
+ -- accessibility level of the object may take on values in a range. The low
+ -- bound of of that range is returned by Type_Access_Level; this function
+ -- yields the high bound of that range.
function Defining_Entity (N : Node_Id) return Entity_Id;
-- Given a declaration N, returns the associated defining entity. If the
-- name, a defining program unit name or an identifier.
function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id;
- -- Expr should be an expression of an access type.
- -- Builds an integer literal except in cases involving anonymous
- -- access types where accessibility levels are tracked at runtime
- -- (access parameters and Ada 2012 stand-alone objects).
+ -- Expr should be an expression of an access type. Builds an integer
+ -- literal except in cases involving anonymous access types where
+ -- accessibility levels are tracked at runtime (access parameters and Ada
+ -- 2012 stand-alone objects).
function Effective_Extra_Accessibility (Id : Entity_Id) return Entity_Id;
-- Same as Einfo.Extra_Accessibility except thtat object renames
OSDN Git Service
