+2014-01-31 Robert Dewar <dewar@adacore.com>
+
+ * sem_ch4.adb: Minor reformatting.
+
+2014-01-31 Robert Dewar <dewar@adacore.com>
+
+ * exp_ch2.adb: New calling sequence for Is_LHS.
+ * frontend.adb: Add call to Process_Deferred_References.
+ * lib-xref.ads, lib-xref.adb (Process_Deferred_References): New.
+ (Deferred_References): New table.
+ * sem_ch8.adb (Find_Direct_Name): Make deferred reference table
+ entries.
+ (Find_Expanded_Name): Ditto.
+ * sem_res.adb: New calling sequence for Is_LHS.
+ * sem_util.ads, sem_util.adb (Is_LHS): New calling sequence.
+ * sem_warn.adb: Call Process_Deferred_References before issuing
+ warnings.
+
+2014-01-31 Tristan Gingold <gingold@adacore.com>
+
+ * exp_util.adb (Corresponding_Runtime_Package): Restrict the
+ use of System_Tasking_Protected_Objects_Single_Entry.
+ * exp_ch9.adb (Build_Simple_Entry_Call): Remove Mode parameter
+ of Protected_Single_Entry_Call.
+ (Expand_N_Timed_Entry_Call): Remove single_entry case.
+ * exp_disp.adb (Make_Disp_Asynchronous_Select_Body): Remove
+ single_entry case.
+ (Make_Disp_Timed_Select_Body): Likewise.
+ * rtsfind.ads (RE_Timed_Protected_Single_Entry_Call): Remove.
+ * s-tposen.adb (Send_Program_Error, PO_Do_Or_Queue): Remove
+ Self_Id parameter.
+ (Wakeup_Entry_Caller): Remove Self_ID and New_State parameters.
+ (Wait_For_Completion_With_Timeout): Remove.
+ (Protected_Single_Entry_Call): Remove Mode parameter
+ (always Simple_Call).
+ (Service_Entry): Remove Self_Id constant (not used anymore).
+ (Timed_Protected_Single_Entry_Call): Remove.
+ * s-tposen.ads (Timed_Protected_Single_Entry_Call): Remove.
+ (Protected_Single_Entry_Call): Remove Mode parameter.
+
2014-01-29 Hristian Kirtchev <kirtchev@adacore.com>
* einfo.adb (Get_Pragma): Handle the retrieval of pragma Refined_Post.
and then Is_Scalar_Type (Etype (N))
and then (Is_Assignable (E) or else Is_Constant_Object (E))
and then Comes_From_Source (N)
- and then not Is_LHS (N)
+ and then Is_LHS (N) = No
and then not Is_Actual_Out_Parameter (N)
and then (Nkind (Parent (N)) /= N_Attribute_Reference
or else Attribute_Name (Parent (N)) /= Name_Valid)
-- family index expressions are evaluated before the entry
-- parameters.
- if Abort_Allowed
- or else Restriction_Active (No_Entry_Queue) = False
- or else not Is_Protected_Type (Conctyp)
- or else Number_Entries (Conctyp) > 1
- or else (Has_Attach_Handler (Conctyp)
- and then not Restricted_Profile)
+ if not Is_Protected_Type (Conctyp)
+ or else
+ Corresponding_Runtime_Package (Conctyp) =
+ System_Tasking_Protected_Objects_Entries
then
X := Make_Defining_Identifier (Loc, Name_uX);
when System_Tasking_Protected_Objects_Single_Entry =>
-- Protected_Single_Entry_Call (
-- Object => po._object'Access,
- -- Uninterpreted_Data => P'Address;
- -- Mode => Simple_Call);
+ -- Uninterpreted_Data => P'Address);
Call :=
Make_Procedure_Call_Statement (Loc,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unchecked_Access,
Prefix => Parm1),
- Parm3,
- New_Reference_To (RTE (RE_Simple_Call), Loc)));
+ Parm3));
when others =>
raise Program_Error;
(RTE (RE_Timed_Protected_Entry_Call), Loc),
Parameter_Associations => Params));
- when System_Tasking_Protected_Objects_Single_Entry =>
- Param := First (Params);
- while Present (Param)
- and then not
- Is_RTE (Etype (Param), RE_Protected_Entry_Index)
- loop
- Next (Param);
- end loop;
-
- Remove (Param);
-
- Rewrite (Call,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To
- (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
- Parameter_Associations => Params));
-
when others =>
raise Program_Error;
end case;
New_Reference_To (Com_Block, Loc)))); -- comm block
- when System_Tasking_Protected_Objects_Single_Entry =>
-
- -- Generate:
- -- procedure Protected_Single_Entry_Call
- -- (Object : Protection_Entry_Access;
- -- Uninterpreted_Data : System.Address;
- -- Mode : Call_Modes);
-
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To
- (RTE (RE_Protected_Single_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
- Obj_Ref,
-
- Make_Attribute_Reference (Loc,
- Prefix => Make_Identifier (Loc, Name_uP),
- Attribute_Name => Name_Address),
-
- New_Reference_To
- (RTE (RE_Asynchronous_Call), Loc))));
-
when others =>
raise Program_Error;
end case;
Make_Identifier (Loc, Name_uM), -- delay mode
Make_Identifier (Loc, Name_uF)))); -- status flag
- when System_Tasking_Protected_Objects_Single_Entry =>
- -- Generate:
-
- -- Timed_Protected_Single_Entry_Call
- -- (T._object'access, P, D, M, F);
-
- -- where T is the protected object, P is the wrapped
- -- parameters, D is the delay amount, M is the delay mode, F
- -- is the status flag.
-
- Append_To (Stmts,
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Reference_To
- (RTE (RE_Timed_Protected_Single_Entry_Call), Loc),
- Parameter_Associations =>
- New_List (
- Obj_Ref,
- Make_Identifier (Loc, Name_uP), -- parameter block
- Make_Identifier (Loc, Name_uD), -- delay
- Make_Identifier (Loc, Name_uM), -- delay mode
- Make_Identifier (Loc, Name_uF)))); -- status flag
-
when others =>
raise Program_Error;
end case;
then
if Abort_Allowed
or else Restriction_Active (No_Entry_Queue) = False
+ or else Restriction_Active (No_Select_Statements) = False
or else Number_Entries (Typ) > 1
or else (Has_Attach_Handler (Typ)
and then not Restricted_Profile)
with Inline; use Inline;
with Lib; use Lib;
with Lib.Load; use Lib.Load;
+with Lib.Xref; use Lib.Xref;
with Live; use Live;
with Namet; use Namet;
with Nlists; use Nlists;
-- Output waiting warning messages
+ Lib.Xref.Process_Deferred_References;
Sem_Warn.Output_Non_Modified_In_Out_Warnings;
Sem_Warn.Output_Unreferenced_Messages;
Sem_Warn.Check_Unused_Withs;
end loop;
end Handle_Orphan_Type_References;
- -- Now we have all the references, including those for any embedded
- -- type references, so we can sort them, and output them.
+ -- Now we have all the references, including those for any embedded type
+ -- references, so we can sort them, and output them.
Output_Refs : declare
end Output_Refs;
end Output_References;
+ ---------------------------------
+ -- Process_Deferred_References --
+ ---------------------------------
+
+ procedure Process_Deferred_References is
+ begin
+ for J in Deferred_References.First .. Deferred_References.Last loop
+ declare
+ D : Deferred_Reference_Entry renames Deferred_References.Table (J);
+
+ begin
+ case Is_LHS (D.N) is
+ when Yes =>
+ Generate_Reference (D.E, D.N, 'm');
+
+ when No =>
+ Generate_Reference (D.E, D.N, 'r');
+
+ -- Not clear if Unknown can occur at this stage, but if it
+ -- does we will treat it as a normal reference.
+
+ when Unknown =>
+ Generate_Reference (D.E, D.N, 'r');
+ end case;
+ end;
+ end loop;
+
+ -- Clear processed entries from table
+
+ Deferred_References.Init;
+ end Process_Deferred_References;
+
-- Start of elaboration for Lib.Xref
begin
-- Export at line 4, that its body is exported to C, and that the link name
-- as given in the pragma is "here".
+ -------------------------
+ -- Deferred_References --
+ -------------------------
+
+ -- Normally we generate references as we go along, but as discussed in
+ -- Sem_Util.Is_LHS, and Sem_Ch8.Find_Direct_Name/Find_Selected_Component,
+ -- we have one case where that is tricky, which is when we have something
+ -- like X.A := 3, where we don't know until we know the type of X whether
+ -- this is a reference (if X is an access type, so what we really have is
+ -- X.all.A := 3) or a modification, where X is not an access type.
+
+ -- What we do in such cases is to gather nodes, where we would have liked
+ -- to call Generate_Reference but we couldn't because we didn't know enough
+ -- into this table, Then we deal with generating references later on when
+ -- we have sufficient information to do it right.
+
+ type Deferred_Reference_Entry is record
+ E : Entity_Id;
+ N : Node_Id;
+ end record;
+ -- One entry, E, N are as required for Generate_Reference call
+
+ package Deferred_References is new Table.Table (
+ Table_Component_Type => Deferred_Reference_Entry,
+ Table_Index_Type => Int,
+ Table_Low_Bound => 0,
+ Table_Initial => 512,
+ Table_Increment => 200,
+ Table_Name => "Name_Deferred_References");
+
+ procedure Process_Deferred_References;
+ -- This procedure is called from Frontend to process these table entries.
+
-----------------------------
-- SPARK Xrefs Information --
-----------------------------
RE_Exceptional_Complete_Single_Entry_Body,
RE_Protected_Count_Entry, -- Protected_Objects.Single_Entry
RE_Protected_Single_Entry_Caller, -- Protected_Objects.Single_Entry
- RE_Timed_Protected_Single_Entry_Call,
RE_Protected_Entry_Index, -- System.Tasking.Protected_Objects
RE_Entry_Body, -- System.Tasking.Protected_Objects
System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Single_Entry_Caller =>
System_Tasking_Protected_Objects_Single_Entry,
- RE_Timed_Protected_Single_Entry_Call =>
- System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Entry_Index => System_Tasking_Protected_Objects,
RE_Entry_Body => System_Tasking_Protected_Objects,
-- Local Subprograms --
-----------------------
- procedure Send_Program_Error
- (Self_Id : Task_Id;
- Entry_Call : Entry_Call_Link);
+ procedure Send_Program_Error (Entry_Call : Entry_Call_Link);
pragma Inline (Send_Program_Error);
-- Raise Program_Error in the caller of the specified entry call
-- Entry Calls Handling --
--------------------------
- procedure Wakeup_Entry_Caller
- (Self_ID : Task_Id;
- Entry_Call : Entry_Call_Link;
- New_State : Entry_Call_State);
+ procedure Wakeup_Entry_Caller (Entry_Call : Entry_Call_Link);
pragma Inline (Wakeup_Entry_Caller);
-- This is called at the end of service of an entry call,
-- to abort the caller if he is in an abortable part, and
-- to wake up the caller if he is on Entry_Caller_Sleep.
-- Call it holding the lock of Entry_Call.Self.
- --
- -- Timed_Call or Simple_Call:
- -- The caller is waiting on Entry_Caller_Sleep, in
- -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
procedure Wait_For_Completion (Entry_Call : Entry_Call_Link);
pragma Inline (Wait_For_Completion);
-- queued. This waits for calls on protected entries.
-- Call this only when holding Self_ID locked.
- procedure Wait_For_Completion_With_Timeout
- (Entry_Call : Entry_Call_Link;
- Wakeup_Time : Duration;
- Mode : Delay_Modes);
- -- Same as Wait_For_Completion but it waits for a timeout with the value
- -- specified in Wakeup_Time as well.
-
procedure Check_Exception
(Self_ID : Task_Id;
Entry_Call : Entry_Call_Link);
-- The caller should not be holding any locks, or there will be deadlock.
procedure PO_Do_Or_Queue
- (Self_Id : Task_Id;
- Object : Protection_Entry_Access;
+ (Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link);
-- This procedure executes or queues an entry call, depending
-- on the status of the corresponding barrier. It assumes that the
-- Send_Program_Error --
------------------------
- procedure Send_Program_Error
- (Self_Id : Task_Id;
- Entry_Call : Entry_Call_Link)
+ procedure Send_Program_Error (Entry_Call : Entry_Call_Link)
is
Caller : constant Task_Id := Entry_Call.Self;
begin
end if;
STPO.Write_Lock (Caller);
- Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+ Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Caller);
if Single_Lock then
Self_Id.Common.State := Runnable;
end Wait_For_Completion;
- --------------------------------------
- -- Wait_For_Completion_With_Timeout --
- --------------------------------------
-
- procedure Wait_For_Completion_With_Timeout
- (Entry_Call : Entry_Call_Link;
- Wakeup_Time : Duration;
- Mode : Delay_Modes)
- is
- Self_Id : constant Task_Id := Entry_Call.Self;
- Timedout : Boolean;
-
- Yielded : Boolean;
- pragma Unreferenced (Yielded);
-
- use type Ada.Exceptions.Exception_Id;
-
- begin
- -- This procedure waits for the entry call to be served, with a timeout.
- -- It tries to cancel the call if the timeout expires before the call is
- -- served.
-
- -- If we wake up from the timed sleep operation here, it may be for the
- -- following possible reasons:
-
- -- 1) The entry call is done being served.
- -- 2) The timeout has expired (Timedout = True)
-
- -- Once the timeout has expired we may need to continue to wait if the
- -- call is already being serviced. In that case, we want to go back to
- -- sleep, but without any timeout. The variable Timedout is used to
- -- control this. If the Timedout flag is set, we do not need to Sleep
- -- with a timeout. We just sleep until we get a wakeup for some status
- -- change.
-
- pragma Assert (Entry_Call.Mode = Timed_Call);
- Self_Id.Common.State := Entry_Caller_Sleep;
-
- STPO.Timed_Sleep
- (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded);
-
- Entry_Call.State := (if Timedout then Cancelled else Done);
- Self_Id.Common.State := Runnable;
- end Wait_For_Completion_With_Timeout;
-
-------------------------
-- Wakeup_Entry_Caller --
-------------------------
-- (This enforces the rule that a task must be off-queue if its state is
-- Done or Cancelled.) Call it holding the lock of Entry_Call.Self.
- -- Timed_Call or Simple_Call:
- -- The caller is waiting on Entry_Caller_Sleep, in
- -- Wait_For_Completion, or Wait_For_Completion_With_Timeout.
-
- -- Conditional_Call:
- -- The caller might be in Wait_For_Completion,
- -- waiting for a rendezvous (possibly requeued without abort)
- -- to complete.
+ -- The caller is waiting on Entry_Caller_Sleep, in Wait_For_Completion.
procedure Wakeup_Entry_Caller
- (Self_ID : Task_Id;
- Entry_Call : Entry_Call_Link;
- New_State : Entry_Call_State)
+ (Entry_Call : Entry_Call_Link)
is
- pragma Warnings (Off, Self_ID);
-
Caller : constant Task_Id := Entry_Call.Self;
-
begin
- pragma Assert (New_State = Done or else New_State = Cancelled);
pragma Assert
(Caller.Common.State /= Terminated and then
Caller.Common.State /= Unactivated);
- Entry_Call.State := New_State;
+ Entry_Call.State := Done;
STPO.Wakeup (Caller, Entry_Caller_Sleep);
end Wakeup_Entry_Caller;
--------------------
procedure PO_Do_Or_Queue
- (Self_Id : Task_Id;
- Object : Protection_Entry_Access;
+ (Object : Protection_Entry_Access;
Entry_Call : Entry_Call_Link)
is
Barrier_Value : Boolean;
-- This violates the No_Entry_Queue restriction, send
-- Program_Error to the caller.
- Send_Program_Error (Self_Id, Entry_Call);
+ Send_Program_Error (Entry_Call);
return;
end if;
end if;
STPO.Write_Lock (Entry_Call.Self);
- Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+ Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Entry_Call.Self);
if Single_Lock then
STPO.Unlock_RTS;
end if;
- elsif Entry_Call.Mode /= Conditional_Call then
+ else
+ pragma Assert (Entry_Call.Mode = Simple_Call);
+
if Object.Entry_Queue /= null then
-- This violates the No_Entry_Queue restriction, send
-- Program_Error to the caller.
- Send_Program_Error (Self_Id, Entry_Call);
+ Send_Program_Error (Entry_Call);
return;
else
Object.Entry_Queue := Entry_Call;
end if;
- else
- -- Conditional_Call
-
- if Single_Lock then
- STPO.Lock_RTS;
- end if;
-
- STPO.Write_Lock (Entry_Call.Self);
- Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled);
- STPO.Unlock (Entry_Call.Self);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- end if;
end if;
exception
when others =>
- Send_Program_Error
- (Self_Id, Entry_Call);
+ Send_Program_Error (Entry_Call);
end PO_Do_Or_Queue;
----------------------------
procedure Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
- Uninterpreted_Data : System.Address;
- Mode : Call_Modes)
+ Uninterpreted_Data : System.Address)
is
Self_Id : constant Task_Id := STPO.Self;
Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
Lock_Entry (Object);
- Entry_Call.Mode := Mode;
+ Entry_Call.Mode := Simple_Call;
Entry_Call.State := Now_Abortable;
Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
- PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
+ PO_Do_Or_Queue (Object, Entry_Call'Access);
Unlock_Entry (Object);
-- The call is either `Done' or not. It cannot be cancelled since there
-------------------
procedure Service_Entry (Object : Protection_Entry_Access) is
- Self_Id : constant Task_Id := STPO.Self;
Entry_Call : constant Entry_Call_Link := Object.Entry_Queue;
Caller : Task_Id;
-- Violation of No_Entry_Queue restriction, raise exception
- Send_Program_Error (Self_Id, Entry_Call);
+ Send_Program_Error (Entry_Call);
Unlock_Entry (Object);
return;
end if;
end if;
STPO.Write_Lock (Caller);
- Wakeup_Entry_Caller (Self_Id, Entry_Call, Done);
+ Wakeup_Entry_Caller (Entry_Call);
STPO.Unlock (Caller);
if Single_Lock then
exception
when others =>
- Send_Program_Error (Self_Id, Entry_Call);
+ Send_Program_Error (Entry_Call);
Unlock_Entry (Object);
end Service_Entry;
- ---------------------------------------
- -- Timed_Protected_Single_Entry_Call --
- ---------------------------------------
-
- -- Compiler interface only (do not call from within the RTS)
-
- procedure Timed_Protected_Single_Entry_Call
- (Object : Protection_Entry_Access;
- Uninterpreted_Data : System.Address;
- Timeout : Duration;
- Mode : Delay_Modes;
- Entry_Call_Successful : out Boolean)
- is
- Self_Id : constant Task_Id := STPO.Self;
- Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1);
-
- begin
- -- If pragma Detect_Blocking is active then Program_Error must be
- -- raised if this potentially blocking operation is called from a
- -- protected action.
-
- if Detect_Blocking
- and then Self_Id.Common.Protected_Action_Nesting > 0
- then
- raise Program_Error with "potentially blocking operation";
- end if;
-
- Lock (Object.Common'Access);
-
- Entry_Call.Mode := Timed_Call;
- Entry_Call.State := Now_Abortable;
- Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
- Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;
-
- PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access);
- Unlock_Entry (Object);
-
- -- Try to avoid waiting for completed calls.
- -- The call is either `Done' or not. It cannot be cancelled since there
- -- is no ATC construct and the timed wait has not started yet.
-
- pragma Assert (Entry_Call.State /= Cancelled);
-
- if Entry_Call.State = Done then
- Check_Exception (Self_Id, Entry_Call'Access);
- Entry_Call_Successful := True;
- return;
- end if;
-
- if Single_Lock then
- STPO.Lock_RTS;
- else
- STPO.Write_Lock (Self_Id);
- end if;
-
- Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode);
-
- if Single_Lock then
- STPO.Unlock_RTS;
- else
- STPO.Unlock (Self_Id);
- end if;
-
- pragma Assert (Entry_Call.State >= Done);
-
- Check_Exception (Self_Id, Entry_Call'Access);
- Entry_Call_Successful := Entry_Call.State = Done;
- end Timed_Protected_Single_Entry_Call;
-
------------------
-- Unlock_Entry --
------------------
procedure Protected_Single_Entry_Call
(Object : Protection_Entry_Access;
- Uninterpreted_Data : System.Address;
- Mode : Call_Modes);
+ Uninterpreted_Data : System.Address);
-- Make a protected entry call to the specified object
--
-- Pend a protected entry call on the protected object represented by
-- This will be returned by Next_Entry_Call when this call is serviced.
-- It can be used by the compiler to pass information between the
-- caller and the server, in particular entry parameters.
- --
- -- Mode
- -- The kind of call to be pended
-
- procedure Timed_Protected_Single_Entry_Call
- (Object : Protection_Entry_Access;
- Uninterpreted_Data : System.Address;
- Timeout : Duration;
- Mode : Delay_Modes;
- Entry_Call_Successful : out Boolean);
- -- Same as the Protected_Entry_Call but with time-out specified.
- -- This routine is used to implement timed entry calls.
procedure Exceptional_Complete_Single_Entry_Body
(Object : Protection_Entry_Access;
-- correct. If an operand is universal it is compatible with any
-- numeric type.
- -- In Ada 2005, the equality on anonymous access types is declared
- -- in Standard, and is always visible.
- -- In an instance, the type may have been immediately visible.
- -- Either the types are compatible, or one operand is universal
- -- (numeric or null).
-
elsif In_Open_Scopes (Scope (Bas))
or else Is_Potentially_Use_Visible (Bas)
or else In_Use (Bas)
or else (In_Use (Scope (Bas)) and then not Is_Hidden (Bas))
+
+ -- In an instance, the type may have been immediately visible.
+ -- Either the types are compatible, or one operand is universal
+ -- (numeric or null).
+
or else (In_Instance
and then
(First_Subtype (T1) = First_Subtype (Etype (R))
or else
(Is_Numeric_Type (T1)
and then Is_Universal_Numeric_Type (Etype (R)))))
+
+ -- In Ada 2005, the equality on anonymous access types is declared
+ -- in Standard, and is always visible.
+
or else Ekind (T1) = E_Anonymous_Access_Type
then
null;
-- Normal case, not a label: generate reference
- -- ??? It is too early to generate a reference here even if the
- -- entity is unambiguous, because the tree is not sufficiently
- -- typed at this point for Generate_Reference to determine
- -- whether this reference modifies the denoted object (because
- -- implicit dereferences cannot be identified prior to full type
- -- resolution).
+ else
+ if not Is_Actual_Parameter then
- -- The Is_Actual_Parameter routine takes care of one of these
- -- cases but there are others probably ???
+ -- Package or generic package is always a simple reference
- -- If the entity is the LHS of an assignment, and is a variable
- -- (rather than a package prefix), we can mark it as a
- -- modification right away, to avoid duplicate references.
+ if Ekind_In (E, E_Package, E_Generic_Package) then
+ Generate_Reference (E, N, 'r');
+
+ -- Else see if we have a left hand side
- else
- if not Is_Actual_Parameter then
- if Is_LHS (N)
- and then Ekind (E) /= E_Package
- and then Ekind (E) /= E_Generic_Package
- then
- Generate_Reference (E, N, 'm');
else
- Generate_Reference (E, N);
+ case Is_LHS (N) is
+ when Yes =>
+ Generate_Reference (E, N, 'm');
+
+ when No =>
+ Generate_Reference (E, N, 'r');
+
+ -- If we don't know now, generate reference later
+
+ when Unknown =>
+ Deferred_References.Append ((E, N));
+ end case;
end if;
end if;
Change_Selected_Component_To_Expanded_Name (N);
+ -- Set appropriate type
+
+ if Is_Type (Id) then
+ Set_Etype (N, Id);
+ else
+ Set_Etype (N, Get_Full_View (Etype (Id)));
+ end if;
+
-- Do style check and generate reference, but skip both steps if this
-- entity has homonyms, since we may not have the right homonym set yet.
-- The proper homonym will be set during the resolve phase.
if Has_Homonym (Id) then
Set_Entity (N, Id);
+
else
Set_Entity_Or_Discriminal (N, Id);
- if Is_LHS (N) then
- Generate_Reference (Id, N, 'm');
- else
- Generate_Reference (Id, N);
- end if;
- end if;
-
- if Is_Type (Id) then
- Set_Etype (N, Id);
- else
- Set_Etype (N, Get_Full_View (Etype (Id)));
+ case Is_LHS (N) is
+ when Yes =>
+ Generate_Reference (Id, N, 'm');
+ when No =>
+ Generate_Reference (Id, N, 'r');
+ when Unknown =>
+ Deferred_References.Append ((Id, N));
+ end case;
end if;
-- Check for violation of No_Wide_Characters
or else (Is_Entity_Name (Prefix (N))
and then Is_Atomic (Entity (Prefix (N)))))
and then Is_Bit_Packed_Array (Array_Type)
- and then Is_LHS (N)
+ and then Is_LHS (N) = Yes
then
Error_Msg_N ("??assignment to component of packed atomic array",
Prefix (N));
or else (Is_Entity_Name (Prefix (N))
and then Is_Atomic (Entity (Prefix (N)))))
and then Is_Packed (T)
- and then Is_LHS (N)
+ and then Is_LHS (N) = Yes
then
Error_Msg_N
("??assignment to component of packed atomic record", Prefix (N));
-- we exclude overloaded calls, since we don't know enough to be sure
-- of giving the right answer in this case.
- if Is_Entity_Name (Name (Call))
+ if Nkind_In (Call, N_Function_Call, N_Procedure_Call_Statement)
+ and then Is_Entity_Name (Name (Call))
and then Present (Entity (Name (Call)))
and then Is_Overloadable (Entity (Name (Call)))
and then not Is_Overloaded (Name (Call))
-- We seem to have a lot of overlapping functions that do similar things
-- (testing for left hand sides or lvalues???).
- function Is_LHS (N : Node_Id) return Boolean is
+ function Is_LHS (N : Node_Id) return Is_LHS_Result is
P : constant Node_Id := Parent (N);
begin
-- Return True if we are the left hand side of an assignment statement
if Nkind (P) = N_Assignment_Statement then
- return Name (P) = N;
+ if Name (P) = N then
+ return Yes;
+ else
+ return No;
+ end if;
-- Case of prefix of indexed or selected component or slice
-- what we really have is N.all.Q (or N.all(Q .. R)). In either
-- case this makes N.all a left hand side but not N itself.
- -- Here follows a worrisome kludge. If Etype (N) is not set, which
- -- for sure happens in the call from Find_Direct_Name, that means we
- -- don't know if N is of an access type, so we can't give an accurate
- -- answer. For now, we assume we do not have an access type, which
- -- means for example that P.Q.R := X will look like a modification
- -- of P, even if P.Q eventually turns out to be an access type. The
- -- consequence is at least that in some cases we incorrectly identify
- -- a reference as a modification. It is not clear if there are any
- -- other bad consequences. ???
+ -- If we don't know the type yet, this is the case where we return
+ -- Unknown, since the answer depends on the type which is unknown.
if No (Etype (N)) then
- return False;
+ return Unknown;
-- We have an Etype set, so we can check it
elsif Is_Access_Type (Etype (N)) then
- return False;
+ return No;
-- OK, not access type case, so just test whole expression
-- All other cases are not left hand sides
else
- return False;
+ return No;
end if;
end Is_LHS;
-- AI05-0139-2: Check whether Typ is one of the predefined interfaces in
-- Ada.Iterator_Interfaces, or it is derived from one.
- function Is_LHS (N : Node_Id) return Boolean;
- -- Returns True iff N is used as Name in an assignment statement
+ type Is_LHS_Result is (Yes, No, Unknown);
+ function Is_LHS (N : Node_Id) return Is_LHS_Result;
+ -- Returns Yes if N is definitely used as Name in an assignment statement.
+ -- Returns No if N is definitely NOT used as a Name in an assignment
+ -- statement. Returns Unknown if we can't tell at this stage (happens in
+ -- the case where we don't know the type of N yet, and we have something
+ -- like N.A := 3, where this counts as N being used on the left side of
+ -- an assignment only if N is not an access type. If it is an access type
+ -- then it is N.all.A that is assigned, not N.
function Is_Library_Level_Entity (E : Entity_Id) return Boolean;
-- A library-level declaration is one that is accessible from Standard,
with Exp_Code; use Exp_Code;
with Fname; use Fname;
with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
-- Start of processing for Check_References
begin
+ Process_Deferred_References;
+
-- No messages if warnings are suppressed, or if we have detected any
-- real errors so far (this last check avoids junk messages resulting
-- from errors, e.g. a subunit that is not loaded).
return;
end if;
+ Process_Deferred_References;
+
-- Flag any unused with clauses. For a subunit, check only the units
-- in its context, not those of the parent, which may be needed by other
-- subunits. We will get the full warnings when we compile the parent,
projects / thirdparty / gcc.git / commitdiff
