-- with invariants, and invariant checks are enabled, then insert an
-- invariant check after the object declaration. Note that it is OK
-- to clobber the object with an invalid value since if the exception
- -- is raised, then the object will go out of scope.
+ -- is raised, then the object will go out of scope. In the case where
+ -- an array object is initialized with an aggregate, the expression
+ -- is removed. Check flag Has_Init_Expression to avoid generating a
+ -- junk invariant check.
- if Has_Invariants (Typ)
- and then Present (Invariant_Procedure (Typ))
+ if Has_Invariants (Base_Typ)
+ and then Present (Invariant_Procedure (Base_Typ))
+ and then not Has_Init_Expression (N)
then
Insert_After (N,
Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
-- Initialize call as it is required but one for each ancestor of
-- its type. This processing is suppressed if No_Initialization set.
- if not Needs_Finalization (Typ)
- or else No_Initialization (N)
- then
+ if not Needs_Finalization (Typ) or else No_Initialization (N) then
null;
- elsif not Abort_Allowed
- or else not Comes_From_Source (N)
- then
+ elsif not Abort_Allowed or else not Comes_From_Source (N) then
Insert_Action_After (Init_After,
Make_Init_Call
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Base_Type (Typ)));
+ Typ => Base_Typ));
-- Abort allowed
L : constant List_Id := New_List (
Make_Init_Call
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
- Typ => Base_Type (Typ)));
+ Typ => Base_Typ));
Blk : constant Node_Id :=
Make_Block_Statement (Loc,
Insert_Action_After (Init_After,
Make_Adjust_Call (
Obj_Ref => New_Reference_To (Def_Id, Loc),
- Typ => Base_Type (Typ)));
+ Typ => Base_Typ));
end if;
-- For tagged types, when an init value is given, the tag has to
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Exp_Util; use Exp_Util;
-with Nlists; use Nlists;
with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Res; use Sem_Res;
procedure Expand_SPARK_N_Attribute_Reference (N : Node_Id);
-- Expand attributes 'Old and 'Result only
- procedure Expand_SPARK_N_In (N : Node_Id);
- -- Expand set membership into individual ones
-
procedure Expand_SPARK_N_Object_Renaming_Declaration (N : Node_Id);
-- Perform name evaluation for a renamed object
N_Identifier =>
Expand_Potential_Renaming (N);
- when N_In =>
- Expand_SPARK_N_In (N);
-
-- A NOT IN B gets transformed to NOT (A IN B). This is the same
-- expansion used in the normal case, so shared the code.
end case;
end Expand_SPARK_N_Attribute_Reference;
- -----------------------
- -- Expand_SPARK_N_In --
- -----------------------
-
- procedure Expand_SPARK_N_In (N : Node_Id) is
- begin
- if Present (Alternatives (N)) then
- Expand_Set_Membership (N);
- end if;
- end Expand_SPARK_N_In;
-
------------------------------------------------
-- Expand_SPARK_N_Object_Renaming_Declaration --
------------------------------------------------
or else Scope (T1) /= Scope (T2);
-- If T2 is a generic actual type it is declared as the subtype of
- -- the actual. If that actual is itself a subtype we need to use
- -- its own base type to check for compatibility.
+ -- the actual. If that actual is itself a subtype we need to use its
+ -- own base type to check for compatibility.
elsif Ekind (BT2) = Ekind (T2) and then BT1 = Base_Type (BT2) then
return True;
function Different_Generic_Profile (E : Entity_Id) return Boolean is
F1, F2 : Entity_Id;
+ function Same_Generic_Actual (T1, T2 : Entity_Id) return Boolean;
+ -- Check that the types of corresponding formals have the same
+ -- generic actual if any. We have to account for subtypes of a
+ -- generic formal, declared between a spec and a body, which may
+ -- appear distinct in an instance but matched in the generic.
+
+ -------------------------
+ -- Same_Generic_Actual --
+ -------------------------
+
+ function Same_Generic_Actual (T1, T2 : Entity_Id) return Boolean is
+ begin
+ return Is_Generic_Actual_Type (T1) = Is_Generic_Actual_Type (T2)
+ or else
+ (Present (Parent (T1))
+ and then Comes_From_Source (Parent (T1))
+ and then Nkind (Parent (T1)) = N_Subtype_Declaration
+ and then Is_Entity_Name (Subtype_Indication (Parent (T1)))
+ and then Entity (Subtype_Indication (Parent (T1))) = T2);
+ end Same_Generic_Actual;
+
+ -- Start of processing for Different_Generic_Profile
+
begin
- if Ekind (E) = E_Function
- and then Is_Generic_Actual_Type (Etype (E)) /=
- Is_Generic_Actual_Type (Etype (Designator))
+ if not In_Instance then
+ return False;
+
+ elsif Ekind (E) = E_Function
+ and then not Same_Generic_Actual (Etype (E), Etype (Designator))
then
return True;
end if;
F1 := First_Formal (Designator);
F2 := First_Formal (E);
while Present (F1) loop
- if Is_Generic_Actual_Type (Etype (F1)) /=
- Is_Generic_Actual_Type (Etype (F2))
- then
+ if not Same_Generic_Actual (Etype (F1), Etype (F2)) then
return True;
end if;
-- If E is an internal function with a controlling result that
-- was created for an operation inherited by a null extension,
-- it may be overridden by a body without a previous spec (one
- -- more reason why these should be shunned). In that case
+ -- more reason why these should be shunned). In that case we
-- remove the generated body if present, because the current
-- one is the explicit overriding.
-- All other node types cannot appear in this context. Strictly
-- we should raise a fatal internal error. Instead we just ignore
-- the nodes. This means that if anyone makes a mistake in the
- -- expander and mucks an expression tree irretrievably, the
- -- result will be a failure to detect a (probably very obscure)
- -- case of non-conformance, which is better than bombing on some
+ -- expander and mucks an expression tree irretrievably, the result
+ -- will be a failure to detect a (probably very obscure) case
+ -- of non-conformance, which is better than bombing on some
-- case where two expressions do in fact conform.
when others =>
return Type_Conformant
(Iface_Prim, Prim, Skip_Controlling_Formals => True);
- -- Case of a function returning an interface, or an access to one.
- -- Check that the return types correspond.
+ -- Case of a function returning an interface, or an access to one. Check
+ -- that the return types correspond.
elsif Implements_Interface (Typ, Iface) then
if (Ekind (Etype (Prim)) = E_Anonymous_Access_Type)
Next_Elmt (Prim_Elt);
end loop;
- -- If no match found, then the new subprogram does not
- -- override in the generic (nor in the instance).
+ -- If no match found, then the new subprogram does not override
+ -- in the generic (nor in the instance).
-- If the type in question is not abstract, and the subprogram
-- is, this will be an error if the new operation is in the
-- Insert inequality right after equality if it is explicit or after
-- the derived type when implicit. These entities are created only
- -- for visibility purposes, and eventually replaced in the course of
- -- expansion, so they do not need to be attached to the tree and seen
- -- by the back-end. Keeping them internal also avoids spurious
+ -- for visibility purposes, and eventually replaced in the course
+ -- of expansion, so they do not need to be attached to the tree and
+ -- seen by the back-end. Keeping them internal also avoids spurious
-- freezing problems. The declaration is inserted in the tree for
-- analysis, and removed afterwards. If the equality operator comes
-- from an explicit declaration, attach the inequality immediately
New_E : Entity_Id) return Boolean;
-- Check whether new subprogram and old subprogram are both inherited
-- from subprograms that have distinct dispatch table entries. This can
- -- occur with derivations from instances with accidental homonyms.
- -- The function is conservative given that the converse is only true
- -- within instances that contain accidental overloadings.
+ -- occur with derivations from instances with accidental homonyms. The
+ -- function is conservative given that the converse is only true within
+ -- instances that contain accidental overloadings.
------------------------------------
-- Check_For_Primitive_Subprogram --
Check_Dispatching_Operation (S, Empty);
Check_For_Primitive_Subprogram (Is_Primitive_Subp);
- -- If subprogram has an explicit declaration, check whether it
- -- has an overriding indicator.
+ -- If subprogram has an explicit declaration, check whether it has an
+ -- overriding indicator.
if Comes_From_Source (S) then
Check_Synchronized_Overriding (S, Overridden_Subp);
if Scope (E) /= Current_Scope then
null;
- -- Ada 2012 (AI05-0165): For internally generated bodies of
- -- null procedures locate the internally generated spec. We
- -- enforce mode conformance since a tagged type may inherit
- -- from interfaces several null primitives which differ only
- -- in the mode of the formals.
+ -- Ada 2012 (AI05-0165): For internally generated bodies of null
+ -- procedures locate the internally generated spec. We enforce
+ -- mode conformance since a tagged type may inherit from
+ -- interfaces several null primitives which differ only in
+ -- the mode of the formals.
elsif not Comes_From_Source (S)
and then Is_Null_Procedure (S)
projects / gcc.git / commitdiff