+2010-09-09 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch13.adb, sem_ch6.adb, exp_ch3.adb: Minor reformatting.
+
+2010-09-09 Robert Dewar <dewar@adacore.com>
+
+ * einfo.adb (Is_Aggregate_Type): New function.
+ * einfo.ads (Aggregate_Kind): New enumeration subtype
+ (Is_Aggregate_Type): New function.
+ * sem_type.adb (Is_Array_Class_Record_Type): Removed, replaced by
+ Is_Aggregate_Typea.
+
+2010-09-09 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch11.adb, frontend.adb, sem_attr.adb, sem_ch10.adb, sem_ch3.adb,
+ sem_ch4.adb, sem_ch9.adb, sem_res.adb: Use Restriction_Check_Needed
+ where appropriate.
+ * restrict.ads, restrict.adb: Ditto.
+ (Restriction_Check_Needed): New function
+
2010-09-09 Ed Schonberg <schonberg@adacore.com>
* exp_ch9.ads (Find_Master_Scope): New function, extracted from
return Ekind (Id) in Access_Subprogram_Kind;
end Is_Access_Subprogram_Type;
+ function Is_Aggregate_Type (Id : E) return B is
+ begin
+ return Ekind (Id) in Aggregate_Kind;
+ end Is_Aggregate_Type;
+
function Is_Array_Type (Id : E) return B is
begin
return Ekind (Id) in Array_Kind;
E_Access_Protected_Subprogram_Type ..
E_Anonymous_Access_Protected_Subprogram_Type;
+ subtype Aggregate_Kind is Entity_Kind range
+ E_Array_Type ..
+ -- E_Array_Subtype
+ -- E_String_Type
+ -- E_String_Subtype
+ -- E_String_Literal_Subtype
+ -- E_Class_Wide_Type
+ -- E_Class_Wide_Subtype
+ -- E_Record_Type
+ E_Record_Subtype;
+
subtype Array_Kind is Entity_Kind range
E_Array_Type ..
-- E_Array_Subtype
function Is_Access_Type (Id : E) return B;
function Is_Access_Protected_Subprogram_Type (Id : E) return B;
function Is_Access_Subprogram_Type (Id : E) return B;
+ function Is_Aggregate_Type (Id : E) return B;
function Is_Array_Type (Id : E) return B;
function Is_Assignable (Id : E) return B;
function Is_Class_Wide_Type (Id : E) return B;
pragma Inline (Is_Access_Type);
pragma Inline (Is_Access_Protected_Subprogram_Type);
pragma Inline (Is_Access_Subprogram_Type);
+ pragma Inline (Is_Aggregate_Type);
pragma Inline (Is_Aliased);
pragma Inline (Is_Array_Type);
pragma Inline (Is_Assignable);
procedure Warn_If_No_Propagation (N : Node_Id) is
begin
- if Restriction_Active (No_Exception_Propagation)
+ if Restriction_Check_Required (No_Exception_Propagation)
and then Warn_On_Non_Local_Exception
then
Warn_No_Exception_Propagation_Active (N);
-- are active) can lead to very large blocks that GCC3 handles poorly.
procedure Build_Untagged_Equality (Typ : Entity_Id);
- -- AI05-0123: equality on untagged records composes. This procedure
- -- build the equality routine for an untagged record that has components
- -- of a record type that have user-defined primitive equality operations.
+ -- AI05-0123: Equality on untagged records composes. This procedure
+ -- builds the equality routine for an untagged record that has components
+ -- of a record type that has user-defined primitive equality operations.
-- The resulting operation is a TSS subprogram.
procedure Build_Variant_Record_Equality (Typ : Entity_Id);
Eq_Op : Entity_Id;
function User_Defined_Eq (T : Entity_Id) return Entity_Id;
- -- Check whether the type T has a user-defined primitive
- -- equality. If true for a component of Typ, we have to
- -- build the primitive equality for it.
+ -- Check whether the type T has a user-defined primitive equality. If so
+ -- return it, else return Empty. If true for a component of Typ, we have
+ -- to build the primitive equality for it.
---------------------
-- User_Defined_Eq --
begin
-- If a record component has a primitive equality operation, we must
- -- builde the corresponding one for the current type.
+ -- build the corresponding one for the current type.
Build_Eq := False;
Comp := First_Component (Typ);
Eq_Op := Empty;
while Present (Prim) loop
if Chars (Node (Prim)) = Name_Op_Eq
- and then Comes_From_Source (Node (Prim))
+ and then Comes_From_Source (Node (Prim))
+
+ -- Don't we also need to check formal types and return type as in
+ -- User_Defined_Eq above???
+
then
Eq_Op := Node (Prim);
Build_Eq := False;
end loop;
-- If the type is derived, inherit the operation, if present, from the
- -- parent type. It may have been declared after the type derivation.
- -- If the parent type itself is derived, it may have inherited an
- -- operation that has itself been overridden, so update its alias
- -- and related flags. Ditto for inequality.
+ -- parent type. It may have been declared after the type derivation. If
+ -- the parent type itself is derived, it may have inherited an operation
+ -- that has itself been overridden, so update its alias and related
+ -- flags. Ditto for inequality.
if No (Eq_Op) and then Is_Derived_Type (Typ) then
Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
end loop;
end if;
- -- If not inherited and not user-defined, build body as for a type
- -- with tagged components.
+ -- If not inherited and not user-defined, build body as for a type with
+ -- tagged components.
if Build_Eq then
Decl :=
- Make_Eq_Body
- (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
+ Make_Eq_Body (Typ, Make_TSS_Name (Typ, TSS_Composite_Equality));
Op := Defining_Entity (Decl);
Set_TSS (Typ, Op);
Set_Is_Pure (Op);
Comps := Component_List (Typ_Def);
end if;
- Variant_Case := Present (Comps)
- and then Present (Variant_Part (Comps));
+ Variant_Case :=
+ Present (Comps) and then Present (Variant_Part (Comps));
end if;
if Variant_Case then
-- explicit switch turning off Warn_On_Non_Local_Exception, then turn on
-- this warning by default if we have encountered an exception handler.
- if Restriction_Active (No_Exception_Propagation)
+ if Restriction_Check_Required (No_Exception_Propagation)
and then not No_Warn_On_Non_Local_Exception
and then Exception_Handler_Encountered
then
-- Start of processing for Check_Obsolescent_2005_Entity
begin
- if Ada_Version >= Ada_2005
- and then Restriction_Active (No_Obsolescent_Features)
+ if Restriction_Check_Required (No_Obsolescent_Features)
+ and then Ada_Version >= Ada_2005
and then Chars_Is (Scope (E), "handling")
and then Chars_Is (Scope (Scope (E)), "characters")
and then Chars_Is (Scope (Scope (Scope (E))), "ada")
-- Start of processing for Check_Restriction
begin
- -- In CodePeer mode, we do not want to check for any restriction, or
- -- set additional restrictions than those already set in gnat1drv.adb
+ -- In CodePeer mode, we do not want to check for any restriction, or set
+ -- additional restrictions other than those already set in gnat1drv.adb
-- so that we have consistency between each compilation.
if CodePeer_Mode then
procedure Check_Wide_Character_Restriction (E : Entity_Id; N : Node_Id) is
begin
- if Restriction_Active (No_Wide_Characters)
+ if Restriction_Check_Required (No_Wide_Characters)
and then Comes_From_Source (N)
then
declare
return Restrictions.Set (R) and then not Restriction_Warnings (R);
end Restriction_Active;
+ --------------------------------
+ -- Restriction_Check_Required --
+ --------------------------------
+
+ function Restriction_Check_Required (R : All_Restrictions) return Boolean is
+ begin
+ return Restrictions.Set (R);
+ end Restriction_Check_Required;
+
---------------------
-- Restriction_Msg --
---------------------
-- used where the compiled code depends on whether the restriction is
-- active. Always use Check_Restriction to record a violation. Note that
-- this returns False if we only have a Restriction_Warnings set, since
- -- restriction warnings should never affect generated code.
+ -- restriction warnings should never affect generated code. If you want
+ -- to know if a call to Check_Restriction is needed then use the function
+ -- Restriction_Check_Required instead.
+
+ function Restriction_Check_Required (R : All_Restrictions) return Boolean;
+ pragma Inline (Restriction_Check_Required);
+ -- Determines if either a Restriction_Warnings or Restrictions pragma has
+ -- been given for the specified restriction. If true, then a subsequent
+ -- call to Check_Restriction is required if the restriction is violated.
+ -- This must not be used to guard code generation that depends on whether
+ -- a restriction is active (see Restriction_Active above). Typically it
+ -- is used to avoid complex code to determine if a restriction is violated,
+ -- executing this code only if needed.
function Restricted_Profile return Boolean;
-- Tests if set of restrictions corresponding to Profile (Restricted) is
-- 2005. Note that we can't test Is_Tagged_Type here on P_Type, since
-- this flag gets set by Find_Type in this situation.
- if Restriction_Active (No_Obsolescent_Features)
+ if Restriction_Check_Required (No_Obsolescent_Features)
and then Ada_Version >= Ada_2005
and then Ekind (P_Type) = E_Incomplete_Type
then
-- Note: this is not quite right if the user defines one of these units
-- himself, but that's a marginal case, and fixing it is hard ???
- if Restriction_Active (No_Obsolescent_Features) then
+ if Restriction_Check_Required (No_Obsolescent_Features) then
declare
F : constant File_Name_Type :=
Unit_File_Name (Get_Source_Unit (U));
function Make_Null_Procedure_Specs (Tag_Typ : Entity_Id) return List_Id;
-- Ada 2005 (AI-251): Makes specs for null procedures associated with
-- null procedures inherited from interface types that have not been
- -- overridden. Only one null procedure will be created for a given
- -- set of inherited null procedures with homographic profiles.
+ -- overridden. Only one null procedure will be created for a given set
+ -- of inherited null procedures with homographic profiles.
-------------------------------
-- Make_Null_Procedure_Specs --
-- of the interface type)
if Is_Controlling_Formal (Formal) then
- if Nkind (Parameter_Type (Parent (Formal)))
- = N_Identifier
+ if Nkind (Parameter_Type (Parent (Formal))) =
+ N_Identifier
then
Set_Parameter_Type (New_Param_Spec,
New_Occurrence_Of (Tag_Typ, Loc));
-- Has_Stream just for efficiency reasons. There is no point in
-- spending time on a Has_Stream check if the restriction is not set.
- if Restrictions.Set (No_Streams) then
+ if Restriction_Check_Required (No_Streams) then
if Has_Stream (T) then
Check_Restriction (No_Streams, N);
end if;
-- Check violation of No_Wide_Characters
- if Restriction_Active (No_Wide_Characters) then
+ if Restriction_Check_Required (No_Wide_Characters) then
Get_Name_String (Chars (L));
if Name_Len >= 3 and then Name_Buffer (1 .. 2) = "QW" then
-- Has_Stream just for efficiency reasons. There is no point in
-- spending time on a Has_Stream check if the restriction is not set.
- if Restrictions.Set (No_Streams) then
+ if Restriction_Check_Required (No_Streams) then
if Has_Stream (Designated_Type (Acc_Type)) then
Check_Restriction (No_Streams, N);
end if;
Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
Error_Msg_Sloc := Sloc (Op);
- if Comes_From_Source (Op)
- or else No (Alias (Op))
- then
+ if Comes_From_Source (Op) or else No (Alias (Op)) then
if not Is_Overriding_Operation (Op) then
Error_Msg_N ("\\primitive % defined #", Typ);
else
-- and the No_Local_Protected_Objects restriction applies, issue a
-- warning that objects of the type will violate the restriction.
- if not Is_Library_Level_Entity (T)
+ if Restriction_Check_Required (No_Local_Protected_Objects)
+ and then not Is_Library_Level_Entity (T)
and then Comes_From_Source (T)
- and then Restrictions.Set (No_Local_Protected_Objects)
then
Error_Msg_Sloc := Restrictions_Loc (No_Local_Protected_Objects);
-- No_Task_Hierarchy restriction applies, issue a warning that objects
-- of the type will violate the restriction.
- if not Is_Library_Level_Entity (T)
+ if Restriction_Check_Required (No_Task_Hierarchy)
+ and then not Is_Library_Level_Entity (T)
and then Comes_From_Source (T)
- and then Restrictions.Set (No_Task_Hierarchy)
then
Error_Msg_Sloc := Restrictions_Loc (No_Task_Hierarchy);
-- Entry family with non-static bounds
else
- -- If restriction is set, then this is an error
+ -- Record an unknown count restriction, and if the
+ -- restriction is active, post a message or warning.
- if Restrictions.Set (R) then
- Error_Msg_N
- ("static subtype required by Restriction pragma",
- DSD);
-
- -- Otherwise we record an unknown count restriction
-
- else
- Check_Restriction (R, D);
- end if;
+ Check_Restriction (R, D);
end if;
end;
end if;
-- violated if either operand can be negative for mod, or for rem
-- if both operands can be negative.
- if Restrictions.Set (No_Implicit_Conditionals)
+ if Restriction_Check_Required (No_Implicit_Conditionals)
and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
then
declare
-- Interp_Has_Abstract_Op. Determine whether an overloaded node has an
-- abstract interpretation which yields type Typ.
- function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean;
- -- This function tests if entity E is in Array_Kind, or Class_Wide_Kind,
- -- or is E_Record_Type or E_Record_Subtype, and returns True for these
- -- cases, and False for all others. Note that other record entity kinds
- -- such as E_Record_Type_With_Private return False.
- --
- -- This is a bit of an odd category, maybe it is wrong or a better name
- -- could be found for the class of entities being tested. The history
- -- is that this used to be done with an explicit range test for the range
- -- E_Array_Type .. E_Record_Subtype, which was itself suspicious and is
- -- now prohibited by the -gnatyE style check ???
-
procedure New_Interps (N : Node_Id);
-- Initialize collection of interpretations for the given node, which is
-- either an overloaded entity, or an operation whose arguments have
-- An aggregate is compatible with an array or record type
elsif T2 = Any_Composite
- and then Is_Array_Class_Record_Type (T1)
+ and then Is_Aggregate_Type (T1)
then
return True;
else
Par := Etype (Par);
end if;
+
+ -- For all other cases return False, not an Ancestor
+
else
return False;
end if;
end if;
end Is_Ancestor;
- --------------------------------
- -- Is_Array_Class_Record_Type --
- --------------------------------
-
- function Is_Array_Class_Record_Type (E : Entity_Id) return Boolean is
- begin
- return Is_Array_Type (E)
- or else Is_Class_Wide_Type (E)
- or else Ekind (E) = E_Record_Type
- or else Ekind (E) = E_Record_Subtype;
- end Is_Array_Class_Record_Type;
-
---------------------------
-- Is_Invisible_Operator --
---------------------------
return T1;
elsif T2 = Any_Composite
- and then Is_Array_Class_Record_Type (T1)
+ and then Is_Aggregate_Type (T1)
then
return T1;
elsif T1 = Any_Composite
- and then Is_Array_Class_Record_Type (T2)
+ and then Is_Aggregate_Type (T2)
then
return T2;
projects / thirdparty / gcc.git / commitdiff
