-- the instance and the generic, so that the back-end can establish the
-- proper order of elaboration.
+ function Get_Associated_Entity (Id : Entity_Id) return Entity_Id;
+ -- Similar to Get_Associated_Node below, but for entities
+
function Get_Associated_Node (N : Node_Id) return Node_Id;
-- In order to propagate semantic information back from the analyzed copy
-- to the original generic, we maintain links between selected nodes in the
Restore_SPARK_Mode (Saved_SM, Saved_SMP);
end Analyze_Subprogram_Instantiation;
+ ---------------------------
+ -- Get_Associated_Entity --
+ ---------------------------
+
+ function Get_Associated_Entity (Id : Entity_Id) return Entity_Id is
+ Assoc : Entity_Id;
+
+ begin
+ Assoc := Associated_Entity (Id);
+
+ if Present (Assoc) then
+ while Present (Associated_Entity (Assoc)) loop
+ Assoc := Associated_Entity (Assoc);
+ end loop;
+ end if;
+
+ return Assoc;
+ end Get_Associated_Entity;
+
-------------------------
-- Get_Associated_Node --
-------------------------
------------------------
procedure Check_Private_View (N : Node_Id) is
- T : constant Entity_Id := Etype (N);
- BT : Entity_Id;
+ Typ : constant Entity_Id := Etype (N);
- begin
- -- Exchange views if the type was not private in the generic but is
- -- private at the point of instantiation. Do not exchange views if
- -- the scope of the type is in scope. This can happen if both generic
- -- and instance are sibling units, or if type is defined in a parent.
- -- In this case the visibility of the type will be correct for all
- -- semantic checks.
+ procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean);
+ -- Check that the available view of T matches Private_View and, if not,
+ -- switch the view of T or of its base type.
+
+ procedure Check_Private_Type (T : Entity_Id; Private_View : Boolean) is
+ BT : constant Entity_Id := Base_Type (T);
+
+ begin
+ -- If the full declaration was not visible in the generic, stop here
+
+ if Private_View then
+ return;
+ end if;
- if Present (T) then
- BT := Base_Type (T);
+ -- Exchange views if the type was not private in the generic but is
+ -- private at the point of instantiation. Do not exchange views if
+ -- the scope of the type is in scope. This can happen if both generic
+ -- and instance are sibling units, or if type is defined in a parent.
+ -- In this case the visibility of the type will be correct for all
+ -- semantic checks.
if Is_Private_Type (T)
- and then not Has_Private_View (N)
and then Present (Full_View (T))
and then not In_Open_Scopes (Scope (T))
then
- -- In the generic, the full declaration was visible
-
Switch_View (T);
- elsif Has_Private_View (N)
- and then not Is_Private_Type (T)
- and then not Has_Been_Exchanged (T)
- and then (not In_Open_Scopes (Scope (T))
- or else Nkind (Parent (N)) = N_Subtype_Declaration)
- then
- -- In the generic, only the private declaration was visible
-
- -- If the type appears in a subtype declaration, the subtype in
- -- instance must have a view compatible with that of its parent,
- -- which must be exchanged (see corresponding code in Restore_
- -- Private_Views) so we make an exception to the open scope rule.
-
- Prepend_Elmt (T, Exchanged_Views);
- Exchange_Declarations (Etype (Get_Associated_Node (N)));
-
- -- Finally, a non-private subtype may have a private base type, which
+ -- Finally, a nonprivate subtype may have a private base type, which
-- must be exchanged for consistency. This can happen when a package
-- body is instantiated, when the scope stack is empty but in fact
-- the subtype and the base type are declared in an enclosing scope.
-- provision for that case in Switch_View).
elsif not Is_Private_Type (T)
- and then not Has_Private_View (N)
and then Is_Private_Type (BT)
and then Present (Full_View (BT))
- and then not Is_Generic_Type (BT)
and then not In_Open_Scopes (BT)
then
Prepend_Elmt (Full_View (BT), Exchanged_Views);
Exchange_Declarations (BT);
end if;
+ end Check_Private_Type;
+
+ begin
+ if Present (Typ) then
+ -- If the type appears in a subtype declaration, the subtype in
+ -- instance must have a view compatible with that of its parent,
+ -- which must be exchanged (see corresponding code in Restore_
+ -- Private_Views) so we make an exception to the open scope rule
+ -- implemented by Check_Private_Type above.
+
+ if Has_Private_View (N)
+ and then not Is_Private_Type (Typ)
+ and then not Has_Been_Exchanged (Typ)
+ and then (not In_Open_Scopes (Scope (Typ))
+ or else Nkind (Parent (N)) = N_Subtype_Declaration)
+ then
+ -- In the generic, only the private declaration was visible
+
+ Prepend_Elmt (Typ, Exchanged_Views);
+ Exchange_Declarations (Etype (Get_Associated_Node (N)));
+
+ else
+ Check_Private_Type (Typ, Has_Private_View (N));
+
+ if Is_Access_Type (Typ) then
+ Check_Private_Type
+ (Designated_Type (Typ), Has_Secondary_Private_View (N));
+
+ elsif Is_Array_Type (Typ) then
+ Check_Private_Type
+ (Component_Type (Typ), Has_Secondary_Private_View (N));
+ end if;
+ end if;
end if;
end Check_Private_View;
Set_Entity (New_N, Entity (Assoc));
Check_Private_View (N);
- -- Here we deal with a very peculiar case for which the
- -- Has_Private_View mechanism is not sufficient, because
- -- the reference to the type is implicit in the tree,
- -- that is to say, it's not referenced from a node but
- -- only from another type, namely through Component_Type.
-
- -- package P is
-
- -- type Pt is private;
-
- -- generic
- -- type Ft is array (Positive range <>) of Pt;
- -- package G is
- -- procedure Check (F1, F2 : Ft; Lt : Boolean);
- -- end G;
-
- -- private
- -- type Pt is new Boolean;
- -- end P;
-
- -- package body P is
- -- package body G is
- -- procedure Check (F1, F2 : Ft; Lt : Boolean) is
- -- begin
- -- if (F1 < F2) /= Lt then
- -- null;
- -- end if;
- -- end Check;
- -- end G;
- -- end P;
-
- -- type Arr is array (Positive range <>) of P.Pt;
-
- -- package Inst is new P.G (Arr);
-
- -- Pt is a global type for the generic package G and it
- -- is not referenced in its body, but only as component
- -- type of Ft, which is a local type. This means that no
- -- references to Pt or Ft are seen during the copy of the
- -- body, the only reference to Pt being seen is when the
- -- actuals are checked by Check_Generic_Actuals, but Pt
- -- is still private at this point. In the end, the views
- -- of Pt are not switched in the body and, therefore, the
- -- array comparison is rejected because the component is
- -- still private.
-
- -- Adding e.g. a dummy variable of type Pt in the body is
- -- sufficient to make everything work, so we generate an
- -- artificial reference to Pt on the fly and thus force
- -- the switching of views on the grounds that, if the
- -- comparison was accepted during the semantic analysis
- -- of the generic, this means that the component cannot
- -- have been private (see Sem_Type.Valid_Comparison_Arg).
-
- if Nkind (Assoc) in N_Op_Compare
- and then Present (Etype (Left_Opnd (Assoc)))
- and then Is_Array_Type (Etype (Left_Opnd (Assoc)))
- and then Present (Etype (Right_Opnd (Assoc)))
- and then Is_Array_Type (Etype (Right_Opnd (Assoc)))
+ -- For the comparison and equality operators, the Etype
+ -- of the operator does not provide any information so,
+ -- if one of the operands is of a universal type, we need
+ -- to manually restore the full view of private types.
+
+ if Nkind (N) in N_Op_Eq
+ | N_Op_Ge
+ | N_Op_Gt
+ | N_Op_Le
+ | N_Op_Lt
+ | N_Op_Ne
then
- declare
- Ltyp : constant Entity_Id :=
- Etype (Left_Opnd (Assoc));
- Rtyp : constant Entity_Id :=
- Etype (Right_Opnd (Assoc));
- begin
- if Is_Private_Type (Component_Type (Ltyp)) then
- Check_Private_View
- (New_Occurrence_Of (Component_Type (Ltyp),
- Sloc (N)));
- end if;
- if Is_Private_Type (Component_Type (Rtyp)) then
- Check_Private_View
- (New_Occurrence_Of (Component_Type (Rtyp),
- Sloc (N)));
+ if Yields_Universal_Type (Left_Opnd (Assoc)) then
+ if Present (Etype (Right_Opnd (Assoc)))
+ and then
+ Is_Private_Type (Etype (Right_Opnd (Assoc)))
+ then
+ Switch_View (Etype (Right_Opnd (Assoc)));
end if;
- end;
-
- -- Here is a similar case, for the Designated_Type of an
- -- access type that is present as target type in a type
- -- conversion from another access type. In this case, if
- -- the base types of the designated types are different
- -- and the conversion was accepted during the semantic
- -- analysis of the generic, this means that the target
- -- type cannot have been private (see Valid_Conversion).
-
- elsif Nkind (Assoc) = N_Identifier
- and then Nkind (Parent (Assoc)) = N_Type_Conversion
- and then Subtype_Mark (Parent (Assoc)) = Assoc
- and then Present (Etype (Assoc))
- and then Is_Access_Type (Etype (Assoc))
- and then Present (Etype (Expression (Parent (Assoc))))
- and then
- Is_Access_Type (Etype (Expression (Parent (Assoc))))
- then
- declare
- Targ_Desig : constant Entity_Id :=
- Designated_Type (Etype (Assoc));
- Expr_Desig : constant Entity_Id :=
- Designated_Type
- (Etype (Expression (Parent (Assoc))));
- begin
- if Base_Type (Targ_Desig) /= Base_Type (Expr_Desig)
- and then Is_Private_Type (Targ_Desig)
+
+ elsif Yields_Universal_Type (Right_Opnd (Assoc)) then
+ if Present (Etype (Left_Opnd (Assoc)))
+ and then
+ Is_Private_Type (Etype (Left_Opnd (Assoc)))
then
- Check_Private_View
- (New_Occurrence_Of (Targ_Desig, Sloc (N)));
+ Switch_View (Etype (Left_Opnd (Assoc)));
end if;
- end;
+ end if;
end if;
-- The node is a reference to a global type and acts as the
-- install the full view (and that of its ancestors, if any).
declare
- T : Entity_Id := (Etype (Get_Associated_Node (New_N)));
+ T : Entity_Id := Etype (Get_Associated_Node (N));
Rt : Entity_Id;
begin
Copy_Descendants;
end;
+ -- Iterator and loop parameter specifications do not have an identifier
+ -- denoting the index type, so we must locate it through the expression
+ -- to check whether the views are consistent.
+
+ elsif Nkind (N) in N_Iterator_Specification
+ | N_Loop_Parameter_Specification
+ and then Instantiating
+ then
+ declare
+ Id : constant Entity_Id :=
+ Get_Associated_Entity (Defining_Identifier (N));
+
+ Index_T : Entity_Id;
+
+ begin
+ if Present (Id) and then Present (Etype (Id)) then
+ Index_T := First_Subtype (Etype (Id));
+
+ if Present (Index_T) and then Is_Private_Type (Index_T) then
+ Switch_View (Index_T);
+ end if;
+ end if;
+
+ Copy_Descendants;
+ end;
+
-- For a proper body, we must catch the case of a proper body that
-- replaces a stub. This represents the point at which a separate
-- compilation unit, and hence template file, may be referenced, so we
if Is_Private_Type (Act_T) then
Set_Has_Private_View (Subtype_Indication (Decl_Node));
+
+ elsif (Is_Access_Type (Act_T)
+ and then Is_Private_Type (Designated_Type (Act_T)))
+ or else (Is_Array_Type (Act_T)
+ and then Is_Private_Type (Component_Type (Act_T)))
+ then
+ Set_Has_Secondary_Private_View (Subtype_Indication (Decl_Node));
end if;
-- In Ada 2012 the actual may be a limited view. Indicate that
return
Is_Generic_Declaration_Or_Body
(Unit_Declaration_Node
- (Associated_Entity (Defining_Entity (Nod))));
+ (Get_Associated_Entity (Defining_Entity (Nod))));
-- Otherwise the generic unit being processed is not the top
-- level template. It is safe to capture of global references
-- type is already the full view (see below). Indicate that the
-- original node has a private view.
- if Entity (N) /= N2 and then Has_Private_View (Entity (N)) then
- Set_Has_Private_View (N);
+ if Entity (N) /= N2 then
+ if Has_Private_View (Entity (N)) then
+ Set_Has_Private_View (N);
+ end if;
+
+ if Has_Secondary_Private_View (Entity (N)) then
+ Set_Has_Secondary_Private_View (N);
+ end if;
end if;
- -- If not a private type, nothing else to do
+ -- If not a private type, deal with a secondary private view
if not Is_Private_Type (Typ) then
- null;
+ if (Is_Access_Type (Typ)
+ and then Is_Private_Type (Designated_Type (Typ)))
+ or else (Is_Array_Type (Typ)
+ and then Is_Private_Type (Component_Type (Typ)))
+ then
+ Set_Has_Secondary_Private_View (N);
+ end if;
-- If it is a derivation of a private type in a context where no
-- full view is needed, nothing to do either.
-- abbreviations are used:
-- "plus fields for binary operator"
- -- Chars Name_Id for the operator
- -- Left_Opnd left operand expression
- -- Right_Opnd right operand expression
- -- Entity defining entity for operator
- -- Associated_Node for generic processing
- -- Do_Overflow_Check set if overflow check needed
- -- Has_Private_View set in generic units.
+ -- Chars Name_Id for the operator
+ -- Left_Opnd left operand expression
+ -- Right_Opnd right operand expression
+ -- Entity defining entity for operator
+ -- Associated_Node for generic processing
+ -- Do_Overflow_Check set if overflow check needed
+ -- Has_Private_View set in generic units
+ -- Has_Secondary_Private_View set in generic units
-- "plus fields for unary operator"
- -- Chars Name_Id for the operator
- -- Right_Opnd right operand expression
- -- Entity defining entity for operator
- -- Associated_Node for generic processing
- -- Do_Overflow_Check set if overflow check needed
- -- Has_Private_View set in generic units.
+ -- Chars Name_Id for the operator
+ -- Right_Opnd right operand expression
+ -- Entity defining entity for operator
+ -- Associated_Node for generic processing
+ -- Do_Overflow_Check set if overflow check needed
+ -- Has_Private_View set in generic units
+ -- Has_Secondary_Private_View set in generic units
-- "plus fields for expression"
-- Paren_Count number of parentheses levels
-- A flag present in N_Subprogram_Body and N_Task_Definition nodes to
-- flag the presence of a pragma Relative_Deadline.
+ -- Has_Secondary_Private_View
+ -- A flag present in generic nodes that have an entity, to indicate that
+ -- the node is either of an access type whose Designated_Type is private
+ -- or of an array type whose Component_Type is private. Used to exchange
+ -- private and full declarations if the visibility at instantiation is
+ -- different from the visibility at generic definition.
+
-- Has_Self_Reference
-- Present in N_Aggregate and N_Extension_Aggregate. Indicates that one
-- of the expressions contains an access attribute reference to the
-- Is_SPARK_Mode_On_Node
-- Is_Elaboration_Warnings_OK_Node
-- Has_Private_View (set in generic units)
+ -- Has_Secondary_Private_View (set in generic units)
-- Redundant_Use
-- Atomic_Sync_Required
-- plus fields for expression
-- Entity
-- Associated_Node
-- Has_Private_View (set in generic units)
+ -- Has_Secondary_Private_View (set in generic units)
-- plus fields for expression
-- Note: the Entity field will be missing (set to Empty) for character
-- Associated_Node Note this is shared with Entity
-- Etype
-- Has_Private_View (set in generic units)
+ -- Has_Secondary_Private_View (set in generic units)
-- Note: the Strval field may be set to No_String for generated
-- operator symbols that are known not to be string literals
-- Is_SPARK_Mode_On_Node
-- Is_Elaboration_Warnings_OK_Node
-- Has_Private_View (set in generic units)
+ -- Has_Secondary_Private_View (set in generic units)
-- Redundant_Use
-- Atomic_Sync_Required
-- plus fields for expression
projects / thirdparty / gcc.git / commitdiff
