+2015-01-07 Robert Dewar <dewar@adacore.com>
+
+ * prj.ads, i-cpoint.adb, freeze.adb, ghost.adb, prj-err.adb: Minor
+ reformatting.
+
+2015-01-07 Robert Dewar <dewar@adacore.com>
+
+ * restrict.adb (Check_Restriction_No_Use_Of_Attribute):
+ New procedure.
+ (OK_No_Use_Of_Entity_Name): New function.
+ (Set_Restriction_No_Use_Of_Entity): New procedure.
+ * restrict.ads (Check_Restriction_No_Use_Of_Attribute):
+ New procedure.
+ (OK_No_Use_Of_Entity_Name): New function.
+ (Set_Restriction_No_Use_Of_Entity): New procedure.
+ * sem_ch8.adb (Find_Direct_Name): Add check for violation of
+ No_Use_Of_Entity.
+ * sem_prag.adb (Process_Restrictions_Or_Restriction_Warnings):
+ Add processing for new restriction No_Use_Of_Entity.
+
2015-01-07 Eric Botcazou <ebotcazou@adacore.com>
* freeze.adb (Freeze_Array_Type): Apply same handling to Is_Atomic
-- packing or explicit component size clause given.
if (Has_Aliased_Components (Arr)
- or else
- Has_Atomic_Components (Arr) or else Is_Atomic (Ctyp))
+ or else Has_Atomic_Components (Arr)
+ or else Is_Atomic (Ctyp))
and then
(Has_Component_Size_Clause (Arr) or else Is_Packed (Arr))
then
if (SSO_Set_Low_By_Default (T) or else SSO_Set_High_By_Default (T))
-- For a record type, if bit order is specified explicitly, then
- -- do not set SSO from default if not consistent.
+ -- do not set SSO from default if not consistent. Note that we
+ -- do not want to look at a Bit_Order attribute definition for
+ -- a parent: if we were to inherit Bit_Order, then both
+ -- SSO_Set_*_By_Default flags would have been cleared already
+ -- (by Inherit_Aspects_At_Freeze_Point).
and then not
(Is_Record_Type (T)
- and then Has_Rep_Item (T, Name_Bit_Order)
+ and then Has_Rep_Item (T,
+ Name_Bit_Order, Check_Parents => False)
and then Reverse_Bit_Order (T) /= Reversed)
then
-- If flags cause reverse storage order, then set the result. Note
for Index in reverse Ignored_Ghost_Units.First ..
Ignored_Ghost_Units.Last
loop
- -- The unit is already present in the table, do not add it again
+ -- If the unit is already present in the table, do not add it again
if Unit = Ignored_Ghost_Units.Table (Index) then
return;
Ref : Node_Id;
begin
- Ref := N;
-
-- When the reference extracts a subcomponent, recover the
-- related object (SPARK RM 6.9(1)).
+ Ref := N;
while Nkind_In (Ref, N_Explicit_Dereference,
N_Indexed_Component,
N_Selected_Component,
elsif Nkind_In (N, N_Assignment_Statement,
N_Procedure_Call_Statement)
then
- Nam := Name (N);
-
-- When the reference extracts a subcomponent, recover the related
-- object (SPARK RM 6.9(1)).
+ Nam := Name (N);
while Nkind_In (Nam, N_Explicit_Dereference,
N_Indexed_Component,
N_Selected_Component,
begin
if Is_Checked_Ghost_Entity (Id) then
Ghost_Mode := Check;
-
elsif Is_Ignored_Ghost_Entity (Id) then
Ghost_Mode := Ignore;
-
Propagate_Ignored_Ghost_Code (N);
end if;
end Set_Ghost_Mode_For_Freeze;
procedure Set_Is_Ghost_Entity (Id : Entity_Id) is
Policy : constant Name_Id := Policy_In_Effect (Name_Ghost);
-
begin
if Policy = Name_Check then
Set_Is_Checked_Ghost_Entity (Id);
-
elsif Policy = Name_Ignore then
Set_Is_Ignored_Ghost_Entity (Id);
end if;
if Source = null or else Target = null then
raise Dereference_Error;
+ -- Forward copy
+
elsif To_Addr (Target) <= To_Addr (Source) then
- -- Forward copy
T := Target;
S := Source;
-
for J in 1 .. Length loop
T.all := S.all;
Increment (T);
Increment (S);
end loop;
+ -- Backward copy
+
else
- -- Backward copy
T := Target + Length;
S := Source + Length;
-
for J in 1 .. Length loop
Decrement (T);
Decrement (S);
Real_Location : Source_Ptr := Location;
begin
+ -- Don't post message if incompleted with's (avoid junk cascaded errors)
+
if Flags.Incomplete_Withs then
return;
end if;
Missing_Source_Files : Error_Warning;
Ignore_Missing_With : Boolean;
- Incomplete_Withs : Boolean := False;
+ Incomplete_Withs : Boolean := False;
-- This flag is set to True when the projects are parsed while ignoring
-- missing withed project and some withed projects are not found.
-- real violation, serious vs non-serious, implicit vs explicit, the second
-- message giving the profile name if needed, and the location information.
+ function Same_Entity (E1, E2 : Node_Id) return Boolean;
+ -- Returns True iff E1 and E2 represent the same entity. Used for handling
+ -- of No_Use_Of_Entity => fully_qualified_ENTITY restriction case.
+
function Same_Unit (U1, U2 : Node_Id) return Boolean;
-- Returns True iff U1 and U2 represent the same library unit. Used for
-- handling of No_Dependence => Unit restriction case.
end if;
end Check_Restriction_No_Use_Of_Attribute;
+ ----------------------------------------
+ -- Check_Restriction_No_Use_Of_Entity --
+ ----------------------------------------
+
+ procedure Check_Restriction_No_Use_Of_Entity (N : Node_Id) is
+ begin
+ -- Error defence (not clearly necessary, but better safe)
+
+ if No (Entity (N)) then
+ return;
+ end if;
+
+ -- If simple name of entity not flagged with Boolean2 flag, then there
+ -- cannot be a matching entry in the table, so skip the search.
+
+ if Get_Name_Table_Boolean2 (Chars (Entity (N))) = False then
+ return;
+ end if;
+
+ -- Restriction is only recognized within a configuration
+ -- pragma file, or within a unit of the main extended
+ -- program. Note: the test for Main_Unit is needed to
+ -- properly include the case of configuration pragma files.
+
+ if Current_Sem_Unit /= Main_Unit
+ and then not In_Extended_Main_Source_Unit (N)
+ then
+ return;
+ end if;
+
+ -- Here we must search the table
+
+ for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop
+ declare
+ NE_Ent : NE_Entry renames No_Use_Of_Entity.Table (J);
+ Ent : Entity_Id;
+ Expr : Node_Id;
+
+ begin
+ Ent := Entity (N);
+ Expr := NE_Ent.Entity;
+ loop
+ -- Here if at outer level of entity name in reference
+
+ if Scope (Ent) = Standard_Standard then
+ if Nkind_In (Expr, N_Identifier, N_Operator_Symbol)
+ and then Chars (Ent) = Chars (Expr)
+ then
+ Error_Msg_Node_1 := N;
+ Error_Msg_Warn := NE_Ent.Warn;
+ Error_Msg_Sloc := Sloc (NE_Ent.Entity);
+ Error_Msg_N
+ ("<*<reference to & violates restriction "
+ & "No_Use_Of_Entity #", N);
+ return;
+
+ else
+ goto Continue;
+ end if;
+
+ -- Here if at outer level of entity name in table
+
+ elsif Nkind_In (Expr, N_Identifier, N_Operator_Symbol) then
+ goto Continue;
+
+ -- Here if neither at the outer level
+
+ else
+ pragma Assert (Nkind (Expr) = N_Selected_Component);
+
+ if Chars (Selector_Name (Expr)) /= Chars (Ent) then
+ goto Continue;
+ end if;
+ end if;
+
+ -- Move up a level
+
+ loop
+ Ent := Scope (Ent);
+ exit when not Is_Internal_Name (Chars (Ent));
+ end loop;
+
+ Expr := Prefix (Expr);
+
+ -- Entry did not match
+
+ <<Continue>> null;
+ end loop;
+ end;
+ end loop;
+ end Check_Restriction_No_Use_Of_Entity;
+
----------------------------------------
-- Check_Restriction_No_Use_Of_Pragma --
----------------------------------------
end if;
end OK_No_Dependence_Unit_Name;
+ ------------------------------
+ -- OK_No_Use_Of_Entity_Name --
+ ------------------------------
+
+ function OK_No_Use_Of_Entity_Name (N : Node_Id) return Boolean is
+ begin
+ if Nkind (N) = N_Selected_Component then
+ return
+ OK_No_Use_Of_Entity_Name (Prefix (N))
+ and then
+ OK_No_Use_Of_Entity_Name (Selector_Name (N));
+
+ elsif Nkind_In (N, N_Identifier, N_Operator_Symbol) then
+ return True;
+
+ else
+ Error_Msg_N ("wrong form for entity name for No_Use_Of_Entity", N);
+ return False;
+ end if;
+ end OK_No_Use_Of_Entity_Name;
+
----------------------------------
-- Process_Restriction_Synonyms --
----------------------------------
end if;
end Restriction_Msg;
+ -----------------
+ -- Same_Entity --
+ -----------------
+
+ function Same_Entity (E1, E2 : Node_Id) return Boolean is
+ begin
+ if Nkind_In (E1, N_Identifier, N_Operator_Symbol)
+ and then
+ Nkind_In (E2, N_Identifier, N_Operator_Symbol)
+ then
+ return Chars (E1) = Chars (E2);
+
+ elsif Nkind_In (E1, N_Selected_Component, N_Expanded_Name)
+ and then
+ Nkind_In (E2, N_Selected_Component, N_Expanded_Name)
+ then
+ return Same_Unit (Prefix (E1), Prefix (E2))
+ and then
+ Same_Unit (Selector_Name (E1), Selector_Name (E2));
+ else
+ return False;
+ end if;
+ end Same_Entity;
+
---------------
-- Same_Unit --
---------------
No_Dependences.Append ((Unit, Warn, Profile));
end Set_Restriction_No_Dependence;
+ --------------------------------------
+ -- Set_Restriction_No_Use_Of_Entity --
+ --------------------------------------
+
+ procedure Set_Restriction_No_Use_Of_Entity
+ (Entity : Node_Id;
+ Warn : Boolean;
+ Profile : Profile_Name := No_Profile)
+ is
+ Nam : Node_Id;
+
+ begin
+ -- Loop to check for duplicate entry
+
+ for J in No_Use_Of_Entity.First .. No_Use_Of_Entity.Last loop
+
+ -- Case of entry already in table
+
+ if Same_Entity (Entity, No_Use_Of_Entity.Table (J).Entity) then
+
+ -- Error has precedence over warning
+
+ if not Warn then
+ No_Use_Of_Entity.Table (J).Warn := False;
+ end if;
+
+ return;
+ end if;
+ end loop;
+
+ -- Entry is not currently in table
+
+ No_Use_Of_Entity.Append ((Entity, Warn, Profile));
+
+ -- Now we need to find the direct name and set Boolean2 flag
+
+ if Nkind_In (Entity, N_Identifier, N_Operator_Symbol) then
+ Nam := Entity;
+
+ else
+ pragma Assert (Nkind (Entity) = N_Selected_Component);
+ Nam := Selector_Name (Entity);
+ pragma Assert (Nkind_In (Nam, N_Identifier, N_Operator_Symbol));
+ end if;
+
+ Set_Name_Table_Boolean2 (Chars (Nam), True);
+ end Set_Restriction_No_Use_Of_Entity;
+
------------------------------------------------
-- Set_Restriction_No_Specification_Of_Aspect --
------------------------------------------------
-- Wrapper on Check_Restriction with Msg_Issued, with the out-parameter
-- being ignored here.
- procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id);
- -- N is the node of an attribute definition clause. An error message
- -- (warning) will be issued if a restriction (warning) was previously set
- -- for this attribute using Set_No_Use_Of_Attribute.
-
- procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id);
- -- N is the node of a pragma. An error message (warning) will be issued
- -- if a restriction (warning) was previously set for this pragma using
- -- Set_No_Use_Of_Pragma.
-
procedure Check_Restriction_No_Dependence (U : Node_Id; Err : Node_Id);
-- Called when a dependence on a unit is created (either implicitly, or by
-- an explicit WITH clause). U is a node for the unit involved, and Err is
-- (warning) will be issued if a restriction (warning) was previous set
-- for this aspect using Set_No_Specification_Of_Aspect.
+ procedure Check_Restriction_No_Use_Of_Attribute (N : Node_Id);
+ -- N is the node of an attribute definition clause. An error message
+ -- (warning) will be issued if a restriction (warning) was previously set
+ -- for this attribute using Set_No_Use_Of_Attribute.
+
+ procedure Check_Restriction_No_Use_Of_Entity (N : Node_Id);
+ -- N is the node id for an entity reference. An error message (warning)
+ -- will be issued if a restriction (warning) was previous set for this
+ -- entity name using Set_No_Use_Of_Entity.
+
+ procedure Check_Restriction_No_Use_Of_Pragma (N : Node_Id);
+ -- N is the node of a pragma. An error message (warning) will be issued
+ -- if a restriction (warning) was previously set for this pragma using
+ -- Set_No_Use_Of_Pragma.
+
procedure Check_Elaboration_Code_Allowed (N : Node_Id);
-- Tests to see if elaboration code is allowed by the current restrictions
-- settings. This function is called by Gigi when it needs to define an
-- pragma Restrictions_Warning, or attribute Restriction_Set. Returns
-- True if N has the proper form for a unit name, False otherwise.
+ function OK_No_Use_Of_Entity_Name (N : Node_Id) return Boolean;
+ -- Used in checking No_Use_Of_Entity argument of pragma Restrictions or
+ -- pragma Restrictions_Warning, or attribute Restriction_Set. Returns
+ -- True if N has the proper form for an entity name, False otherwise.
+
function Is_In_Hidden_Part_In_SPARK (Loc : Source_Ptr) return Boolean;
-- Determine if given location is covered by a hidden region range in the
-- SPARK hides table.
-- No_Use_Of_Attribute. Caller has verified that this is a valid attribute
-- designator.
+ procedure Set_Restriction_No_Use_Of_Entity
+ (Entity : Node_Id;
+ Warn : Boolean;
+ Profile : Profile_Name := No_Profile);
+ -- Sets given No_Use_Of_Entity restriction in table if not there already.
+ -- Warn is True if from Restriction_Warnings, or for Restrictions if the
+ -- flag Treat_Restrictions_As_Warnings is set. False if from Restrictions
+ -- and this flag is not set. Profile is set to a non-default value if the
+ -- No_Dependence restriction comes from a Profile pragma. This procedure
+ -- also takes care of setting the Boolean2 flag of the simple name for
+ -- the entity (to optimize table searches).
+
procedure Set_Restriction_No_Use_Of_Pragma
(N : Node_Id;
Warning : Boolean);
Nvis_Messages;
end if;
- return;
+ goto Done;
-- Processing for a potentially use visible entry found. We must search
-- the rest of the homonym chain for two reasons. First, if there is a
end loop;
Nvis_Messages;
- return;
+ goto Done;
elsif
Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
else
Nvis_Messages;
- return;
+ goto Done;
end if;
end if;
end;
and then Expander_Active
and then Get_PCS_Name /= Name_No_DSA
then
- Rewrite (N,
- New_Occurrence_Of (Equivalent_Type (E), Sloc (N)));
- return;
+ Rewrite (N, New_Occurrence_Of (Equivalent_Type (E), Sloc (N)));
+ goto Done;
end if;
-- Set the entity. Note that the reason we call Set_Entity for the
end if;
end if;
end;
+
+ -- Come here with entity set
+
+ <<Done>>
+ Check_Restriction_No_Use_Of_Entity (N);
end Find_Direct_Name;
------------------------
Set_Restriction_No_Use_Of_Attribute (Expr, Warn);
end if;
- -- Case of No_Use_Of_Entity => fully-qualified-name. Note that the
- -- parser already processed this case commpletely, including error
- -- checking and making an entry in the No_Use_Of_Entity table.
+ -- Case of No_Use_Of_Entity => fully-qualified-name
elsif Id = Name_No_Use_Of_Entity then
- null;
+
+ -- Restriction is only recognized within a configuration
+ -- pragma file, or within a unit of the main extended
+ -- program. Note: the test for Main_Unit is needed to
+ -- properly include the case of configuration pragma files.
+
+ if Current_Sem_Unit = Main_Unit
+ or else In_Extended_Main_Source_Unit (N)
+ then
+ if not OK_No_Dependence_Unit_Name (Expr) then
+ Error_Msg_N ("wrong form for entity name", Expr);
+ else
+ Set_Restriction_No_Use_Of_Entity
+ (Expr, Warn, No_Profile);
+ end if;
+ end if;
-- Case of No_Use_Of_Pragma => pragma-identifier
or else not Is_Pragma_Name (Chars (Expr))
then
Error_Msg_N ("unknown pragma name??", Expr);
-
else
Set_Restriction_No_Use_Of_Pragma (Expr, Warn);
end if;
-- Independent_Components --
----------------------------
- -- pragma Atomic_Components (array_or_record_LOCAL_NAME);
+ -- pragma Independent_Components (array_or_record_LOCAL_NAME);
when Pragma_Independent_Components => Independent_Components : declare
E_Id : Node_Id;
projects / gcc.git / commitdiff