2010-10-08 Robert Dewar <dewar@adacore.com>
+ * sem_prag.adb (Check_Duplicate_Pragma): Check for entity match
+ * gcc-interface/Make-lang.in: Update dependencies.
+ * einfo.ads: Minor reformatting.
+
+2010-10-08 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch5.adb, sem_ch3.adb, exp_ch7.adb, exp_util.adb, sem_aux.adb,
+ sem_aux.ads, exp_ch4.adb, exp_ch6.adb, sem_ch6.adb, exp_aggr.adb,
+ exp_ch3.adb: Change Is_Inherently_Limited_Type to
+ Is_Immutably_Limited_Type to accord with new RM terminology.
+ * sem_aux.adb (Is_Immutably_Limited_Type): A type that is a descendant
+ of a formal limited private type is not immutably limited in a generic
+ body.
+
+2010-10-08 Robert Dewar <dewar@adacore.com>
+
* sem_prag.adb (Check_Duplicate_Pragma): New procedure
Add calls to this new procedure where appropriate
-- 4. Setting Component_Size of an array to a bit-packable value
-- 3. Indexing an array with a non-standard enumeration type.
--
--- For records, Is_Packed is always set if Has_Pack_Pragma is set,
+-- For records, Is_Packed is always set if Has_Pragma_Pack is set,
-- and can also be set on its own in a derived type which inherited
-- its packed status.
--
-- the bit packed case once the array type is frozen.
--
-- Before an array type is frozen, Is_Packed will always be set if
--- Has_Pack_Pragma is set. Before the freeze point, it is not possible
+-- Has_Pragma_Pack is set. Before the freeze point, it is not possible
-- to know the component size, since the component type is not frozen
-- until the array type is frozen. Thus Is_Packed for an array type
-- before it is frozen means that packed is required. Then if it turns
-- If component is limited, aggregate must be expanded because each
-- component assignment must be built in place.
- if Is_Inherently_Limited_Type (Component_Type (Typ)) then
+ if Is_Immutably_Limited_Type (Component_Type (Typ)) then
return False;
end if;
then
RC := RE_Limited_Record_Controller;
- elsif Is_Inherently_Limited_Type (Target_Type) then
+ elsif Is_Immutably_Limited_Type (Target_Type) then
RC := RE_Limited_Record_Controller;
else
-- in place within the caller's scope).
or else
- (Is_Inherently_Limited_Type (Typ)
+ (Is_Immutably_Limited_Type (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_05 and then Is_Inherently_Limited_Type (Typ) then
+ if Ada_Version >= Ada_05 and then Is_Immutably_Limited_Type (Typ) then
if not Nkind_In (Parent (N), N_Object_Declaration,
N_Component_Association)
then
and then Has_New_Controlled_Component (Enclos_Type)
and then Has_Controlled_Component (Typ)
then
- if Is_Inherently_Limited_Type (Typ) then
+ if Is_Immutably_Limited_Type (Typ) then
Controller_Typ := RTE (RE_Limited_Record_Controller);
else
Controller_Typ := RTE (RE_Record_Controller);
if Needs_Finalization (Typ)
and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate))
- and then not Is_Inherently_Limited_Type (Typ)
+ and then not Is_Immutably_Limited_Type (Typ)
then
declare
Ref : constant Node_Id :=
-- creating the object (via allocator) and initializing it.
if Is_Return_Object (Def_Id)
- and then Is_Inherently_Limited_Type (Typ)
+ and then Is_Immutably_Limited_Type (Typ)
then
null;
-- renaming declaration.
if Needs_Finalization (Typ)
- and then not Is_Inherently_Limited_Type (Typ)
+ and then not Is_Immutably_Limited_Type (Typ)
and then not Rewrite_As_Renaming
then
Insert_Actions_After (Init_After,
Loc := Sloc (First (Component_Items (Comp_List)));
end if;
- if Is_Inherently_Limited_Type (T) then
+ if Is_Immutably_Limited_Type (T) then
Controller_Type := RTE (RE_Limited_Record_Controller);
else
Controller_Type := RTE (RE_Record_Controller);
end if;
Set_Is_Frozen (Def_Id);
- Set_All_DT_Position (Def_Id);
+ if not Is_Derived_Type (Def_Id)
+ or else Is_Tagged_Type (Etype (Def_Id))
+ then
+ Set_All_DT_Position (Def_Id);
+ end if;
-- Add the controlled component before the freezing actions
-- referenced in those actions.
end if;
end;
- elsif Ada_Version >= Ada_12
- and then Comes_From_Source (Def_Id)
+ -- Otherwise create primitive equality operation (AI05-0123)
+ -- This is done unconditionally to ensure that tools can be linked
+ -- properly with user programs compiled with older language versions.
+ -- It might be worth including a switch to revert to a non-composable
+ -- equality for untagged records, even though no program depending on
+ -- non-composability has surfaced ???
+
+ elsif Comes_From_Source (Def_Id)
and then Convention (Def_Id) = Convention_Ada
+ and then not Is_Limited_Type (Def_Id)
then
Build_Untagged_Equality (Def_Id);
end if;
-- want to Adjust.
if not Aggr_In_Place
- and then not Is_Inherently_Limited_Type (T)
+ and then not Is_Immutably_Limited_Type (T)
then
Insert_Actions (N,
Make_Adjust_Call (
-- the type of the expression may be.
if not Comes_From_Extended_Return_Statement (N)
- and then Is_Inherently_Limited_Type (Etype (Expression (N)))
+ and then Is_Immutably_Limited_Type (Etype (Expression (N)))
and then Ada_Version >= Ada_05
and then not Debug_Flag_Dot_L
then
-- type that requires special processing (indicated by the fact that
-- it requires a cleanup scope for the secondary stack case).
- if Is_Inherently_Limited_Type (Exptyp)
+ if Is_Immutably_Limited_Type (Exptyp)
or else Is_Limited_Interface (Exptyp)
then
null;
elsif Ekind (R_Type) = E_Anonymous_Access_Type
and then Has_Controlling_Result (Scope_Id)
- and then Ada_Version >= Ada_12
+ and then (Ada_Version >= Ada_12 or else True)
then
Insert_Action (Exp,
Make_Raise_Constraint_Error (Loc,
-- not a rewriting of a protected function call.
if Needs_Finalization (Etype (Subp)) then
- if not Is_Inherently_Limited_Type (Etype (Subp))
+ if not Is_Immutably_Limited_Type (Etype (Subp))
and then
(No (First_Formal (Subp))
or else
then
null;
- elsif Is_Inherently_Limited_Type (Typ) then
+ elsif Is_Immutably_Limited_Type (Typ) then
Set_Returns_By_Ref (Spec_Id);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
-- may return objects of nonlimited descendants.
else
- return Is_Inherently_Limited_Type (Etype (E))
+ return Is_Immutably_Limited_Type (Etype (E))
and then Ada_Version >= Ada_05
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_Inherently_Limited_Type (Typ) then
+ if Is_Immutably_Limited_Type (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_Inherently_Limited_Type (Typ) then
+ if not Is_Immutably_Limited_Type (Typ) then
Set_TSS (Typ,
Make_Deep_Proc (
Prim => Adjust_Case,
Typ => Typ,
Stmts => Make_Deep_Record_Body (Initialize_Case, Typ)));
- if not Is_Inherently_Limited_Type (Typ) then
+ if not Is_Immutably_Limited_Type (Typ) then
Set_TSS (Typ,
Make_Deep_Proc (
Prim => Adjust_Case,
Res : constant List_Id := New_List;
begin
- if Is_Inherently_Limited_Type (Typ) then
+ if Is_Immutably_Limited_Type (Typ) then
Controller_Typ := RTE (RE_Limited_Record_Controller);
else
Controller_Typ := RTE (RE_Record_Controller);
-- to accommodate functions returning limited objects by reference.
if Nkind (Exp) = N_Function_Call
- and then Is_Inherently_Limited_Type (Etype (Exp))
+ and then Is_Immutably_Limited_Type (Etype (Exp))
and then Nkind (Parent (Exp)) /= N_Object_Declaration
and then Ada_Version >= Ada_05
then
ada/casing.ads ada/checks.ads ada/checks.adb ada/csets.ads \
ada/debug.ads ada/einfo.ads ada/einfo.adb ada/elists.ads ada/elists.adb \
ada/err_vars.ads ada/errout.ads ada/erroutc.ads ada/eval_fat.ads \
- ada/exp_aggr.ads ada/exp_atag.ads ada/exp_ch11.ads ada/exp_ch2.ads \
- ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads ada/exp_ch6.adb \
- ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads ada/exp_disp.ads \
- ada/exp_dist.ads ada/exp_intr.ads ada/exp_pakd.ads ada/exp_tss.ads \
- ada/exp_util.ads ada/exp_util.adb ada/exp_vfpt.ads ada/fname.ads \
- ada/fname-uf.ads ada/freeze.ads ada/get_targ.ads ada/gnat.ads \
- ada/g-hesorg.ads ada/g-htable.ads ada/hostparm.ads ada/inline.ads \
- ada/interfac.ads ada/itypes.ads ada/lib.ads ada/lib.adb \
- ada/lib-list.adb ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads \
- ada/namet.ads ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads \
- ada/nmake.adb ada/opt.ads ada/output.ads ada/restrict.ads \
- ada/restrict.adb ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb \
- ada/scans.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
+ ada/exp_aggr.ads ada/exp_atag.ads ada/exp_cg.ads ada/exp_ch11.ads \
+ ada/exp_ch2.ads ada/exp_ch3.ads ada/exp_ch4.ads ada/exp_ch6.ads \
+ ada/exp_ch6.adb ada/exp_ch7.ads ada/exp_ch9.ads ada/exp_dbug.ads \
+ ada/exp_disp.ads ada/exp_disp.adb ada/exp_dist.ads ada/exp_intr.ads \
+ ada/exp_pakd.ads ada/exp_tss.ads ada/exp_util.ads ada/exp_util.adb \
+ ada/exp_vfpt.ads ada/fname.ads ada/fname-uf.ads ada/freeze.ads \
+ ada/get_targ.ads ada/gnat.ads ada/g-hesorg.ads ada/g-htable.ads \
+ ada/hostparm.ads ada/inline.ads ada/interfac.ads ada/itypes.ads \
+ ada/layout.ads ada/lib.ads ada/lib.adb ada/lib-list.adb \
+ ada/lib-load.ads ada/lib-sort.adb ada/lib-xref.ads ada/namet.ads \
+ ada/namet.adb ada/nlists.ads ada/nlists.adb ada/nmake.ads ada/nmake.adb \
+ ada/opt.ads ada/output.ads ada/restrict.ads ada/restrict.adb \
+ ada/rident.ads ada/rtsfind.ads ada/rtsfind.adb ada/scans.ads \
+ ada/scil_ll.ads ada/scn.ads ada/scng.ads ada/scng.adb ada/sem.ads \
ada/sem_attr.ads ada/sem_aux.ads ada/sem_aux.adb ada/sem_ch12.ads \
ada/sem_ch13.ads ada/sem_ch3.ads ada/sem_ch6.ads ada/sem_ch7.ads \
ada/sem_ch8.ads ada/sem_disp.ads ada/sem_dist.ads ada/sem_eval.ads \
end if;
end Is_Indefinite_Subtype;
- --------------------------------
- -- Is_Inherently_Limited_Type --
- --------------------------------
+ -------------------------------
+ -- Is_Immutably_Limited_Type --
+ -------------------------------
- function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean is
+ function Is_Immutably_Limited_Type (Ent : Entity_Id) return Boolean is
Btype : constant Entity_Id := Base_Type (Ent);
begin
- if Is_Private_Type (Btype) then
- declare
- Utyp : constant Entity_Id := Underlying_Type (Btype);
- begin
- if No (Utyp) then
+ if Ekind (Btype) = E_Limited_Private_Type then
+ if Nkind (Parent (Btype)) = N_Formal_Type_Declaration then
+ return not In_Package_Body (Scope ((Btype)));
+ else
+ return True;
+ end if;
+
+ 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;
+
+ elsif Ekind (Scope (Etype (Btype))) = E_Generic_Package then
+ return not In_Package_Body (Scope (Etype (Btype)));
+
else
- return Is_Inherently_Limited_Type (Utyp);
+ return False;
end if;
- end;
+
+ 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;
return True;
elsif Is_Class_Wide_Type (Btype) then
- return Is_Inherently_Limited_Type (Root_Type (Btype));
+ return Is_Immutably_Limited_Type (Root_Type (Btype));
else
declare
-- limited intefaces.
if not Is_Interface (Etype (C))
- and then Is_Inherently_Limited_Type (Etype (C))
+ and then Is_Immutably_Limited_Type (Etype (C))
then
return True;
end if;
end if;
elsif Is_Array_Type (Btype) then
- return Is_Inherently_Limited_Type (Component_Type (Btype));
+ return Is_Immutably_Limited_Type (Component_Type (Btype));
else
return False;
end if;
- end Is_Inherently_Limited_Type;
+ end Is_Immutably_Limited_Type;
---------------------
-- Is_Limited_Type --
-- discriminant values or a class wide type or subtype and returns True if
-- so. False for other type entities, or any entities that are not types.
- function Is_Inherently_Limited_Type (Ent : Entity_Id) return Boolean;
+ function Is_Immutably_Limited_Type (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".
-- only in the declaration for a task or protected type, or for a type
-- with the reserved word 'limited' in its definition or in one of its
-- ancestors. (RM 3.7(10))
+ -- AI-0063 : the proper condition is that type must be immutably
+ -- limited.
if Nkind (Discriminant_Type (D)) = N_Access_Definition
- and then not Is_Concurrent_Type (Current_Scope)
- and then not Is_Concurrent_Record_Type (Current_Scope)
- and then not Is_Limited_Record (Current_Scope)
- and then Ekind (Current_Scope) /= E_Limited_Private_Type
+ and then not Is_Immutably_Limited_Type (Current_Scope)
then
Error_Msg_N
("access discriminants allowed only for limited types", Loc);
Error_Msg_N
("(Ada 2005) cannot copy object of a limited type " &
"(RM-2005 6.5(5.5/2))", Expr);
- if Is_Inherently_Limited_Type (R_Type) then
+ if Is_Immutably_Limited_Type (R_Type) then
Error_Msg_N
("\return by reference not permitted in Ada 2005", Expr);
end if;
-- evilly turned off. Otherwise it is a real error.
elsif Warn_On_Ada_2005_Compatibility or GNAT_Mode then
- if Is_Inherently_Limited_Type (R_Type) then
+ if Is_Immutably_Limited_Type (R_Type) then
Error_Msg_N
("return by reference not permitted in Ada 2005 " &
"(RM-2005 6.5(5.5/2))?", Expr);
-- check the static cases.
if (Ada_Version < Ada_05 or else Debug_Flag_Dot_L)
- and then Is_Inherently_Limited_Type (Etype (Scope_Id))
+ and then Is_Immutably_Limited_Type (Etype (Scope_Id))
and then Object_Access_Level (Expr) >
Subprogram_Access_Level (Scope_Id)
then
Utyp : constant Entity_Id := Underlying_Type (Typ);
begin
- if Is_Inherently_Limited_Type (Typ) then
+ if Is_Immutably_Limited_Type (Typ) then
Set_Returns_By_Ref (Designator);
elsif Present (Utyp) and then CW_Or_Has_Controlled_Part (Utyp) then
end if;
end Check_Component;
+ ----------------------------
+ -- Check_Duplicate_Pragma --
+ ----------------------------
+
procedure Check_Duplicate_Pragma (E : Entity_Id) is
- P : constant Node_Id := Get_Rep_Pragma (E, Pragma_Name (N));
+ P : constant Node_Id := Get_Rep_Pragma (E, Pragma_Name (N));
+ Arg : Node_Id;
+
begin
if Present (P) then
- Error_Msg_Name_1 := Pname;
- Error_Msg_Sloc := Sloc (P);
- Error_Msg_NE ("pragma% for & duplicates one#", N, E);
- raise Pragma_Exit;
+
+ -- Make sure pragma is for this entity, and not for some parent
+ -- entity in the case of a derived type.
+
+ Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (P)));
+
+ if Nkind (Arg) = N_Identifier
+ and then Entity (Arg) = E
+ then
+ Error_Msg_Name_1 := Pname;
+ Error_Msg_Sloc := Sloc (P);
+ Error_Msg_NE ("pragma% for & duplicates one#", N, E);
+ raise Pragma_Exit;
+ end if;
end if;
end Check_Duplicate_Pragma;
projects / platform / upstream / linaro-gcc.git / commitdiff