+2012-01-30 Robert Dewar <dewar@adacore.com>
+
+ * einfo.ads, sem_prag.adb, sem_attr.adb, aspects.ads,
+ sem_cat.adb, sem_aggr.adb, exp_aggr.adb: Minor reformatting.
+
2012-01-30 Robert Dewar <dewar@adacore.com>
* a-cdlili.adb, a-cidlli.adb, a-cbdlli.adb: Minor reformatting.
-----------------------------------------
-- Table linking aspect names and id's
- -- Shouldn't this be automatically generated in Snames???
Aspect_Names : constant array (Aspect_Id) of Name_Id := (
No_Aspect => No_Name,
-- Is_Generic_Type (Flag13)
-- Present in all entities. Set for types which are generic formal types.
-- Such types have an Ekind that corresponds to their classification, so
--- the Ekind cannot be used to identify generic types.
+-- the Ekind cannot be used to identify generic formal types.
-- Is_Generic_Unit (synthesized)
-- Applies to all entities. Yields True for a generic unit (generic
-- Present in all entities. Set in E_Package and E_Generic_Package
-- entities to which a pragma Remote_Types is applied, and also on
-- entities declared in the visible part of the spec of such a package.
--- Also set for generic formal types to which pragma Remote_Access_Type
--- applies.
+-- Also set for types which are generic formal types to which the
+-- pragma Remote_Access_Type applies.
-- Is_Renaming_Of_Object (Flag112)
-- Present in all entities, set only for a variable or constant for
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Target : Node_Id) return List_Id;
-- This routine implements top-down expansion of nested aggregates. In
-- doing so, it avoids the generation of temporaries at each level. N is a
- -- nested (record or array) aggregate that has been marked with 'Delay_
- -- Expansion'. Typ is the expected type of the aggregate. Target is a
+ -- nested (record or array) aggregate that has been marked with Expansion_
+ -- Delayed. Typ is the expected type of the aggregate. Target is a
-- (duplicable) expression that will hold the result of the aggregate
-- expansion.
-- Ada 2005 (AI-318-2): We need to convert to assignments if components
-- are build-in-place function calls. The assignments will each turn
- -- into a build-in-place function call. If components are all static,
+ -- into a build-in-place function call. If components are all static,
-- we can pass the aggregate to the backend regardless of limitedness.
-- Extension aggregates, aggregates in extended return statements, and
if Is_Tagged_Type (Typ) then
- -- The tagged case, _parent and _tag component must be created
+ -- In the tagged case, _parent and _tag component must be created
- -- Reset null_present unconditionally. tagged records always have
- -- at least one field (the tag or the parent)
+ -- Reset Null_Present unconditionally. Tagged records always have
+ -- at least one field (the tag or the parent).
Set_Null_Record_Present (N, False);
-- When the current aggregate comes from the expansion of an
-- extension aggregate, the parent expr is replaced by an
- -- aggregate formed by selected components of this expr
+ -- aggregate formed by selected components of this expr.
if Present (Parent_Expr)
and then Is_Empty_List (Comps)
-- Compute the value for the Tag now, if the type is a root it
-- will be included in the aggregate right away, otherwise it will
- -- be propagated to the parent aggregate
+ -- be propagated to the parent aggregate.
if Present (Orig_Tag) then
Tag_Value := Orig_Tag;
+
elsif not Tagged_Type_Expansion then
Tag_Value := Empty;
+
else
Tag_Value :=
New_Occurrence_Of
-- Expand recursively the parent propagating the right Tag
- Expand_Record_Aggregate (
- Parent_Aggr, Tag_Value, Parent_Expr);
+ Expand_Record_Aggregate
+ (Parent_Aggr, Tag_Value, Parent_Expr);
end;
-- For a root type, the tag component is added (unless compiling
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- dynamic-sized aggregate in the code, something that gigi cannot
-- handle.
- Relocate : Boolean;
- -- Set to True if the resolved Expr node needs to be relocated
- -- when attached to the newly created association list. This node
- -- need not be relocated if its parent pointer is not set.
- -- In fact in this case Expr is the output of a New_Copy_Tree call.
- -- if Relocate is True then we have analyzed the expression node
- -- in the original aggregate and hence it needs to be relocated
- -- when moved over the new association list.
+ Relocate : Boolean;
+ -- Set to True if the resolved Expr node needs to be relocated when
+ -- attached to the newly created association list. This node need not
+ -- be relocated if its parent pointer is not set. In fact in this
+ -- case Expr is the output of a New_Copy_Tree call. If Relocate is
+ -- True then we have analyzed the expression node in the original
+ -- aggregate and hence it needs to be relocated when moved over to
+ -- the new association list.
+
+ ---------------------------
+ -- Has_Expansion_Delayed --
+ ---------------------------
function Has_Expansion_Delayed (Expr : Node_Id) return Boolean is
Kind : constant Node_Kind := Nkind (Expr);
and then Has_Expansion_Delayed (Expression (Expr)));
end Has_Expansion_Delayed;
- -- Start of processing for Resolve_Aggr_Expr
+ -- Start of processing for Resolve_Aggr_Expr
begin
-- If the type of the component is elementary or the type of the
Set_Raises_Constraint_Error (N);
end if;
- -- If the expression has been marked as requiring a range check,
- -- then generate it here.
+ -- If the expression has been marked as requiring a range check, then
+ -- generate it here.
if Do_Range_Check (Expr) then
Set_Do_Range_Check (Expr, False);
-- If the type has no components, then the aggregate should either
-- have "null record", or in Ada 2005 it could instead have a single
- -- component association given by "others => <>". For Ada 95 we flag
- -- an error at this point, but for Ada 2005 we proceed with checking
- -- the associations below, which will catch the case where it's not
- -- an aggregate with "others => <>". Note that the legality of a <>
+ -- component association given by "others => <>". For Ada 95 we flag an
+ -- error at this point, but for Ada 2005 we proceed with checking the
+ -- associations below, which will catch the case where it's not an
+ -- aggregate with "others => <>". Note that the legality of a <>
-- aggregate for a null record type was established by AI05-016.
elsif No (First_Entity (Typ))
if Is_Remote_Access_To_Class_Wide_Type (Base_Type (P_Type)) then
- if not Is_Generic_Type (P_Type) then
- -- For a real RACW [sub]type, use corresponding stub type
+ -- For a real RACW [sub]type, use corresponding stub type
+ if not Is_Generic_Type (P_Type) then
Rewrite (N,
New_Occurrence_Of
(Corresponding_Stub_Type (Base_Type (P_Type)), Loc));
- else
- -- For a generic type (that has been marked as an RACW using
- -- the Remote_Access_Type aspect or pragma), use a generic RACW
- -- stub type. Note that if the actual is not a remote access
- -- type, the instantiation will fail.
+ -- For a generic type (that has been marked as an RACW using the
+ -- Remote_Access_Type aspect or pragma), use a generic RACW stub
+ -- type. Note that if the actual is not a remote access type, the
+ -- instantiation will fail.
+ else
-- Note: we go to the underlying type here because the view
-- returned by RTE (RE_RACW_Stub_Type) might be incomplete.
if Is_Pure (E)
and then not
- (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E))
+ (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E))
then
return Pure;
-- to WITH anything in the package body, per (RM E.2(5)).
if (Unit_Category = Remote_Types
- or else Unit_Category = Remote_Call_Interface)
+ or else Unit_Category = Remote_Call_Interface)
and then In_Package_Body (Unit_Entity)
then
null;
function Has_Read_Write_Attributes (E : Entity_Id) return Boolean is
begin
return True
- and then Has_Stream_Attribute_Definition (E,
- TSS_Stream_Read, At_Any_Place => True)
- and then Has_Stream_Attribute_Definition (E,
- TSS_Stream_Write, At_Any_Place => True);
+ and then Has_Stream_Attribute_Definition
+ (E, TSS_Stream_Read, At_Any_Place => True)
+ and then Has_Stream_Attribute_Definition
+ (E, TSS_Stream_Write, At_Any_Place => True);
end Has_Read_Write_Attributes;
-------------------------------------
or else Is_Shared_Passive (Unit_Entity)
or else
((Is_Remote_Types (Unit_Entity)
- or else Is_Remote_Call_Interface (Unit_Entity))
+ or else Is_Remote_Call_Interface (Unit_Entity))
and then Ekind (Unit_Entity) = E_Package
and then Unit_Kind /= N_Package_Body
and then not In_Package_Body (Unit_Entity)
and then Is_Package_Or_Generic_Package (Unit_Entity)
and then Unit_Kind /= N_Package_Body
and then List_Containing (N) =
- Visible_Declarations
- (Specification (Unit_Declaration_Node (Unit_Entity)))
+ Visible_Declarations
+ (Specification (Unit_Declaration_Node (Unit_Entity)))
and then not In_Package_Body (Unit_Entity)
and then not In_Instance;
PN : Node_Id;
begin
- if Is_Child_Unit (S)
- and then Is_Generic_Instance (S)
- then
+ if Is_Child_Unit (S) and then Is_Generic_Instance (S) then
Set_Parents (True);
end if;
Next (PN);
end loop;
- if Is_Child_Unit (S)
- and then Is_Generic_Instance (S)
- then
+ if Is_Child_Unit (S) and then Is_Generic_Instance (S) then
Set_Parents (False);
end if;
end;
Specification : Node_Id := Empty;
begin
- Set_Is_Pure (E,
- Is_Pure (Scop) and then Is_Library_Level_Entity (E));
+ Set_Is_Pure
+ (E, Is_Pure (Scop) and then Is_Library_Level_Entity (E));
if not Is_Remote_Call_Interface (E) then
if Ekind (E) in Subprogram_Kind then
Declaration := Unit_Declaration_Node (E);
- if Nkind (Declaration) = N_Subprogram_Body
- or else
- Nkind (Declaration) = N_Subprogram_Renaming_Declaration
+ if Nkind_In (Declaration, N_Subprogram_Body,
+ N_Subprogram_Renaming_Declaration)
then
Specification := Corresponding_Spec (Declaration);
end if;
end if;
- -- A subprogram body or renaming-as-body is a remote call
- -- interface if it serves as the completion of a subprogram
- -- declaration that is a remote call interface.
+ -- A subprogram body or renaming-as-body is a remote call interface
+ -- if it serves as the completion of a subprogram declaration that
+ -- is a remote call interface.
if Nkind (Specification) in N_Entity then
Set_Is_Remote_Call_Interface
Set_Is_Remote_Call_Interface
(E, Is_Remote_Call_Interface (Scop)
and then not (In_Private_Part (Scop)
- or else In_Package_Body (Scop)));
+ or else In_Package_Body (Scop)));
end if;
end if;
Set_Is_Remote_Types
(E, Is_Remote_Types (Scop)
and then not (In_Private_Part (Scop)
- or else In_Package_Body (Scop)));
+ or else In_Package_Body (Scop)));
end Set_Categorization_From_Scope;
------------------------------
if Comes_From_Source (T)
and then not (In_Package_Body (Scope (T))
- or else In_Private_Part (Scope (T)))
+ or else In_Private_Part (Scope (T)))
then
Set_Is_Remote_Call_Interface
(T, Is_Remote_Call_Interface (Scope (T)));
-- Body of RCI unit does not need validation
if Is_Remote_Call_Interface (E)
- and then (Nkind (N) = N_Package_Body
- or else Nkind (N) = N_Subprogram_Body)
+ and then Nkind_In (N, N_Package_Body, N_Subprogram_Body)
then
return;
end if;
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then not (Implicit_With (Item)
- or else Limited_Present (Item)
+ or else Limited_Present (Item)
- -- Skip if error already posted on the WITH
- -- clause (in which case the Name attribute
- -- may be invalid). In particular, this fixes
- -- the problem of hanging in the presence of a
- -- WITH clause on a child that is an illegal
- -- generic instantiation.
+ -- Skip if error already posted on the WITH
+ -- clause (in which case the Name attribute
+ -- may be invalid). In particular, this fixes
+ -- the problem of hanging in the presence of a
+ -- WITH clause on a child that is an illegal
+ -- generic instantiation.
- or else Error_Posted (Item))
+ or else Error_Posted (Item))
then
Entity_Of_Withed := Entity (Name (Item));
Check_Categorization_Dependencies
PEE : Node_Id;
begin
- if Has_Discriminants (ET)
- and then Present (EE)
- then
+ if Has_Discriminants (ET) and then Present (EE) then
PEE := Parent (EE);
if Nkind (PEE) = N_Full_Type_Declaration
-- Check that the return type supports external streaming
elsif No_External_Streaming (Rtyp)
- and then not Error_Posted (Rtyp)
+ and then not Error_Posted (Rtyp)
then
Illegal_Remote_Subp ("return type containing non-remote access "
& "must have Read and Write attributes",
if not Comes_From_Source (T)
or else (not In_RCI_Declaration (Parent (T))
- and then not In_RT_Declaration)
+ and then not In_RT_Declaration)
then
return;
end if;
-- If we have a true dereference that comes from source and that
-- is a controlling argument for a dispatching call, accept it.
- if Is_Actual_Parameter (N)
- and then Is_Controlling_Actual (N)
- then
+ if Is_Actual_Parameter (N) and then Is_Controlling_Actual (N) then
return;
end if;
-- apply in the case of dereference that is the prefix of a selected
-- component, which can be a call given in prefixed form.
- if (Is_Actual_Parameter (N)
- or else PK = N_Selected_Component)
+ if (Is_Actual_Parameter (N) or else PK = N_Selected_Component)
and then not Analyzed (N)
then
return;
-- partition (E.2.2(8)).
if (Ada_Version < Ada_2005 and then Has_Non_Remote_Access (U_Typ))
- or else
- (Stream_Attributes_Available (Typ)
- and then No_External_Streaming (U_Typ))
+ or else (Stream_Attributes_Available (Typ)
+ and then No_External_Streaming (U_Typ))
then
if Is_Non_Remote_Access_Type (Typ) then
Error_Msg_N ("error in non-remote access type", U_Typ);
Direct_Designated_Type : Entity_Id;
function Has_Entry_Declarations (E : Entity_Id) return Boolean;
- -- Return true if the protected type designated by T has
- -- entry declarations.
+ -- Return true if the protected type designated by T has entry
+ -- declarations.
----------------------------
-- Has_Entry_Declarations --
and then
Enclosing_Lib_Unit_Node (N) /= Enclosing_Lib_Unit_Node (E)
and then (Is_Preelaborated (Scope (E))
- or else Is_Pure (Scope (E))
- or else (Present (Renamed_Object (E))
- and then
- Is_Entity_Name (Renamed_Object (E))
- and then
- (Is_Preelaborated
- (Scope (Renamed_Object (E)))
- or else
- Is_Pure (Scope
- (Renamed_Object (E))))))
+ or else Is_Pure (Scope (E))
+ or else (Present (Renamed_Object (E))
+ and then Is_Entity_Name (Renamed_Object (E))
+ and then
+ (Is_Preelaborated
+ (Scope (Renamed_Object (E)))
+ or else
+ Is_Pure (Scope
+ (Renamed_Object (E))))))
then
null;
Check_Arg_Count (1);
Check_Optional_Identifier (Arg1, Name_Entity);
Check_Arg_Is_Local_Name (Arg1);
+
E := Entity (Get_Pragma_Arg (Arg1));
if Nkind (Parent (E)) = N_Formal_Type_Declaration
projects / gcc.git / commitdiff