+2017-09-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * sem_ch3.adb, sem_ch7.adb, sem_util.adb, g-debpoo.adb, sem_ch4.adb,
+ sem_ch6.adb, sem_ch8.adb: Minor reformatting.
+ * exp_util.adb (Is_Source_Object): Account for
+ the cases where the source object may appear as a dereference
+ or within a type conversion.
+ * exp_ch6.adb: Fix missing space in error message.
+
+2017-09-06 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_prag.adb: Update description of Eliminate.
+
+
2017-09-06 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute, case 'Loop_Entry): Handle
elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
Error_Msg_NE
("tag-indeterminate expression must have type&"
- & "(RM 5.2 (6))",
+ & " (RM 5.2 (6))",
Call_Node, Root_Type (Etype (Name (Ass))));
else
----------------------
function Is_Displace_Call (N : Node_Id) return Boolean is
- Call : Node_Id := N;
+ Call : Node_Id;
begin
-- Strip various actions which may precede a call to Displace
+ Call := N;
loop
if Nkind (Call) = N_Explicit_Dereference then
Call := Prefix (Call);
----------------------
function Is_Source_Object (N : Node_Id) return Boolean is
+ Obj : Node_Id;
+
begin
+ -- Strip various actions which may be associated with the object
+
+ Obj := N;
+ loop
+ if Nkind (Obj) = N_Explicit_Dereference then
+ Obj := Prefix (Obj);
+
+ elsif Nkind_In (Obj, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
+ then
+ Obj := Expression (Obj);
+
+ else
+ exit;
+ end if;
+ end loop;
+
return
- Present (N)
- and then Nkind (N) in N_Has_Entity
- and then Is_Object (Entity (N))
- and then Comes_From_Source (N);
+ Present (Obj)
+ and then Nkind (Obj) in N_Has_Entity
+ and then Is_Object (Entity (Obj))
+ and then Comes_From_Source (Obj);
end Is_Source_Object;
-- Local variables
type Scope_Lock is
new Ada.Finalization.Limited_Controlled with null record;
- -- to handle Lock_Task/Unlock_Task calls
+ -- Used to handle Lock_Task/Unlock_Task calls
overriding procedure Initialize (This : in out Scope_Lock);
- -- lock task on initialization
+ -- Lock task on initialization
overriding procedure Finalize (This : in out Scope_Lock);
- -- unlock task on finalization
+ -- Unlock task on finalization
----------------
-- Initialize --
-- Header_Of --
---------------
- function Header_Of (Address : System.Address)
- return Allocation_Header_Access
+ function Header_Of
+ (Address : System.Address) return Allocation_Header_Access
is
- function Convert is new Ada.Unchecked_Conversion
- (System.Address, Allocation_Header_Access);
+ function Convert is
+ new Ada.Unchecked_Conversion
+ (System.Address,
+ Allocation_Header_Access);
begin
return Convert (Address - Header_Offset);
end Header_Of;
----------
function Next
- (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr is
+ (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr
+ is
begin
return E.Next;
end Next;
procedure Reset_Marks is
Current : System.Address := Pool.First_Free_Block;
Header : Allocation_Header_Access;
+
begin
while Current /= System.Null_Address loop
Header := Header_Of (Current);
Lock : Scope_Lock;
pragma Unreferenced (Lock);
- -- Start of processing for Free_Physically
+ -- Start of processing for Free_Physically
begin
-
if Pool.Advanced_Scanning then
-- Reset the mark for each freed block
Free_Blocks (Ignore_Marks => not Pool.Advanced_Scanning);
-- The contract is that we need to free at least Minimum_To_Free bytes,
- -- even if this means freeing marked blocks in the advanced scheme
+ -- even if this means freeing marked blocks in the advanced scheme.
if Total_Freed < Pool.Minimum_To_Free
and then Pool.Advanced_Scanning
Pool.Marked_Blocks_Deallocated := True;
Free_Blocks (Ignore_Marks => True);
end if;
-
end Free_Physically;
--------------
procedure Get_Size
(Storage_Address : Address;
Size_In_Storage_Elements : out Storage_Count;
- Valid : out Boolean) is
-
+ Valid : out Boolean)
+ is
Lock : Scope_Lock;
pragma Unreferenced (Lock);
begin
-
Valid := Is_Valid (Storage_Address);
if Is_Valid (Storage_Address) then
declare
- Header : constant Allocation_Header_Access :=
- Header_Of (Storage_Address);
+ Header : constant Allocation_Header_Access :=
+ Header_Of (Storage_Address);
+
begin
if Header.Block_Size >= 0 then
Valid := True;
else
Valid := False;
end if;
-
end Get_Size;
---------------------
procedure Print_Traceback
(Output_File : File_Type;
Prefix : String;
- Traceback : Traceback_Htable_Elem_Ptr) is
+ Traceback : Traceback_Htable_Elem_Ptr)
+ is
begin
if Traceback /= null then
Put (Output_File, Prefix);
pragma Unreferenced (Alignment);
Header : constant Allocation_Header_Access :=
- Header_Of (Storage_Address);
- Valid : Boolean;
+ Header_Of (Storage_Address);
Previous : System.Address;
+ Valid : Boolean;
+
Header_Block_Size_Was_Less_Than_0 : Boolean := True;
begin
declare
Lock : Scope_Lock;
pragma Unreferenced (Lock);
+
begin
Valid := Is_Valid (Storage_Address);
Header_Block_Size_Was_Less_Than_0 := False;
-- Some sort of codegen problem or heap corruption caused the
- -- Size_In_Storage_Elements to be wrongly computed.
- -- The code below is all based on the assumption that Header.all
- -- is not corrupted, such that the error is non-fatal.
+ -- Size_In_Storage_Elements to be wrongly computed. The code
+ -- below is all based on the assumption that Header.all is not
+ -- corrupted, such that the error is non-fatal.
if Header.Block_Size /= Size_In_Storage_Elements and then
Size_In_Storage_Elements /= Storage_Count'Last
-- Do not physically release the memory here, but in Alloc.
-- See comment there for details.
end if;
-
end;
if not Valid then
-
if Storage_Address = System.Null_Address then
if Pool.Raise_Exceptions and then
Size_In_Storage_Elements /= Storage_Count'Last
end if;
end if;
- if Allow_Unhandled_Memory and then not Is_Handled (Storage_Address)
+ if Allow_Unhandled_Memory
+ and then not Is_Handled (Storage_Address)
then
System.CRTL.free (Storage_Address);
return;
end if;
- if Pool.Raise_Exceptions and then
- Size_In_Storage_Elements /= Storage_Count'Last
+ if Pool.Raise_Exceptions
+ and then Size_In_Storage_Elements /= Storage_Count'Last
then
raise Freeing_Not_Allocated_Storage;
else
end if;
elsif Header_Block_Size_Was_Less_Than_0 then
-
if Pool.Raise_Exceptions then
raise Freeing_Deallocated_Storage;
else
Print_Traceback (Output_File (Pool), " Memory was allocated at ",
Header.Alloc_Traceback);
end if;
-
end if;
-
end Deallocate;
--------------------
Display_Slots : Boolean := False;
Display_Leaks : Boolean := False)
is
-
package Backtrace_Htable_Cumulate is new GNAT.HTable.Static_HTable
(Header_Num => Header,
Element => Traceback_Htable_Elem,
Equal => Equal);
-- This needs a comment ??? probably some of the ones below do too???
+ Current : System.Address;
Data : Traceback_Htable_Elem_Ptr;
Elem : Traceback_Htable_Elem_Ptr;
- Current : System.Address;
Header : Allocation_Header_Access;
K : Traceback_Kind;
if Data.Kind in Alloc .. Dealloc then
Elem :=
new Traceback_Htable_Elem'
- (Traceback => new Tracebacks_Array'(Data.Traceback.all),
- Count => Data.Count,
- Kind => Data.Kind,
- Total => Data.Total,
- Frees => Data.Frees,
- Total_Frees => Data.Total_Frees,
- Next => null);
+ (Traceback => new Tracebacks_Array'(Data.Traceback.all),
+ Count => Data.Count,
+ Kind => Data.Kind,
+ Total => Data.Total,
+ Frees => Data.Frees,
+ Total_Frees => Data.Total_Frees,
+ Next => null);
Backtrace_Htable_Cumulate.Set (Elem);
if Cumulate then
-- If not, insert it
if Elem = null then
- Elem := new Traceback_Htable_Elem'
- (Traceback => new Tracebacks_Array'
- (Data.Traceback (T .. Data.Traceback'Last)),
- Count => Data.Count,
- Kind => K,
- Total => Data.Total,
- Frees => Data.Frees,
- Total_Frees => Data.Total_Frees,
- Next => null);
+ Elem :=
+ new Traceback_Htable_Elem'
+ (Traceback =>
+ new Tracebacks_Array'
+ (Data.Traceback
+ (T .. Data.Traceback'Last)),
+ Count => Data.Count,
+ Kind => K,
+ Total => Data.Total,
+ Frees => Data.Frees,
+ Total_Frees => Data.Total_Frees,
+ Next => null);
Backtrace_Htable_Cumulate.Set (Elem);
-- Properly take into account that the subprograms
procedure Dump
(Pool : Debug_Pool;
Size : Positive;
- Report : Report_Type := All_Reports) is
-
+ Report : Report_Type := All_Reports)
+ is
procedure Do_Report (Sort : Report_Type);
-- Do a specific type of report
+ ---------------
+ -- Do_Report --
+ ---------------
+
procedure Do_Report (Sort : Report_Type) is
Elem : Traceback_Htable_Elem_Ptr;
Bigger : Boolean;
end;
while Elem /= null loop
-
declare
Lock : Scope_Lock;
pragma Unreferenced (Lock);
-- gain speed.
if (Sort = Memory_Usage
- and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000)
+ and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000)
or else (Sort = Allocations_Count
- and then Elem_Safe.Count - Elem_Safe.Frees >= 1)
+ and then Elem_Safe.Count - Elem_Safe.Frees >= 1)
or else (Sort = Sort_Total_Allocs
- and then Elem_Safe.Count > 1)
+ and then Elem_Safe.Count > 1)
or else (Sort = Marked_Blocks
- and then Elem_Safe.Total = 0)
+ and then Elem_Safe.Total = 0)
then
if Sort = Marked_Blocks then
Grand_Total := Grand_Total + Float (Elem_Safe.Count);
for M in Max'Range loop
Bigger := Max (M) = null;
if not Bigger then
-
declare
Lock : Scope_Lock;
pragma Unreferenced (Lock);
begin
Elem := Backtrace_Htable.Get_Next;
end;
-
end loop;
if Grand_Total = 0.0 then
exit when Max (M) = null;
declare
type Percent is delta 0.1 range 0.0 .. 100.0;
+
+ P : Percent;
Total : Byte_Count;
- P : Percent;
- begin
+ begin
declare
Lock : Scope_Lock;
pragma Unreferenced (Lock);
-- In multi tasking configuration, memory deallocations
-- during Do_Report processing can lead to Total >
-- Grand_Total. As Percent requires Total <= Grand_Total
+
begin
if Normalized_Total > Grand_Total then
P := 100.0;
end;
case Sort is
- when Memory_Usage | Allocations_Count | All_Reports =>
+ when All_Reports
+ | Allocations_Count
+ | Memory_Usage
+ =>
declare
Count : constant Natural :=
Max_M_Safe.Count - Max_M_Safe.Frees;
Put (P'Img & "%:" & Total'Img & " bytes in"
& Count'Img & " chunks at");
end;
+
when Sort_Total_Allocs =>
Put (P'Img & "%:" & Total'Img & " bytes in"
& Max_M_Safe.Count'Img & " chunks at");
+
when Marked_Blocks =>
Put (P'Img & "%:"
& Max_M_Safe.Count'Img & " chunks /"
-- High_Water_Mark --
---------------------
- function High_Water_Mark
- (Pool : Debug_Pool) return Byte_Count is
+ function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is
Lock : Scope_Lock;
pragma Unreferenced (Lock);
begin
-- Current_Water_Mark --
------------------------
- function Current_Water_Mark
- (Pool : Debug_Pool) return Byte_Count is
+ function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is
Lock : Scope_Lock;
pragma Unreferenced (Lock);
begin
------------------------------
procedure System_Memory_Debug_Pool
- (Has_Unhandled_Memory : Boolean := True) is
+ (Has_Unhandled_Memory : Boolean := True)
+ is
Lock : Scope_Lock;
pragma Unreferenced (Lock);
begin
Header : Allocation_Header_Access;
begin
- -- We might get Null_Address if the call from gdb was done
- -- incorrectly. For instance, doing a "print_pool(my_var)" passes 0x0,
- -- instead of passing the value of my_var
+ -- We might get Null_Address if the call from gdb was done incorrectly.
+ -- For instance, doing a "print_pool(my_var)" passes 0x0, instead of
+ -- passing the value of my_var.
if A = System.Null_Address then
Put_Line
Display_Slots : Boolean := False;
Display_Leaks : Boolean := False)
is
-
procedure Internal is new Print_Info
(Put_Line => Stdout_Put_Line,
Put => Stdout_Put);
-- corresponding subtype of the full view.
elsif Ekind (Priv_Dep) = E_Incomplete_Subtype
- and then Comes_From_Source (Priv_Dep)
+ and then Comes_From_Source (Priv_Dep)
then
Set_Subtype_Indication
(Parent (Priv_Dep), New_Occurrence_Of (Full_T, Sloc (Priv_Dep)));
Set_Ekind (Priv_Dep, Subtype_Kind (Ekind (Full_T)));
Set_Analyzed (Parent (Priv_Dep), False);
- -- Reanalyze the declaration, suppressing the call to
- -- Enter_Name to avoid duplicate names.
+ -- Reanalyze the declaration, suppressing the call to Enter_Name
+ -- to avoid duplicate names.
Analyze_Subtype_Declaration
(N => Parent (Priv_Dep),
Set_Etype (Alt, It.Typ);
- -- If the alternative is an enumeration literal, use
- -- the one for this interpretation.
+ -- If the alternative is an enumeration literal, use the one
+ -- for this interpretation.
if Is_Entity_Name (Alt) then
Set_Entity (Alt, It.Nam);
if No (It.Typ) then
Set_Is_Overloaded (Alt, False);
Common_Type := Etype (Alt);
-
end if;
Candidate_Interps := Alt;
-- there are various error checks that are applied on this body
-- when it is analyzed (e.g. correct aspect placement).
- if Has_Completion (Prev)
- then
+ if Has_Completion (Prev) then
Error_Msg_Sloc := Sloc (Prev);
Error_Msg_NE ("duplicate body for & declared#", N, Prev);
end if;
-- Check on incomplete types
- -- AI05-0213: A formal incomplete type has no completion,
- -- and neither does the corresponding subtype in an instance.
+ -- AI05-0213: A formal incomplete type has no completion, and neither
+ -- does the corresponding subtype in an instance.
if Is_Incomplete_Type (E)
and then No (Full_View (E))
-- Case of Renaming_As_Body
if Present (Rename_Spec) then
-
Check_Previous_Null_Procedure (N, Rename_Spec);
-- Renaming declaration is the completion of the declaration of
---------------
-- pragma Eliminate (
- -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
- -- [,[Entity =>] IDENTIFIER |
- -- SELECTED_COMPONENT |
- -- STRING_LITERAL]
- -- [, OVERLOADING_RESOLUTION]);
-
- -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
- -- SOURCE_LOCATION
-
- -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
- -- FUNCTION_PROFILE
-
- -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
-
- -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
- -- Result_Type => result_SUBTYPE_NAME]
-
- -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
- -- SUBTYPE_NAME ::= STRING_LITERAL
+ -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
+ -- [Entity =>] IDENTIFIER |
+ -- SELECTED_COMPONENT |
+ -- STRING_LITERAL]
+ -- [, Source_Location => SOURCE_TRACE]);
-- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
-- SOURCE_TRACE ::= STRING_LITERAL
Name_Result_Type,
Name_Source_Location);
+ -- Note : Parameter_Types and Result_Type are leftovers from
+ -- prior implementations of the pragma. They are not generated
+ -- by the gnatelim tool, and play no role in selecting which
+ -- of a set of overloaded names is chosen for elimination.
+
Unit_Name : Node_Id renames Args (1);
Entity : Node_Id renames Args (2);
Parameter_Types : Node_Id renames Args (3);
end if;
end Cannot_Raise_Constraint_Error;
- ------------------------------------
- -- Check_Previous_Null_Procedure --
- ------------------------------------
-
- procedure Check_Previous_Null_Procedure
- (Decl : Node_Id;
- Prev : Entity_Id)
- is
- begin
- if Ekind (Prev) = E_Procedure
- and then Nkind (Parent (Prev)) = N_Procedure_Specification
- and then Null_Present (Parent (Prev))
- then
- Error_Msg_Sloc := Sloc (Prev);
- Error_Msg_N
- ("declaration cannot complete previous null procedure#", Decl);
- end if;
- end Check_Previous_Null_Procedure;
-
- -----------------------------
- -- Check_Part_Of_Reference --
- -----------------------------
-
- procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is
- Conc_Typ : constant Entity_Id := Encapsulating_State (Var_Id);
- Decl : Node_Id;
- OK_Use : Boolean := False;
- Par : Node_Id;
- Prag_Nam : Name_Id;
- Spec_Id : Entity_Id;
-
- begin
- -- Traverse the parent chain looking for a suitable context for the
- -- reference to the concurrent constituent.
-
- Par := Parent (Ref);
- while Present (Par) loop
- if Nkind (Par) = N_Pragma then
- Prag_Nam := Pragma_Name (Par);
-
- -- A concurrent constituent is allowed to appear in pragmas
- -- Initial_Condition and Initializes as this is part of the
- -- elaboration checks for the constituent (SPARK RM 9.3).
-
- if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then
- OK_Use := True;
- exit;
-
- -- When the reference appears within pragma Depends or Global,
- -- check whether the pragma applies to a single task type. Note
- -- that the pragma is not encapsulated by the type definition,
- -- but this is still a valid context.
-
- elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) then
- Decl := Find_Related_Declaration_Or_Body (Par);
-
- if Nkind (Decl) = N_Object_Declaration
- and then Defining_Entity (Decl) = Conc_Typ
- then
- OK_Use := True;
- exit;
- end if;
- end if;
-
- -- The reference appears somewhere in the definition of the single
- -- protected/task type (SPARK RM 9.3).
-
- elsif Nkind_In (Par, N_Single_Protected_Declaration,
- N_Single_Task_Declaration)
- and then Defining_Entity (Par) = Conc_Typ
- then
- OK_Use := True;
- exit;
-
- -- The reference appears within the expanded declaration or the body
- -- of the single protected/task type (SPARK RM 9.3).
-
- elsif Nkind_In (Par, N_Protected_Body,
- N_Protected_Type_Declaration,
- N_Task_Body,
- N_Task_Type_Declaration)
- then
- Spec_Id := Unique_Defining_Entity (Par);
-
- if Present (Anonymous_Object (Spec_Id))
- and then Anonymous_Object (Spec_Id) = Conc_Typ
- then
- OK_Use := True;
- exit;
- end if;
-
- -- The reference has been relocated within an internally generated
- -- package or subprogram. Assume that the reference is legal as the
- -- real check was already performed in the original context of the
- -- reference.
-
- elsif Nkind_In (Par, N_Package_Body,
- N_Package_Declaration,
- N_Subprogram_Body,
- N_Subprogram_Declaration)
- and then not Comes_From_Source (Par)
- then
- -- Continue to examine the context if the reference appears in a
- -- subprogram body which was previously an expression function.
-
- if Nkind (Par) = N_Subprogram_Body
- and then Was_Expression_Function (Par)
- then
- null;
-
- -- Otherwise the reference is legal
-
- else
- OK_Use := True;
- exit;
- end if;
-
- -- The reference has been relocated to an inlined body for GNATprove.
- -- Assume that the reference is legal as the real check was already
- -- performed in the original context of the reference.
-
- elsif GNATprove_Mode
- and then Nkind (Par) = N_Subprogram_Body
- and then Chars (Defining_Entity (Par)) = Name_uParent
- then
- OK_Use := True;
- exit;
- end if;
-
- Par := Parent (Par);
- end loop;
-
- -- The reference is illegal as it appears outside the definition or
- -- body of the single protected/task type.
-
- if not OK_Use then
- Error_Msg_NE
- ("reference to variable & cannot appear in this context",
- Ref, Var_Id);
- Error_Msg_Name_1 := Chars (Var_Id);
-
- if Ekind (Conc_Typ) = E_Protected_Type then
- Error_Msg_NE
- ("\% is constituent of single protected type &", Ref, Conc_Typ);
- else
- Error_Msg_NE
- ("\% is constituent of single task type &", Ref, Conc_Typ);
- end if;
- end if;
- end Check_Part_Of_Reference;
-
-----------------------------------------
-- Check_Dynamically_Tagged_Expression --
-----------------------------------------
end if;
end Check_Nonvolatile_Function_Profile;
+ -----------------------------
+ -- Check_Part_Of_Reference --
+ -----------------------------
+
+ procedure Check_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id) is
+ Conc_Typ : constant Entity_Id := Encapsulating_State (Var_Id);
+ Decl : Node_Id;
+ OK_Use : Boolean := False;
+ Par : Node_Id;
+ Prag_Nam : Name_Id;
+ Spec_Id : Entity_Id;
+
+ begin
+ -- Traverse the parent chain looking for a suitable context for the
+ -- reference to the concurrent constituent.
+
+ Par := Parent (Ref);
+ while Present (Par) loop
+ if Nkind (Par) = N_Pragma then
+ Prag_Nam := Pragma_Name (Par);
+
+ -- A concurrent constituent is allowed to appear in pragmas
+ -- Initial_Condition and Initializes as this is part of the
+ -- elaboration checks for the constituent (SPARK RM 9.3).
+
+ if Nam_In (Prag_Nam, Name_Initial_Condition, Name_Initializes) then
+ OK_Use := True;
+ exit;
+
+ -- When the reference appears within pragma Depends or Global,
+ -- check whether the pragma applies to a single task type. Note
+ -- that the pragma is not encapsulated by the type definition,
+ -- but this is still a valid context.
+
+ elsif Nam_In (Prag_Nam, Name_Depends, Name_Global) then
+ Decl := Find_Related_Declaration_Or_Body (Par);
+
+ if Nkind (Decl) = N_Object_Declaration
+ and then Defining_Entity (Decl) = Conc_Typ
+ then
+ OK_Use := True;
+ exit;
+ end if;
+ end if;
+
+ -- The reference appears somewhere in the definition of the single
+ -- protected/task type (SPARK RM 9.3).
+
+ elsif Nkind_In (Par, N_Single_Protected_Declaration,
+ N_Single_Task_Declaration)
+ and then Defining_Entity (Par) = Conc_Typ
+ then
+ OK_Use := True;
+ exit;
+
+ -- The reference appears within the expanded declaration or the body
+ -- of the single protected/task type (SPARK RM 9.3).
+
+ elsif Nkind_In (Par, N_Protected_Body,
+ N_Protected_Type_Declaration,
+ N_Task_Body,
+ N_Task_Type_Declaration)
+ then
+ Spec_Id := Unique_Defining_Entity (Par);
+
+ if Present (Anonymous_Object (Spec_Id))
+ and then Anonymous_Object (Spec_Id) = Conc_Typ
+ then
+ OK_Use := True;
+ exit;
+ end if;
+
+ -- The reference has been relocated within an internally generated
+ -- package or subprogram. Assume that the reference is legal as the
+ -- real check was already performed in the original context of the
+ -- reference.
+
+ elsif Nkind_In (Par, N_Package_Body,
+ N_Package_Declaration,
+ N_Subprogram_Body,
+ N_Subprogram_Declaration)
+ and then not Comes_From_Source (Par)
+ then
+ -- Continue to examine the context if the reference appears in a
+ -- subprogram body which was previously an expression function.
+
+ if Nkind (Par) = N_Subprogram_Body
+ and then Was_Expression_Function (Par)
+ then
+ null;
+
+ -- Otherwise the reference is legal
+
+ else
+ OK_Use := True;
+ exit;
+ end if;
+
+ -- The reference has been relocated to an inlined body for GNATprove.
+ -- Assume that the reference is legal as the real check was already
+ -- performed in the original context of the reference.
+
+ elsif GNATprove_Mode
+ and then Nkind (Par) = N_Subprogram_Body
+ and then Chars (Defining_Entity (Par)) = Name_uParent
+ then
+ OK_Use := True;
+ exit;
+ end if;
+
+ Par := Parent (Par);
+ end loop;
+
+ -- The reference is illegal as it appears outside the definition or
+ -- body of the single protected/task type.
+
+ if not OK_Use then
+ Error_Msg_NE
+ ("reference to variable & cannot appear in this context",
+ Ref, Var_Id);
+ Error_Msg_Name_1 := Chars (Var_Id);
+
+ if Ekind (Conc_Typ) = E_Protected_Type then
+ Error_Msg_NE
+ ("\% is constituent of single protected type &", Ref, Conc_Typ);
+ else
+ Error_Msg_NE
+ ("\% is constituent of single task type &", Ref, Conc_Typ);
+ end if;
+ end if;
+ end Check_Part_Of_Reference;
+
------------------------------------------
-- Check_Potentially_Blocking_Operation --
------------------------------------------
end loop;
end Check_Potentially_Blocking_Operation;
+ ------------------------------------
+ -- Check_Previous_Null_Procedure --
+ ------------------------------------
+
+ procedure Check_Previous_Null_Procedure
+ (Decl : Node_Id;
+ Prev : Entity_Id)
+ is
+ begin
+ if Ekind (Prev) = E_Procedure
+ and then Nkind (Parent (Prev)) = N_Procedure_Specification
+ and then Null_Present (Parent (Prev))
+ then
+ Error_Msg_Sloc := Sloc (Prev);
+ Error_Msg_N
+ ("declaration cannot complete previous null procedure#", Decl);
+ end if;
+ end Check_Previous_Null_Procedure;
+
---------------------------------
-- Check_Result_And_Post_State --
---------------------------------
-- Note that predefined operators are functions as well, and so
-- are attributes that are (can be renamed as) functions.
- when N_Function_Call | N_Binary_Op | N_Unary_Op =>
+ when N_Binary_Op
+ | N_Function_Call
+ | N_Unary_Op
+ =>
return Etype (N) /= Standard_Void_Type;
-- Attributes references 'Loop_Entry, 'Old, and 'Result yield
Nam_In (Attribute_Name (N), Name_Loop_Entry,
Name_Old,
Name_Result)
- or else Is_Function_Attribute_Name (Attribute_Name (N));
+ or else Is_Function_Attribute_Name (Attribute_Name (N));
when N_Selected_Component =>
return
projects / gcc.git / commitdiff