+2013-10-17 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_aux.ads, sem_aux.adb (Is_Immutably_Limited_Type): Make
+ predicate compatible with Ada 2012 definition
+ (Is_Limited_View): New name for previous version of
+ Is_Immutably_Limited_Type. Predicate is true for an untagged
+ record type with a limited component.
+ * exp_ch7.adb, exp_ch6.adb, exp_ch4.adb, exp_ch3.adb, exp_aggr.adb,
+ sem_util.adb, sem_res.adb, sem_prag.adb, sem_attr.adb, sem_ch8.adb,
+ sem_ch6.adb, sem_ch3.adb, exp_util.adb: Use Is_Limited_View
+ * freeze.adb Use Is_Immutably_Limited_Type to check the legality
+ of references to the current instance, Is_Limited_View otherwise.
+
2013-10-17 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch13.adb (Analyze_Aspect_Specifications): Flag aspect
-- If component is limited, aggregate must be expanded because each
-- component assignment must be built in place.
- if Is_Immutably_Limited_Type (Component_Type (Typ)) then
+ if Is_Limited_View (Component_Type (Typ)) then
return False;
end if;
-- in place within the caller's scope).
or else
- (Is_Immutably_Limited_Type (Typ)
+ (Is_Limited_View (Typ)
and then
(Nkind (Parent (Parent_Node)) = N_Extended_Return_Statement
or else Nkind (Parent_Node) = N_Simple_Return_Statement))
-- Extension aggregates, aggregates in extended return statements, and
-- aggregates for C++ imported types must be expanded.
- if Ada_Version >= Ada_2005 and then Is_Immutably_Limited_Type (Typ) then
+ if Ada_Version >= Ada_2005 and then Is_Limited_View (Typ) then
if not Nkind_In (Parent (N), N_Object_Declaration,
N_Component_Association)
then
if Needs_Finalization (Typ)
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
- and then not Is_Immutably_Limited_Type (Typ)
+ and then not Is_Limited_View (Typ)
then
Append_To (Res,
Make_Adjust_Call
-- creating the object (via allocator) and initializing it.
if Is_Return_Object (Def_Id)
- and then Is_Immutably_Limited_Type (Typ)
+ and then Is_Limited_View (Typ)
then
null;
-- renaming declaration.
if Needs_Finalization (Typ)
- and then not Is_Immutably_Limited_Type (Typ)
+ and then not Is_Limited_View (Typ)
and then not Rewrite_As_Renaming
then
Insert_Action_After (Init_After,
-- want to Adjust.
if not Aggr_In_Place
- and then not Is_Immutably_Limited_Type (T)
+ and then not Is_Limited_View (T)
then
Insert_Action (N,
-- result from the secondary stack.
if Needs_Finalization (Etype (Subp)) then
- if not Is_Immutably_Limited_Type (Etype (Subp))
+ if not Is_Limited_View (Etype (Subp))
and then
(No (First_Formal (Subp))
or else
then
null;
- elsif Is_Immutably_Limited_Type (Typ) then
+ elsif Is_Limited_View (Typ) then
Set_Returns_By_Ref (Spec_Id);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
-- the type of the expression may be.
if not Comes_From_Extended_Return_Statement (N)
- and then Is_Immutably_Limited_Type (Etype (Expression (N)))
+ and then Is_Limited_View (Etype (Expression (N)))
and then Ada_Version >= Ada_2005
and then not Debug_Flag_Dot_L
-- type that requires special processing (indicated by the fact that
-- it requires a cleanup scope for the secondary stack case).
- if Is_Immutably_Limited_Type (Exptyp)
+ if Is_Limited_View (Exptyp)
or else Is_Limited_Interface (Exptyp)
then
null;
-- may return objects of nonlimited descendants.
else
- return Is_Immutably_Limited_Type (Etype (E))
+ return Is_Limited_View (Etype (E))
and then Ada_Version >= Ada_2005
and then not Debug_Flag_Dot_L;
end if;
Typ : constant Entity_Id := Etype (Subp);
Utyp : constant Entity_Id := Underlying_Type (Typ);
begin
- if Is_Immutably_Limited_Type (Typ) then
+ if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Subp);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Subp);
Typ => Typ,
Stmts => Make_Deep_Array_Body (Initialize_Case, Typ)));
- if not Is_Immutably_Limited_Type (Typ) then
+ if not Is_Limited_View (Typ) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Adjust_Case,
Typ => Typ,
Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
- if not Is_Immutably_Limited_Type (Typ) then
+ if not Is_Limited_View (Typ) then
Set_TSS (Typ,
Make_Deep_Proc
(Prim => Adjust_Case,
-- function being called is build-in-place. This will have to be revised
-- when build-in-place functions are generalized to other types.
- elsif Is_Immutably_Limited_Type (Exp_Typ)
+ elsif Is_Limited_View (Exp_Typ)
and then
(Is_Class_Wide_Type (Exp_Typ)
or else Is_Interface (Exp_Typ)
if Ada_Version >= Ada_2005
and then Nkind (Exp) = N_Function_Call
- and then Is_Immutably_Limited_Type (Etype (Exp))
+ and then Is_Limited_View (Etype (Exp))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
then
declare
if Has_Private_Declaration (E) then
if (not Is_Record_Type (E)
- or else not Is_Immutably_Limited_Type (E))
+ or else not Is_Limited_View (E))
and then not Is_Private_Type (E)
then
Error_Msg_Name_1 := Name_Simple_Storage_Pool_Type;
-- Loop_Entry must create a constant initialized by the evaluated
-- prefix.
- if Is_Immutably_Limited_Type (Etype (P)) then
+ if Is_Limited_View (Etype (P)) then
Error_Attr_P ("prefix of attribute % cannot be limited");
end if;
then
Error_Attr_P ("prefix of attribute % must be a record or array");
- elsif Is_Immutably_Limited_Type (P_Type) then
+ elsif Is_Limited_View (P_Type) then
Error_Attr ("prefix of attribute % cannot be limited", N);
elsif Nkind (E1) /= N_Aggregate then
end if;
end Is_Generic_Formal;
- -------------------------------
- -- Is_Immutably_Limited_Type --
- -------------------------------
+ ---------------------
+ -- Is_Limited_View --
+ ---------------------
- function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
+ function Is_Limited_View (Ent : Entity_Id) return Boolean is
Btype : constant Entity_Id := Available_View (Base_Type (Ent));
begin
if No (Utyp) then
return False;
else
- return Is_Immutably_Limited_Type (Utyp);
+ return Is_Limited_View (Utyp);
end if;
end;
end if;
-- of a type that is not inherently limited.
if Is_Class_Wide_Type (Btype) then
- return Is_Immutably_Limited_Type (Root_Type (Btype));
+ return Is_Limited_View (Root_Type (Btype));
else
declare
-- limited interfaces.
if not Is_Interface (Etype (C))
- and then Is_Immutably_Limited_Type (Etype (C))
+ and then Is_Limited_View (Etype (C))
then
return True;
end if;
end if;
elsif Is_Array_Type (Btype) then
- return Is_Immutably_Limited_Type (Component_Type (Btype));
+ return Is_Limited_View (Component_Type (Btype));
+
+ else
+ return False;
+ end if;
+ end Is_Limited_View;
+
+ -------------------------------
+ -- Is_Immutably_Limited_Type --
+ -------------------------------
+
+ function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
+ Btype : constant Entity_Id := Available_View (Base_Type (Ent));
+
+ begin
+ if Is_Limited_Record (Btype) then
+ return True;
+
+ elsif Ekind (Btype) = E_Limited_Private_Type
+ and then Nkind (Parent (Btype)) = N_Formal_Type_Declaration
+ then
+ return not In_Package_Body (Scope ((Btype)));
+
+ elsif Is_Private_Type (Btype) then
+
+ -- AI05-0063: A type derived from a limited private formal type is
+ -- not immutably limited in a generic body.
+
+ if Is_Derived_Type (Btype)
+ and then Is_Generic_Type (Etype (Btype))
+ then
+ if not Is_Limited_Type (Etype (Btype)) then
+ return False;
+
+ -- A descendant of a limited formal type is not immutably limited
+ -- in the generic body, or in the body of a generic child.
+
+ elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
+ return not In_Package_Body (Scope (Btype));
+
+ else
+ return False;
+ end if;
+
+ else
+ declare
+ Utyp : constant Entity_Id := Underlying_Type (Btype);
+ begin
+ if No (Utyp) then
+ return False;
+ else
+ return Is_Immutably_Limited_Type (Utyp);
+ end if;
+ end;
+ end if;
+
+ elsif Is_Concurrent_Type (Btype) then
+ return True;
else
return False;
-- so. False for other type entities, or any entities that are not types.
function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean;
+ -- Implements definition in Ada 2012 RM-7.5 (8.1/3). This differs from the
+ -- following predicate in that an untagged record with immutably limited
+ -- components is NOT by itself immutably limited. This matters, eg. when
+ -- checking the legality of an access to the current instance.
+
+ function Is_Limited_View (Ent : Entity_Id) return Boolean;
-- Ent is any entity. True for a type that is "inherently" limited (i.e.
-- cannot become nonlimited). From the Ada 2005 RM-7.5(8.1/2), "a type with
-- a part that is of a task, protected, or explicitly limited record type".
-- Ent is any entity. Returns true if Ent is a limited type (limited
-- private type, limited interface type, task type, protected type,
-- composite containing a limited component, or a subtype of any of
- -- these types).
+ -- these types). This older routine overlaps with the previous one, this
+ -- should be cleaned up?
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
-- Given a subtype Typ, this function finds out the nearest ancestor from
-- or else be a partial view.
if Nkind (Discriminant_Type (D)) = N_Access_Definition then
- if Is_Immutably_Limited_Type (Current_Scope)
+ if Is_Limited_View (Current_Scope)
or else
(Nkind (Parent (Current_Scope)) = N_Private_Type_Declaration
and then Limited_Present (Parent (Current_Scope)))
("(Ada 2005) cannot copy object of a limited type " &
"(RM-2005 6.5(5.5/2))", Expr);
- if Is_Immutably_Limited_Type (R_Type) then
+ if Is_Limited_View (R_Type) then
Error_Msg_N
("\return by reference not permitted in Ada 2005", Expr);
end if;
("return of limited object not permitted in Ada 2005 "
& "(RM-2005 6.5(5.5/2))?y?", Expr);
- elsif Is_Immutably_Limited_Type (R_Type) then
+ elsif Is_Limited_View (R_Type) then
Error_Msg_N
("return by reference not permitted in Ada 2005 "
& "(RM-2005 6.5(5.5/2))?y?", Expr);
("aliased only allowed for limited"
& " return objects in Ada 2012?", N);
- elsif not Is_Immutably_Limited_Type (R_Type) then
+ elsif not Is_Limited_View (R_Type) then
Error_Msg_N ("aliased only allowed for limited"
& " return objects", N);
end if;
-- check the static cases.
if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
- and then Is_Immutably_Limited_Type (Etype (Scope_Id))
+ and then Is_Limited_View (Etype (Scope_Id))
and then Object_Access_Level (Expr) >
Subprogram_Access_Level (Scope_Id)
then
Typ : constant Entity_Id := Etype (Designator);
Utyp : constant Entity_Id := Underlying_Type (Typ);
begin
- if Is_Immutably_Limited_Type (Typ) then
+ if Is_Limited_View (Typ) then
Set_Returns_By_Ref (Designator);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
Set_Returns_By_Ref (Designator);
-- there is no copy involved and no performance hit.
if Nkind (Nam) = N_Function_Call
- and then Is_Immutably_Limited_Type (Etype (Nam))
+ and then Is_Limited_View (Etype (Nam))
and then not Is_Constrained (Etype (Nam))
and then Comes_From_Source (N)
then
-- in Freeze_Entity).
if Is_Record_Type (Typ)
- and then not Is_Immutably_Limited_Type (Typ)
+ and then not Is_Limited_View (Typ)
then
Error_Pragma
("pragma% can only apply to explicitly limited record type");
-- of the current b-i-p implementation to unify the handling for
-- multiple kinds of storage pools). ???
- if Is_Immutably_Limited_Type (Desig_T)
+ if Is_Limited_View (Desig_T)
and then Nkind (Expression (E)) = N_Function_Call
then
declare
if Ada_Version >= Ada_2012
and then Is_Limited_Type (Desig_T)
- and then not Is_Immutably_Limited_Type (Scope (Discr))
+ and then not Is_Limited_View (Scope (Discr))
then
Error_Msg_N
("only immutably limited types can have anonymous "
-- statement is aliased if its type is immutably limited.
or else (Is_Return_Object (E)
- and then Is_Immutably_Limited_Type (Etype (E)));
+ and then Is_Limited_View (Etype (E)));
elsif Nkind (Obj) = N_Selected_Component then
return Is_Aliased (Entity (Selector_Name (Obj)));
projects / platform / upstream / gcc.git / commitdiff