+2013-04-11 Robert Dewar <dewar@adacore.com>
+
+ * exp_attr.adb, sem_res.adb, sem_attr.adb: Minor reformatting.
+
+2013-04-11 Robert Dewar <dewar@adacore.com>
+
+ * atree.adb, atree.ads (Node31): New function.
+ (Set_Node31): New procedure.
+
+2013-04-11 Robert Dewar <dewar@adacore.com>
+
+ * errout.ads: Minor typo correction.
+
+2013-04-11 Javier Miranda <miranda@adacore.com>
+
+ * einfo.ad[sb] (Thunk_Entity/Set_Thunk_Entity): New attribute.
+
2013-04-11 Robert Dewar <dewar@adacore.com>
* back_end.adb (Register_Back_End_Types): Moved to Get_Targ
-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
return Node_Id (Nodes.Table (N + 5).Field6);
end Node30;
+ function Node31 (N : Node_Id) return Node_Id is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ return Node_Id (Nodes.Table (N + 5).Field7);
+ end Node31;
+
function List1 (N : Node_Id) return List_Id is
begin
pragma Assert (N <= Nodes.Last);
Nodes.Table (N + 5).Field6 := Union_Id (Val);
end Set_Node30;
+ procedure Set_Node31 (N : Node_Id; Val : Node_Id) is
+ begin
+ pragma Assert (Nkind (N) in N_Entity);
+ Nodes.Table (N + 5).Field7 := Union_Id (Val);
+ end Set_Node31;
+
procedure Set_List1 (N : Node_Id; Val : List_Id) is
begin
pragma Assert (N <= Nodes.Last);
-- --
-- S p e c --
-- --
--- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2013, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
function Node30 (N : Node_Id) return Node_Id;
pragma Inline (Node30);
+ function Node31 (N : Node_Id) return Node_Id;
+ pragma Inline (Node31);
+
function List1 (N : Node_Id) return List_Id;
pragma Inline (List1);
procedure Set_Node30 (N : Node_Id; Val : Node_Id);
pragma Inline (Set_Node30);
+ procedure Set_Node31 (N : Node_Id; Val : Node_Id);
+ pragma Inline (Set_Node31);
+
procedure Set_List1 (N : Node_Id; Val : List_Id);
pragma Inline (Set_List1);
-- Corresponding_Equality Node30
-- Static_Initialization Node30
- -- (unused) Node31
+ -- Thunk_Entity Node31
-- (unused) Node32
return Node25 (Id);
end Task_Body_Procedure;
+ function Thunk_Entity (Id : E) return E is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ and then Is_Thunk (Id));
+ return Node31 (Id);
+ end Thunk_Entity;
+
function Treat_As_Volatile (Id : E) return B is
begin
return Flag41 (Id);
Set_Node25 (Id, V);
end Set_Task_Body_Procedure;
+ procedure Set_Thunk_Entity (Id : E; V : E) is
+ begin
+ pragma Assert (Ekind_In (Id, E_Function, E_Procedure)
+ and then Is_Thunk (Id));
+ Set_Node31 (Id, V);
+ end Set_Thunk_Entity;
+
procedure Set_Treat_As_Volatile (Id : E; V : B := True) is
begin
Set_Flag41 (Id, V);
E_Variable =>
Write_Str ("Related_Type");
- when E_Procedure =>
+ when E_Procedure |
+ E_Function =>
Write_Str ("Wrapped_Entity");
when others =>
procedure Write_Field31_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
+ when E_Procedure |
+ E_Function =>
+ Write_Str ("Thunk_Entity");
+
when others =>
Write_Str ("Field31??");
end case;
-- The last sentence is odd??? Why not have Task_Body_Procedure go to the
-- Underlying_Type of the Root_Type???
+-- Thunk_Entity (Node31)
+-- Defined in functions and procedures which have been classified as
+-- Is_Thunk. Set to the target entity called by the thunk.
+
-- Treat_As_Volatile (Flag41)
-- Defined in all type entities, and also in constants, components and
-- variables. Set if this entity is to be treated as volatile for code
-- Extra_Formals (Node28)
-- Subprograms_For_Type (Node29)
-- Corresponding_Equality (Node30) (implicit /= only)
+ -- Thunk_Entity (Node31) (thunk case only)
-- Body_Needed_For_SAL (Flag40)
-- Elaboration_Entity_Required (Flag174)
-- Default_Expressions_Processed (Flag108)
-- Wrapped_Entity (Node27) (non-generic case only)
-- Extra_Formals (Node28)
-- Static_Initialization (Node30) (init_proc only)
+ -- Thunk_Entity (Node31) (thunk case only)
-- Body_Needed_For_SAL (Flag40)
-- Delay_Cleanups (Flag114)
-- Discard_Names (Flag88)
function Suppress_Style_Checks (Id : E) return B;
function Suppress_Value_Tracking_On_Call (Id : E) return B;
function Task_Body_Procedure (Id : E) return N;
+ function Thunk_Entity (Id : E) return E;
function Treat_As_Volatile (Id : E) return B;
function Underlying_Full_View (Id : E) return E;
function Underlying_Record_View (Id : E) return E;
procedure Set_Suppress_Style_Checks (Id : E; V : B := True);
procedure Set_Suppress_Value_Tracking_On_Call (Id : E; V : B := True);
procedure Set_Task_Body_Procedure (Id : E; V : N);
+ procedure Set_Thunk_Entity (Id : E; V : E);
procedure Set_Treat_As_Volatile (Id : E; V : B := True);
procedure Set_Underlying_Full_View (Id : E; V : E);
procedure Set_Underlying_Record_View (Id : E; V : E);
pragma Inline (Suppress_Style_Checks);
pragma Inline (Suppress_Value_Tracking_On_Call);
pragma Inline (Task_Body_Procedure);
+ pragma Inline (Thunk_Entity);
pragma Inline (Treat_As_Volatile);
pragma Inline (Underlying_Full_View);
pragma Inline (Underlying_Record_View);
pragma Inline (Set_Suppress_Style_Checks);
pragma Inline (Set_Suppress_Value_Tracking_On_Call);
pragma Inline (Set_Task_Body_Procedure);
+ pragma Inline (Set_Thunk_Entity);
pragma Inline (Set_Treat_As_Volatile);
pragma Inline (Set_Underlying_Full_View);
pragma Inline (Set_Underlying_Record_View);
-- A second ^ may occur in the message, in which case it is replaced
-- by the decimal conversion of the Uint value in Error_Msg_Uint_2.
- -- Insertion character > (Right bracket, run time name)
+ -- Insertion character > (Greater Than, run time name)
-- The character > is replaced by a string of the form (name) if
-- Targparm scanned out a Run_Time_Name (see package Targparm for
-- details). The name is enclosed in parentheses and output in mixed
begin
Subp := Current_Scope;
- while Ekind (Subp) = E_Loop
- or else Ekind (Subp) = E_Block
- loop
+ while Ekind_In (Subp, E_Loop, E_Block) loop
Subp := Scope (Subp);
end loop;
Unchecked_Convert_To (Typ,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Unrestricted_Access,
- Prefix =>
- New_Occurrence_Of (Formal, Loc))));
+ Prefix =>
+ New_Occurrence_Of (Formal, Loc))));
Analyze_And_Resolve (N);
end if;
end;
-- then this is only legal within a task or protected record.
when others =>
- if not Is_Entity_Name (P)
- or else not Is_Type (Entity (P))
- then
+ if not Is_Entity_Name (P) or else not Is_Type (Entity (P)) then
Resolve (P);
end if;
-- 'Class) then this is only legal within a task or protected
-- record. What is this all about ???
- if Is_Entity_Name (N)
- and then Is_Type (Entity (N))
- then
+ if Is_Entity_Name (N) and then Is_Type (Entity (N)) then
if Is_Concurrent_Type (Entity (N))
and then In_Open_Scopes (Entity (P))
then
S : Entity_Id;
begin
- if Ekind (Etype (R)) = E_Allocator_Type
- or else Ekind (Etype (R)) = E_Access_Attribute_Type
+ if Ekind_In (Etype (R), E_Allocator_Type,
+ E_Access_Attribute_Type)
then
Acc := Designated_Type (Etype (R));
- elsif Ekind (Etype (L)) = E_Allocator_Type
- or else Ekind (Etype (L)) = E_Access_Attribute_Type
+ elsif Ekind_In (Etype (L), E_Allocator_Type,
+ E_Access_Attribute_Type)
then
Acc := Designated_Type (Etype (L));
else
projects / thirdparty / gcc.git / commitdiff
