2010-10-11 Javier Miranda <miranda@adacore.com>
* exp_ch6.adb (Expand_Call): For VM platforms, add missing expansion of
tag check in case of dispatching call through "=".
2010-10-11 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Access_Subprogram_Declaration): In
Ada2012 an incomplete
type is legal in the profile of any basic declaration.
* sem_ch6.adb (Analyze_Return_Type, Process_Formals): In
Ada2012 an
incomplete type, including a limited view of a type, is legal in the
profile of any subprogram declaration.
If the type is tagged, its use is also legal in a body.
* sem_ch10.adb (Install_Limited_With_Clause): Do not process context
item if misplaced.
(Install_Limited_Withed_Unit): Refine legality checks when both the
limited and the non-limited view of a package are visible in the context
of a unit.
If this is not an error case, the limited view is ignored.
freeze.adb (Freeze_Entity): In
Ada2012, an incomplete type is legal in
access to subprogram declarations
From-SVN: r165295
+2010-10-11 Javier Miranda <miranda@adacore.com>
+
+ * exp_ch6.adb (Expand_Call): For VM platforms, add missing expansion of
+ tag check in case of dispatching call through "=".
+
+2010-10-11 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Access_Subprogram_Declaration): In Ada2012 an incomplete
+ type is legal in the profile of any basic declaration.
+ * sem_ch6.adb (Analyze_Return_Type, Process_Formals): In Ada2012 an
+ incomplete type, including a limited view of a type, is legal in the
+ profile of any subprogram declaration.
+ If the type is tagged, its use is also legal in a body.
+ * sem_ch10.adb (Install_Limited_With_Clause): Do not process context
+ item if misplaced.
+ (Install_Limited_Withed_Unit): Refine legality checks when both the
+ limited and the non-limited view of a package are visible in the context
+ of a unit.
+ If this is not an error case, the limited view is ignored.
+ freeze.adb (Freeze_Entity): In Ada2012, an incomplete type is legal in
+ access to subprogram declarations
+
2010-10-11 Robert Dewar <dewar@adacore.com>
* exp_ch6.adb: Code clean up.
-- access type. If the function call is the initialization expression for a
-- return object, we pass along the master passed in by the caller. The
-- activation chain to pass is always the local one. Note: Master_Actual
- -- can be Empty, but only if there are no tasks
+ -- can be Empty, but only if there are no tasks.
procedure Check_Overriding_Operation (Subp : Entity_Id);
-- Subp is a dispatching operation. Check whether it may override an
-- convoluted tree traversal before setting the proper subprogram to be
-- called.
+ function New_Value (From : Node_Id) return Node_Id;
+ -- From is the original Expression. New_Value is equivalent to a call
+ -- to Duplicate_Subexpr with an explicit dereference when From is an
+ -- access parameter.
+
--------------------------
-- Add_Actual_Parameter --
--------------------------
raise Program_Error;
end Inherited_From_Formal;
+ ---------------
+ -- New_Value --
+ ---------------
+
+ function New_Value (From : Node_Id) return Node_Id is
+ Res : constant Node_Id := Duplicate_Subexpr (From);
+ begin
+ if Is_Access_Type (Etype (From)) then
+ return
+ Make_Explicit_Dereference (Sloc (From),
+ Prefix => Res);
+ else
+ return Res;
+ end if;
+ end New_Value;
+
-- Local variables
Remote : constant Boolean := Is_Remote_Call (Call_Node);
and then Present (Controlling_Argument (Call_Node))
then
declare
+ Call_Typ : constant Entity_Id := Etype (Call_Node);
Typ : constant Entity_Id := Find_Dispatching_Type (Subp);
Eq_Prim_Op : Entity_Id := Empty;
+ New_Call : Node_Id;
+ Param : Node_Id;
+ Prev_Call : Node_Id;
begin
if not Is_Limited_Type (Typ) then
else
Apply_Tag_Checks (Call_Node);
+ -- If this is a dispatching "=", we must first compare the
+ -- tags so we generate: x.tag = y.tag and then x = y
+
+ if Subp = Eq_Prim_Op then
+
+ -- Mark the node as analyzed to avoid reanalizing this
+ -- dispatching call (which would cause a never-ending loop)
+
+ Prev_Call := Relocate_Node (Call_Node);
+ Set_Analyzed (Prev_Call);
+
+ Param := First_Actual (Call_Node);
+ New_Call :=
+ Make_And_Then (Loc,
+ Left_Opnd =>
+ Make_Op_Eq (Loc,
+ Left_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Value (Param),
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Typ),
+ Loc)),
+
+ Right_Opnd =>
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Unchecked_Convert_To (Typ,
+ New_Value (Next_Actual (Param))),
+ Selector_Name =>
+ New_Reference_To
+ (First_Tag_Component (Typ), Loc))),
+ Right_Opnd => Prev_Call);
+
+ Rewrite (Call_Node, New_Call);
+
+ Analyze_And_Resolve
+ (Call_Node, Call_Typ, Suppress => All_Checks);
+ end if;
+
-- Expansion of a dispatching call results in an indirect call,
-- which in turn causes current values to be killed (see
-- Resolve_Call), so on VM targets we do the call here to
-- to the call node because we generated:
-- x.tag = y.tag and then x = y
- if Subp = Eq_Prim_Op
- and then Nkind (Call_Node) = N_Op_And
- then
+ if Subp = Eq_Prim_Op then
Call_Node := Right_Opnd (Call_Node);
end if;
end;
then
if Is_Tagged_Type (Etype (Formal)) then
null;
- else
+
+ -- AI05-151 : incomplete types are allowed in access to
+ -- subprogram specifications.
+
+ elsif Ada_Version < Ada_2012 then
Error_Msg_NE
("invalid use of incomplete type&", E, Etype (Formal));
end if;
while Present (Item) loop
if Nkind (Item) = N_With_Clause
and then Limited_Present (Item)
+ and then not Error_Posted (Item)
then
if Nkind (Name (Item)) = N_Selected_Component then
Expand_Limited_With_Clause
(Is_Immediately_Visible (P)
or else (Is_Child_Package and then Is_Visible_Child_Unit (P)))
then
- return;
+
+ -- The presence of both the limited and the analyzed nonlimited view
+ -- may also be an error, such as an illegal context for a limited
+ -- with_clause. In that case, do not process the context item at all.
+
+ if Error_Posted (N) then
+ return;
+ end if;
+
+ if Nkind (Unit (Cunit (Current_Sem_Unit))) = N_Package_Body then
+ declare
+ Item : Node_Id;
+ begin
+ Item := First (Context_Items (Cunit (Current_Sem_Unit)));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then Comes_From_Source (Item)
+ and then Entity (Name (Item)) = P
+ then
+ return;
+ end if;
+
+ Next (Item);
+ end loop;
+ end;
+
+ -- If this is a child body, assume that the nonlimited with_clause
+ -- appears in an ancestor. Could be refined ???
+
+ if Is_Child_Unit
+ (Defining_Entity
+ (Unit (Library_Unit (Cunit (Current_Sem_Unit)))))
+ then
+ return;
+ end if;
+
+ else
+
+ -- If in package declaration, nonlimited view brought in from
+ -- parent unit or some error condition.
+
+ return;
+ end if;
end if;
if Debug_Flag_I then
else
if From_With_Type (Typ) then
- Error_Msg_NE
- ("illegal use of incomplete type&",
- Result_Definition (T_Def), Typ);
+
+ -- AI05-151 : incomplete types are allowed in all basic
+ -- declarations, including access to subprograms.
+
+ if Ada_Version >= Ada_2012 then
+ null;
+
+ else
+ Error_Msg_NE
+ ("illegal use of incomplete type&",
+ Result_Definition (T_Def), Typ);
+ end if;
elsif Ekind (Current_Scope) = E_Package
and then In_Private_Part (Current_Scope)
Check_Or_Process_Discriminants (N, Derived_Type);
- -- For non-tagged types the constraint on the Parent_Type must be
+ -- For untagged types, the constraint on the Parent_Type must be
-- present and is used to rename the discriminants.
if not Is_Tagged and then not Has_Discriminants (Parent_Type) then
end if;
-- Final check: Direct descendants must have their primitives in the
- -- same order. We exclude from this test non-tagged types and instances
+ -- same order. We exclude from this test untagged types and instances
-- of formal derived types. We skip this test if we have already
-- reported serious errors in the sources.
("discriminant defaults not allowed for formal type",
Expression (Discr));
- -- Tagged types cannot have defaulted discriminants, but a
- -- non-tagged private type with defaulted discriminants
- -- can have a tagged completion.
+ -- Tagged types declarations cannot have defaulted discriminants,
+ -- but an untagged private type with defaulted discriminants can
+ -- have a tagged completion.
elsif Is_Tagged_Type (Current_Scope)
and then Comes_From_Source (N)
and then
Ekind (Root_Type (Typ)) = E_Incomplete_Type)
then
- Error_Msg_NE
- ("invalid use of incomplete type&", Designator, Typ);
+ -- AI05-0151: Tagged incomplete types are allowed in all formal
+ -- parts. Untagged incomplete types are not allowed in bodies.
+
+ if Ada_Version >= Ada_2012 then
+ if Is_Tagged_Type (Typ) then
+ null;
+
+ elsif Nkind_In (Parent (Parent (N)),
+ N_Accept_Statement,
+ N_Entry_Body,
+ N_Subprogram_Body)
+ then
+ Error_Msg_NE
+ ("invalid use of untagged incomplete type&",
+ Designator, Typ);
+ end if;
+
+ else
+ Error_Msg_NE
+ ("invalid use of incomplete type&", Designator, Typ);
+ end if;
end if;
end if;
elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
N_Access_Procedure_Definition)
then
- Error_Msg_NE
- ("invalid use of incomplete type&",
- Param_Spec, Formal_Type);
- -- Further checks on the legality of incomplete types
- -- in formal parts must be delayed until the freeze point
- -- of the enclosing subprogram or access to subprogram.
+ -- AI05-0151: Tagged incomplete types are allowed in all
+ -- formal parts. Untagged incomplete types are not allowed
+ -- in bodies.
+
+ if Ada_Version >= Ada_2012 then
+ if Is_Tagged_Type (Formal_Type) then
+ null;
+
+ elsif Nkind_In (Parent (Parent (T)),
+ N_Accept_Statement,
+ N_Entry_Body,
+ N_Subprogram_Body)
+ then
+ Error_Msg_NE
+ ("invalid use of untagged incomplete type&",
+ Ptype, Formal_Type);
+ end if;
+
+ else
+ Error_Msg_NE
+ ("invalid use of incomplete type&",
+ Param_Spec, Formal_Type);
+
+ -- Further checks on the legality of incomplete types
+ -- in formal parts are delayed until the freeze point
+ -- of the enclosing subprogram or access to subprogram.
+ end if;
end if;
elsif Ekind (Formal_Type) = E_Void then
projects / gcc.git / commitdiff