===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -832,7 +832,7 @@
----------------------
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
- D : constant Node_Id := Declaration_Node (Typ);
+ D : constant Node_Id := Original_Node (Declaration_Node (Typ));
begin
-- If we have a subtype declaration, get the ancestor subtype
@@ -860,6 +860,15 @@
end if;
end;
+ -- If derived type and private type, get the full view to find who we
+ -- are derived from.
+
+ elsif Is_Derived_Type (Typ)
+ and then Is_Private_Type (Typ)
+ and then Present (Full_View (Typ))
+ then
+ return Nearest_Ancestor (Full_View (Typ));
+
-- Otherwise, nothing useful to return, return Empty
else
===================================================================
@@ -831,12 +831,18 @@
-- Attributes related to Ada 2012 iterators (placeholder ???)
- when Attribute_Constant_Indexing => null;
- when Attribute_Default_Iterator => null;
- when Attribute_Implicit_Dereference => null;
- when Attribute_Iterator_Element => null;
- when Attribute_Variable_Indexing => null;
+ when Attribute_Constant_Indexing |
+ Attribute_Default_Iterator |
+ Attribute_Implicit_Dereference |
+ Attribute_Iterator_Element |
+ Attribute_Variable_Indexing => null;
+ -- Attributes related to Ada 2012 aspects
+
+ when Attribute_CPU |
+ Attribute_Dispatching_Domain |
+ Attribute_Interrupt_Priority => null;
+
------------
-- Access --
------------
===================================================================
@@ -1476,33 +1476,6 @@
return Flag17 (N);
end Has_No_Elaboration_Code;
- function Has_Pragma_CPU
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Definition);
- return Flag14 (N);
- end Has_Pragma_CPU;
-
- function Has_Pragma_Dispatching_Domain
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Definition);
- return Flag15 (N);
- end Has_Pragma_Dispatching_Domain;
-
- function Has_Pragma_Priority
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Protected_Definition
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Definition);
- return Flag6 (N);
- end Has_Pragma_Priority;
-
function Has_Pragma_Suppress_All
(N : Node_Id) return Boolean is
begin
@@ -1549,22 +1522,6 @@
return Flag5 (N);
end Has_Storage_Size_Pragma;
- function Has_Task_Info_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Definition);
- return Flag7 (N);
- end Has_Task_Info_Pragma;
-
- function Has_Task_Name_Pragma
- (N : Node_Id) return Boolean is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Definition);
- return Flag8 (N);
- end Has_Task_Name_Pragma;
-
function Has_Wide_Character
(N : Node_Id) return Boolean is
begin
@@ -4580,33 +4537,6 @@
Set_Flag17 (N, Val);
end Set_Has_No_Elaboration_Code;
- procedure Set_Has_Pragma_CPU
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Definition);
- Set_Flag14 (N, Val);
- end Set_Has_Pragma_CPU;
-
- procedure Set_Has_Pragma_Dispatching_Domain
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Definition);
- Set_Flag15 (N, Val);
- end Set_Has_Pragma_Dispatching_Domain;
-
- procedure Set_Has_Pragma_Priority
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Protected_Definition
- or else NT (N).Nkind = N_Subprogram_Body
- or else NT (N).Nkind = N_Task_Definition);
- Set_Flag6 (N, Val);
- end Set_Has_Pragma_Priority;
-
procedure Set_Has_Pragma_Suppress_All
(N : Node_Id; Val : Boolean := True) is
begin
@@ -4653,22 +4583,6 @@
Set_Flag5 (N, Val);
end Set_Has_Storage_Size_Pragma;
- procedure Set_Has_Task_Info_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Definition);
- Set_Flag7 (N, Val);
- end Set_Has_Task_Info_Pragma;
-
- procedure Set_Has_Task_Name_Pragma
- (N : Node_Id; Val : Boolean := True) is
- begin
- pragma Assert (False
- or else NT (N).Nkind = N_Task_Definition);
- Set_Flag8 (N, Val);
- end Set_Has_Task_Name_Pragma;
-
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True) is
begin
===================================================================
@@ -1149,16 +1149,6 @@
-- generate elaboration code, and non-preelaborated packages which do
-- not generate elaboration code.
- -- Has_Pragma_CPU (Flag14-Sem)
- -- A flag present in N_Subprogram_Body and N_Task_Definition nodes to
- -- flag the presence of a CPU pragma in the declaration sequence (public
- -- or private in the task case).
-
- -- Has_Pragma_Dispatching_Domain (Flag15-Sem)
- -- A flag present in N_Task_Definition nodes to flag the presence of a
- -- Dispatching_Domain pragma in the declaration sequence (public or
- -- private in the task case).
-
-- Has_Pragma_Suppress_All (Flag14-Sem)
-- This flag is set in an N_Compilation_Unit node if the Suppress_All
-- pragma appears anywhere in the unit. This accommodates the rather
@@ -1168,12 +1158,6 @@
-- Suppress (All_Checks) appearing at the start of the configuration
-- pragmas for the unit.
- -- Has_Pragma_Priority (Flag6-Sem)
- -- A flag present in N_Subprogram_Body, N_Task_Definition and
- -- N_Protected_Definition nodes to flag the presence of either a Priority
- -- or Interrupt_Priority pragma in the declaration sequence (public or
- -- private in the task and protected cases)
-
-- Has_Private_View (Flag11-Sem)
-- A flag present in generic nodes that have an entity, to indicate that
-- the node has a private type. Used to exchange private and full
@@ -1194,14 +1178,6 @@
-- A flag present in an N_Task_Definition node to flag the presence of a
-- Storage_Size pragma.
- -- Has_Task_Info_Pragma (Flag7-Sem)
- -- A flag present in an N_Task_Definition node to flag the presence of a
- -- Task_Info pragma. Used to detect duplicate pragmas.
-
- -- Has_Task_Name_Pragma (Flag8-Sem)
- -- A flag present in N_Task_Definition nodes to flag the presence of a
- -- Task_Name pragma in the declaration sequence for the task.
-
-- Has_Wide_Character (Flag11-Sem)
-- Present in string literals, set if any wide character (i.e. character
-- code outside the Character range but within Wide_Character range)
@@ -4619,13 +4595,11 @@
-- Acts_As_Spec (Flag4-Sem)
-- Bad_Is_Detected (Flag15) used only by parser
-- Do_Storage_Check (Flag17-Sem)
- -- Has_Pragma_Priority (Flag6-Sem)
-- Is_Protected_Subprogram_Body (Flag7-Sem)
-- Is_Entry_Barrier_Function (Flag8-Sem)
-- Is_Task_Master (Flag5-Sem)
-- Was_Originally_Stub (Flag13-Sem)
-- Has_Relative_Deadline_Pragma (Flag9-Sem)
- -- Has_Pragma_CPU (Flag14-Sem)
-------------------------
-- Expression Function --
@@ -5109,13 +5083,8 @@
-- Visible_Declarations (List2)
-- Private_Declarations (List3) (set to No_List if no private part)
-- End_Label (Node4)
- -- Has_Pragma_Priority (Flag6-Sem)
-- Has_Storage_Size_Pragma (Flag5-Sem)
- -- Has_Task_Info_Pragma (Flag7-Sem)
- -- Has_Task_Name_Pragma (Flag8-Sem)
-- Has_Relative_Deadline_Pragma (Flag9-Sem)
- -- Has_Pragma_CPU (Flag14-Sem)
- -- Has_Pragma_Dispatching_Domain (Flag15-Sem)
--------------------
-- 9.1 Task Item --
@@ -5200,7 +5169,6 @@
-- Visible_Declarations (List2)
-- Private_Declarations (List3) (set to No_List if no private part)
-- End_Label (Node4)
- -- Has_Pragma_Priority (Flag6-Sem)
------------------------------------------
-- 9.4 Protected Operation Declaration --
@@ -8566,15 +8534,6 @@
function Has_No_Elaboration_Code
(N : Node_Id) return Boolean; -- Flag17
- function Has_Pragma_CPU
- (N : Node_Id) return Boolean; -- Flag14
-
- function Has_Pragma_Dispatching_Domain
- (N : Node_Id) return Boolean; -- Flag15
-
- function Has_Pragma_Priority
- (N : Node_Id) return Boolean; -- Flag6
-
function Has_Pragma_Suppress_All
(N : Node_Id) return Boolean; -- Flag14
@@ -8590,12 +8549,6 @@
function Has_Storage_Size_Pragma
(N : Node_Id) return Boolean; -- Flag5
- function Has_Task_Info_Pragma
- (N : Node_Id) return Boolean; -- Flag7
-
- function Has_Task_Name_Pragma
- (N : Node_Id) return Boolean; -- Flag8
-
function Has_Wide_Character
(N : Node_Id) return Boolean; -- Flag11
@@ -9556,15 +9509,6 @@
procedure Set_Has_No_Elaboration_Code
(N : Node_Id; Val : Boolean := True); -- Flag17
- procedure Set_Has_Pragma_CPU
- (N : Node_Id; Val : Boolean := True); -- Flag14
-
- procedure Set_Has_Pragma_Dispatching_Domain
- (N : Node_Id; Val : Boolean := True); -- Flag15
-
- procedure Set_Has_Pragma_Priority
- (N : Node_Id; Val : Boolean := True); -- Flag6
-
procedure Set_Has_Pragma_Suppress_All
(N : Node_Id; Val : Boolean := True); -- Flag14
@@ -9580,12 +9524,6 @@
procedure Set_Has_Storage_Size_Pragma
(N : Node_Id; Val : Boolean := True); -- Flag5
- procedure Set_Has_Task_Info_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag7
-
- procedure Set_Has_Task_Name_Pragma
- (N : Node_Id; Val : Boolean := True); -- Flag8
-
procedure Set_Has_Wide_Character
(N : Node_Id; Val : Boolean := True); -- Flag11
@@ -11990,15 +11928,10 @@
pragma Inline (Has_Local_Raise);
pragma Inline (Has_Self_Reference);
pragma Inline (Has_No_Elaboration_Code);
- pragma Inline (Has_Pragma_CPU);
- pragma Inline (Has_Pragma_Dispatching_Domain);
- pragma Inline (Has_Pragma_Priority);
pragma Inline (Has_Pragma_Suppress_All);
pragma Inline (Has_Private_View);
pragma Inline (Has_Relative_Deadline_Pragma);
pragma Inline (Has_Storage_Size_Pragma);
- pragma Inline (Has_Task_Info_Pragma);
- pragma Inline (Has_Task_Name_Pragma);
pragma Inline (Has_Wide_Character);
pragma Inline (Has_Wide_Wide_Character);
pragma Inline (Header_Size_Added);
@@ -12316,15 +12249,10 @@
pragma Inline (Set_Has_Local_Raise);
pragma Inline (Set_Has_Dynamic_Range_Check);
pragma Inline (Set_Has_No_Elaboration_Code);
- pragma Inline (Set_Has_Pragma_CPU);
- pragma Inline (Set_Has_Pragma_Dispatching_Domain);
- pragma Inline (Set_Has_Pragma_Priority);
pragma Inline (Set_Has_Pragma_Suppress_All);
pragma Inline (Set_Has_Private_View);
pragma Inline (Set_Has_Relative_Deadline_Pragma);
pragma Inline (Set_Has_Storage_Size_Pragma);
- pragma Inline (Set_Has_Task_Info_Pragma);
- pragma Inline (Set_Has_Task_Name_Pragma);
pragma Inline (Set_Has_Wide_Character);
pragma Inline (Set_Has_Wide_Wide_Character);
pragma Inline (Set_Header_Size_Added);
===================================================================
@@ -395,15 +395,6 @@
-- the scope of Context_Id and Context_Decls is the declarative list of
-- Context.
- function Find_Task_Or_Protected_Pragma
- (T : Node_Id;
- P : Name_Id) return Node_Id;
- -- Searches the task or protected definition T for the first occurrence
- -- of the pragma whose name is given by P. The caller has ensured that
- -- the pragma is present in the task definition. A special case is that
- -- when P is Name_uPriority, the call will also find Interrupt_Priority.
- -- ??? Should be implemented with the rep item chain mechanism.
-
function Index_Object (Spec_Id : Entity_Id) return Entity_Id;
-- Given a subprogram identifier, return the entity which is associated
-- with the protection entry index in the Protected_Body_Subprogram or the
@@ -11279,30 +11270,30 @@
-- in the pragma, and is used to override the task stack size otherwise
-- associated with the task type.
- -- The _Priority field is present only if a Priority or Interrupt_Priority
- -- pragma appears in the task definition. The expression captures the
- -- argument that was present in the pragma, and is used to provide the Size
- -- parameter to the call to Create_Task.
+ -- The _Priority field is always present. It will be filled at the freeze
+ -- point, when the record init proc is built, to capture the expression of
+ -- a Priority pragma, attribute definition clause or aspect specification
+ -- (see Build_Record_Init_Proc in Exp_Ch3).
-- The _Task_Info field is present only if a Task_Info pragma appears in
-- the task definition. The expression captures the argument that was
-- present in the pragma, and is used to provide the Task_Image parameter
-- to the call to Create_Task.
- -- The _CPU field is present only if a CPU pragma appears in the task
- -- definition. The expression captures the argument that was present in
- -- the pragma, and is used to provide the CPU parameter to the call to
- -- Create_Task.
+ -- The _CPU field is always present. It will be filled at the freeze point,
+ -- when the record init proc is built, to capture the expression of a CPU
+ -- pragma, attribute definition clause or aspect specification (see
+ -- Build_Record_Init_Proc in Exp_Ch3).
-- The _Relative_Deadline field is present only if a Relative_Deadline
-- pragma appears in the task definition. The expression captures the
-- argument that was present in the pragma, and is used to provide the
-- Relative_Deadline parameter to the call to Create_Task.
- -- The _Domain field is present only if a Dispatching_Domain pragma or
- -- aspect appears in the task definition. The expression captures the
- -- argument that was present in the pragma or aspect, and is used to
- -- provide the Dispatching_Domain parameter to the call to Create_Task.
+ -- The _Domain field is always present. It will be filled at the freeze
+ -- point, when the record init proc is built, to capture the expression of
+ -- a Dispatching_Domain pragma, attribute definition clause or aspect
+ -- specification (see Build_Record_Init_Proc in Exp_Ch3).
-- When a task is declared, an instance of the task value record is
-- created. The elaboration of this declaration creates the correct bounds
@@ -11336,21 +11327,65 @@
procedure Expand_N_Task_Type_Declaration (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ TaskId : constant Entity_Id := Defining_Identifier (N);
Tasktyp : constant Entity_Id := Etype (Defining_Identifier (N));
Tasknm : constant Name_Id := Chars (Tasktyp);
Taskdef : constant Node_Id := Task_Definition (N);
+ Body_Decl : Node_Id;
+ Cdecls : List_Id;
+ Decl_Stack : Node_Id;
+ Elab_Decl : Node_Id;
+ Ent_Stack : Entity_Id;
Proc_Spec : Node_Id;
Rec_Decl : Node_Id;
Rec_Ent : Entity_Id;
- Cdecls : List_Id;
- Elab_Decl : Node_Id;
- Size_Decl : Node_Id;
- Body_Decl : Node_Id;
+ Size_Decl : Entity_Id;
Task_Size : Node_Id;
- Ent_Stack : Entity_Id;
- Decl_Stack : Node_Id;
+ function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id;
+ -- Searches the task definition T for the first occurrence of the pragma
+ -- Relative Deadline. The caller has ensured that the pragma is present
+ -- in the task definition. Note that this routine cannot be implemented
+ -- with the Rep Item chain mechanism since Relative_Deadline pragmas are
+ -- not chained because their expansion into a procedure call statement
+ -- would cause a break in the chain.
+
+ ----------------------------------
+ -- Get_Relative_Deadline_Pragma --
+ ----------------------------------
+
+ function Get_Relative_Deadline_Pragma (T : Node_Id) return Node_Id is
+ N : Node_Id;
+
+ begin
+ N := First (Visible_Declarations (T));
+ while Present (N) loop
+ if Nkind (N) = N_Pragma
+ and then Pragma_Name (N) = Name_Relative_Deadline
+ then
+ return N;
+ end if;
+
+ Next (N);
+ end loop;
+
+ N := First (Private_Declarations (T));
+ while Present (N) loop
+ if Nkind (N) = N_Pragma
+ and then Pragma_Name (N) = Name_Relative_Deadline
+ then
+ return N;
+ end if;
+
+ Next (N);
+ end loop;
+
+ raise Program_Error;
+ end Get_Relative_Deadline_Pragma;
+
+ -- Start of processing for Expand_N_Task_Type_Declaration
+
begin
-- If already expanded, nothing to do
@@ -11378,6 +11413,7 @@
Aliased_Present => True,
Object_Definition => New_Reference_To (Standard_Boolean, Loc),
Expression => New_Reference_To (Standard_False, Loc));
+
Insert_After (N, Elab_Decl);
-- Next create the declaration of the size variable (tasknmZ)
@@ -11392,8 +11428,7 @@
Is_Static_Expression
(Expression
(First (Pragma_Argument_Associations
- (Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Storage_Size)))))
+ (Get_Rep_Pragma (TaskId, Name_Storage_Size)))))
then
Size_Decl :=
Make_Object_Declaration (Loc,
@@ -11403,8 +11438,8 @@
Convert_To (RTE (RE_Size_Type),
Relocate_Node
(Expression (First (Pragma_Argument_Associations
- (Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Storage_Size)))))));
+ (Get_Rep_Pragma
+ (TaskId, Name_Storage_Size)))))));
else
Size_Decl :=
@@ -11472,8 +11507,7 @@
Expr_N : constant Node_Id :=
Expression (First (
Pragma_Argument_Associations (
- Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Storage_Size))));
+ Get_Rep_Pragma (TaskId, Name_Storage_Size))));
Etyp : constant Entity_Id := Etype (Expr_N);
P : constant Node_Id := Parent (Expr_N);
@@ -11532,52 +11566,20 @@
Collect_Entry_Families (Loc, Cdecls, Size_Decl, Tasktyp);
- -- Add the _Priority component if a Priority pragma is present
+ -- Add the _Priority component with no expression
- if Present (Taskdef) and then Has_Pragma_Priority (Taskdef) then
- declare
- Prag : constant Node_Id :=
- Find_Task_Or_Protected_Pragma (Taskdef, Name_Priority);
- Expr : Node_Id;
+ Append_To (Cdecls,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uPriority),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (Standard_Integer, Loc))));
- begin
- Expr := First (Pragma_Argument_Associations (Prag));
+ -- Add the _Size component if a Storage_Size pragma is present
- if Nkind (Expr) = N_Pragma_Argument_Association then
- Expr := Expression (Expr);
- end if;
-
- Expr := New_Copy_Tree (Expr);
-
- -- Add conversion to proper type to do range check if required
- -- Note that for runtime units, we allow out of range interrupt
- -- priority values to be used in a priority pragma. This is for
- -- the benefit of some versions of System.Interrupts which use
- -- a special server task with maximum interrupt priority.
-
- if Pragma_Name (Prag) = Name_Priority
- and then not GNAT_Mode
- then
- Rewrite (Expr, Convert_To (RTE (RE_Priority), Expr));
- else
- Rewrite (Expr, Convert_To (RTE (RE_Any_Priority), Expr));
- end if;
-
- Append_To (Cdecls,
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uPriority),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication => New_Reference_To (Standard_Integer,
- Loc)),
- Expression => Expr));
- end;
- end if;
-
- -- Add the _Task_Size component if a Storage_Size pragma is present
-
if Present (Taskdef)
and then Has_Storage_Size_Pragma (Taskdef)
then
@@ -11589,21 +11591,20 @@
Component_Definition =>
Make_Component_Definition (Loc,
Aliased_Present => False,
- Subtype_Indication => New_Reference_To (RTE (RE_Size_Type),
- Loc)),
+ Subtype_Indication =>
+ New_Reference_To (RTE (RE_Size_Type), Loc)),
Expression =>
Convert_To (RTE (RE_Size_Type),
Relocate_Node (
Expression (First (
Pragma_Argument_Associations (
- Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Storage_Size))))))));
+ Get_Rep_Pragma (TaskId, Name_Storage_Size))))))));
end if;
-- Add the _Task_Info component if a Task_Info pragma is present
- if Present (Taskdef) and then Has_Task_Info_Pragma (Taskdef) then
+ if Has_Rep_Pragma_For_Entity (TaskId, Name_Task_Info) then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
@@ -11618,31 +11619,22 @@
Expression => New_Copy (
Expression (First (
Pragma_Argument_Associations (
- Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Task_Info)))))));
+ Get_Rep_Pragma_For_Entity (TaskId, Name_Task_Info)))))));
end if;
- -- Add the _CPU component if a CPU pragma is present
+ -- Add the _CPU component with no expression
- if Present (Taskdef) and then Has_Pragma_CPU (Taskdef) then
- Append_To (Cdecls,
- Make_Component_Declaration (Loc,
- Defining_Identifier =>
- Make_Defining_Identifier (Loc, Name_uCPU),
+ Append_To (Cdecls,
+ Make_Component_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Defining_Identifier (Loc, Name_uCPU),
- Component_Definition =>
- Make_Component_Definition (Loc,
- Aliased_Present => False,
- Subtype_Indication =>
- New_Reference_To (RTE (RE_CPU_Range), Loc)),
+ Component_Definition =>
+ Make_Component_Definition (Loc,
+ Aliased_Present => False,
+ Subtype_Indication =>
+ New_Reference_To (RTE (RE_CPU_Range), Loc))));
- Expression => New_Copy (
- Expression (First (
- Pragma_Argument_Associations (
- Find_Task_Or_Protected_Pragma
- (Taskdef, Name_CPU)))))));
- end if;
-
-- Add the _Relative_Deadline component if a Relative_Deadline pragma is
-- present. If we are using a restricted run time this component will
-- not be added (deadlines are not allowed by the Ravenscar profile).
@@ -11667,19 +11659,14 @@
Relocate_Node (
Expression (First (
Pragma_Argument_Associations (
- Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Relative_Deadline))))))));
+ Get_Relative_Deadline_Pragma (Taskdef))))))));
end if;
- -- Add the _Dispatching_Domain component if a Dispatching_Domain pragma
- -- or aspect is present. If we are using a restricted run time this
- -- component will not be added (dispatching domains are not allowed by
- -- the Ravenscar profile).
+ -- Add the _Dispatching_Domain component with no expression. If we are
+ -- using a restricted run time this component will not be added
+ -- (dispatching domains are not allowed by the Ravenscar profile).
- if not Restricted_Profile
- and then Present (Taskdef)
- and then Has_Pragma_Dispatching_Domain (Taskdef)
- then
+ if not Restricted_Profile then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
@@ -11690,16 +11677,7 @@
Aliased_Present => False,
Subtype_Indication =>
New_Reference_To
- (RTE (RE_Dispatching_Domain_Access), Loc)),
-
- Expression =>
- Unchecked_Convert_To (RTE (RE_Dispatching_Domain_Access),
- Relocate_Node
- (Expression
- (First
- (Pragma_Argument_Associations
- (Find_Task_Or_Protected_Pragma
- (Taskdef, Name_Dispatching_Domain))))))));
+ (RTE (RE_Dispatching_Domain_Access), Loc))));
end if;
Insert_After (Size_Decl, Rec_Decl);
@@ -12750,60 +12728,6 @@
return S;
end Find_Master_Scope;
- -----------------------------------
- -- Find_Task_Or_Protected_Pragma --
- -----------------------------------
-
- function Find_Task_Or_Protected_Pragma
- (T : Node_Id;
- P : Name_Id) return Node_Id
- is
- N : Node_Id;
-
- begin
- N := First (Visible_Declarations (T));
- while Present (N) loop
- if Nkind (N) = N_Pragma then
- if Pragma_Name (N) = P then
- return N;
-
- elsif P = Name_Priority
- and then Pragma_Name (N) = Name_Interrupt_Priority
- then
- return N;
-
- else
- Next (N);
- end if;
-
- else
- Next (N);
- end if;
- end loop;
-
- N := First (Private_Declarations (T));
- while Present (N) loop
- if Nkind (N) = N_Pragma then
- if Pragma_Name (N) = P then
- return N;
-
- elsif P = Name_Priority
- and then Pragma_Name (N) = Name_Interrupt_Priority
- then
- return N;
-
- else
- Next (N);
- end if;
-
- else
- Next (N);
- end if;
- end loop;
-
- raise Program_Error;
- end Find_Task_Or_Protected_Pragma;
-
-------------------------------
-- First_Protected_Operation --
-------------------------------
@@ -13362,7 +13286,6 @@
is
Loc : constant Source_Ptr := Sloc (Protect_Rec);
P_Arr : Entity_Id;
- Pdef : Node_Id;
Pdec : Node_Id;
Ptyp : constant Node_Id :=
Corresponding_Concurrent_Type (Protect_Rec);
@@ -13392,10 +13315,6 @@
Next (Pdec);
end loop;
- -- Now we can find the object definition from this declaration
-
- Pdef := Protected_Definition (Pdec);
-
-- Build the parameter list for the call. Note that _Init is the name
-- of the formal for the object to be initialized, which is the task
-- value record itself.
@@ -13418,24 +13337,34 @@
Attribute_Name => Name_Unchecked_Access));
-- Priority parameter. Set to Unspecified_Priority unless there is a
- -- priority pragma, in which case we take the value from the pragma,
- -- or there is an interrupt pragma and no priority pragma, and we
- -- set the ceiling to Interrupt_Priority'Last, an implementation-
- -- defined value, see D.3(10).
+ -- priority clause, in which case we take the value from the
+ -- pragma/attribute definition clause, or there is an interrupt
+ -- clause and no priority clause, and we set the ceiling to
+ -- Interrupt_Priority'Last, an implementation defined value,
+ -- see D.3(10).
- if Present (Pdef)
- and then Has_Pragma_Priority (Pdef)
- then
+ if Has_Rep_Item (Ptyp, Name_Priority) then
declare
- Prio : constant Node_Id :=
- Expression
- (First
- (Pragma_Argument_Associations
- (Find_Task_Or_Protected_Pragma
- (Pdef, Name_Priority))));
+ Prio_Clause : constant Node_Id :=
+ Get_Rep_Item (Ptyp, Name_Priority);
+
+ Prio : Node_Id;
Temp : Entity_Id;
begin
+ -- Pragma Priority
+
+ if Nkind (Prio_Clause) = N_Pragma then
+ Prio :=
+ Expression
+ (First (Pragma_Argument_Associations (Prio_Clause)));
+
+ -- Attribute definition clause Priority
+
+ else
+ Prio := Expression (Prio_Clause);
+ end if;
+
-- If priority is a static expression, then we can duplicate it
-- with no problem and simply append it to the argument list.
@@ -13738,9 +13667,9 @@
Args := New_List;
-- Priority parameter. Set to Unspecified_Priority unless there is a
- -- priority pragma, in which case we take the value from the pragma.
+ -- priority rep item, in which case we take the value from the rep item.
- if Present (Tdef) and then Has_Pragma_Priority (Tdef) then
+ if Has_Rep_Item (Ttyp, Name_Priority) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
@@ -13795,9 +13724,7 @@
-- Task_Info parameter. Set to Unspecified_Task_Info unless there is a
-- Task_Info pragma, in which case we take the value from the pragma.
- if Present (Tdef)
- and then Has_Task_Info_Pragma (Tdef)
- then
+ if Has_Rep_Pragma_For_Entity (Ttyp, Name_Task_Info) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
@@ -13808,18 +13735,17 @@
New_Reference_To (RTE (RE_Unspecified_Task_Info), Loc));
end if;
- -- CPU parameter. Set to Unspecified_CPU unless there is a CPU pragma,
- -- in which case we take the value from the pragma. The parameter is
+ -- CPU parameter. Set to Unspecified_CPU unless there is a CPU rep item,
+ -- in which case we take the value from the rep item. The parameter is
-- passed as an Integer because in the case of unspecified CPU the
-- value is not in the range of CPU_Range.
- if Present (Tdef) and then Has_Pragma_CPU (Tdef) then
+ if Has_Rep_Item (Ttyp, Name_CPU) then
Append_To (Args,
Convert_To (Standard_Integer,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
Selector_Name => Make_Identifier (Loc, Name_uCPU))));
-
else
Append_To (Args,
New_Reference_To (RTE (RE_Unspecified_CPU), Loc));
@@ -13836,7 +13762,9 @@
-- Case where pragma Relative_Deadline applies: use given value
- if Present (Tdef) and then Has_Relative_Deadline_Pragma (Tdef) then
+ if Present (Tdef)
+ and then Has_Relative_Deadline_Pragma (Tdef)
+ then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix =>
@@ -13851,18 +13779,17 @@
New_Reference_To (RTE (RE_Time_Span_Zero), Loc));
end if;
- -- Dispatching_Domain parameter. If no Dispatching_Domain pragma or
- -- aspect is present, then the dispatching domain is null. If a
- -- pragma or aspect is present, then the dispatching domain is taken
- -- from the _Dispatching_Domain field of the task value record,
- -- which was set from the pragma value. Note that this parameter
- -- must not be generated for the restricted profiles since Ravenscar
- -- does not allow dispatching domains.
+ -- Dispatching_Domain parameter. If no Dispatching_Domain rep item is
+ -- present, then the dispatching domain is null. If a rep item is
+ -- present, then the dispatching domain is taken from the
+ -- _Dispatching_Domain field of the task value record, which was set
+ -- from the rep item value. Note that this parameter must not be
+ -- generated for the restricted profiles since Ravenscar does not
+ -- allow dispatching domains.
- -- Case where pragma or aspect Dispatching_Domain applies: use given
- -- value.
+ -- Case where Dispatching_Domain rep item applies: use given value
- if Present (Tdef) and then Has_Pragma_Dispatching_Domain (Tdef) then
+ if Has_Rep_Item (Ttyp, Name_Dispatching_Domain) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix =>
@@ -13980,18 +13907,16 @@
-- init call unless there is a Task_Name pragma, in which case we take
-- the value from the pragma.
- if Present (Tdef)
- and then Has_Task_Name_Pragma (Tdef)
- then
+ if Has_Rep_Pragma_For_Entity (Ttyp, Name_Task_Name) then
-- Copy expression in full, because it may be dynamic and have
-- side effects.
Append_To (Args,
New_Copy_Tree
- (Expression (First
- (Pragma_Argument_Associations
- (Find_Task_Or_Protected_Pragma
- (Tdef, Name_Task_Name))))));
+ (Expression
+ (First
+ (Pragma_Argument_Associations
+ (Get_Rep_Pragma_For_Entity (Ttyp, Name_Task_Name))))));
else
Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
===================================================================
@@ -111,10 +111,6 @@
-- Find entity in corresponding task or protected declaration. Use full
-- view if first declaration was for an incomplete type.
- procedure Install_Declarations (Spec : Entity_Id);
- -- Utility to make visible in corresponding body the entities defined in
- -- task, protected type declaration, or entry declaration.
-
-------------------------------------
-- Allows_Lock_Free_Implementation --
-------------------------------------
@@ -2983,4 +2979,91 @@
end loop;
end Install_Declarations;
+ ---------------------------
+ -- Install_Discriminants --
+ ---------------------------
+
+ procedure Install_Discriminants (E : Entity_Id) is
+ Disc : Entity_Id;
+ Prev : Entity_Id;
+ begin
+ Disc := First_Discriminant (E);
+ while Present (Disc) loop
+ Prev := Current_Entity (Disc);
+ Set_Current_Entity (Disc);
+ Set_Is_Immediately_Visible (Disc);
+ Set_Homonym (Disc, Prev);
+ Next_Discriminant (Disc);
+ end loop;
+ end Install_Discriminants;
+
+ ------------------------------------------
+ -- Push_Scope_And_Install_Discriminants --
+ ------------------------------------------
+
+ procedure Push_Scope_And_Install_Discriminants (E : Entity_Id) is
+ begin
+ if Has_Discriminants (E) then
+ Push_Scope (E);
+ Install_Discriminants (E);
+ end if;
+ end Push_Scope_And_Install_Discriminants;
+
+ -----------------------------
+ -- Uninstall_Discriminants --
+ -----------------------------
+
+ procedure Uninstall_Discriminants (E : Entity_Id) is
+ Disc : Entity_Id;
+ Prev : Entity_Id;
+ Outer : Entity_Id;
+
+ begin
+ Disc := First_Discriminant (E);
+ while Present (Disc) loop
+ if Disc /= Current_Entity (Disc) then
+ Prev := Current_Entity (Disc);
+ while Present (Prev)
+ and then Present (Homonym (Prev))
+ and then Homonym (Prev) /= Disc
+ loop
+ Prev := Homonym (Prev);
+ end loop;
+ else
+ Prev := Empty;
+ end if;
+
+ Set_Is_Immediately_Visible (Disc, False);
+
+ Outer := Homonym (Disc);
+ while Present (Outer) and then Scope (Outer) = E loop
+ Outer := Homonym (Outer);
+ end loop;
+
+ -- Reset homonym link of other entities, but do not modify link
+ -- between entities in current scope, so that the back-end can have
+ -- a proper count of local overloadings.
+
+ if No (Prev) then
+ Set_Name_Entity_Id (Chars (Disc), Outer);
+
+ elsif Scope (Prev) /= Scope (Disc) then
+ Set_Homonym (Prev, Outer);
+ end if;
+
+ Next_Discriminant (Disc);
+ end loop;
+ end Uninstall_Discriminants;
+
+ -------------------------------------------
+ -- Uninstall_Discriminants_And_Pop_Scope --
+ -------------------------------------------
+
+ procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id) is
+ begin
+ if Has_Discriminants (E) then
+ Uninstall_Discriminants (E);
+ Pop_Scope;
+ end if;
+ end Uninstall_Discriminants_And_Pop_Scope;
end Sem_Ch9;
===================================================================
@@ -54,6 +54,25 @@
procedure Analyze_Timed_Entry_Call (N : Node_Id);
procedure Analyze_Triggering_Alternative (N : Node_Id);
+ procedure Install_Declarations (Spec : Entity_Id);
+ -- Utility to make visible in corresponding body the entities defined in
+ -- task, protected type declaration, or entry declaration.
+
+ procedure Install_Discriminants (E : Entity_Id);
+ -- Utility to make visible the discriminants of type entity E
+
+ procedure Push_Scope_And_Install_Discriminants (E : Entity_Id);
+ -- Utility that pushes the scope E and makes visible the discriminants of
+ -- type entity E if E has discriminants.
+
+ procedure Uninstall_Discriminants (E : Entity_Id);
+ -- Utility that removes the visibility to the discriminants of type entity
+ -- E.
+
+ procedure Uninstall_Discriminants_And_Pop_Scope (E : Entity_Id);
+ -- Utility that removes the visibility to the discriminants of type entity
+ -- E and pop the scope stack if E has discriminants.
+
------------------------------
-- Lock Free Data Structure --
------------------------------
===================================================================
@@ -35,6 +35,7 @@
with Atree; use Atree;
with Nlists; use Nlists;
with Output; use Output;
+with Sem_Aux; use Sem_Aux;
with Sinfo; use Sinfo;
with Stand; use Stand;
@@ -283,7 +284,6 @@
-- Checks_May_Be_Suppressed Flag31
-- Kill_Elaboration_Checks Flag32
-- Kill_Range_Checks Flag33
- -- Kill_Tag_Checks Flag34
-- Is_Class_Wide_Equivalent_Type Flag35
-- Referenced_As_LHS Flag36
-- Is_Known_Non_Null Flag37
@@ -526,6 +526,7 @@
-- Has_Anonymous_Master Flag253
-- Is_Implementation_Defined Flag254
+ -- (unused) Flag34
-- (unused) Flag201
-----------------------
@@ -2210,11 +2211,6 @@
return Flag33 (Id);
end Kill_Range_Checks;
- function Kill_Tag_Checks (Id : E) return B is
- begin
- return Flag34 (Id);
- end Kill_Tag_Checks;
-
function Known_To_Have_Preelab_Init (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
@@ -2781,7 +2777,7 @@
function Universal_Aliasing (Id : E) return B is
begin
pragma Assert (Is_Type (Id));
- return Flag216 (Base_Type (Id));
+ return Flag216 (Implementation_Base_Type (Id));
end Universal_Aliasing;
function Unset_Reference (Id : E) return N is
@@ -4760,11 +4756,6 @@
Set_Flag33 (Id, V);
end Set_Kill_Range_Checks;
- procedure Set_Kill_Tag_Checks (Id : E; V : B := True) is
- begin
- Set_Flag34 (Id, V);
- end Set_Kill_Tag_Checks;
-
procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True) is
begin
pragma Assert (Is_Type (Id));
@@ -5988,6 +5979,44 @@
return Empty;
end Get_Attribute_Definition_Clause;
+ ------------------
+ -- Get_Rep_Item --
+ ------------------
+
+ function Get_Rep_Item
+ (E : Entity_Id;
+ Nam : Name_Id) return Node_Id
+ is
+ N : Node_Id;
+ N_Nam : Name_Id := No_Name;
+
+ begin
+ N := First_Rep_Item (E);
+
+ while Present (N) loop
+ if Nkind (N) = N_Pragma then
+ N_Nam := Pragma_Name (N);
+
+ elsif Nkind (N) = N_Attribute_Definition_Clause then
+ N_Nam := Chars (N);
+
+ elsif Nkind (N) = N_Aspect_Specification then
+ N_Nam := Chars (Identifier (N));
+ end if;
+
+ if N_Nam = Nam
+ or else (Nam = Name_Priority
+ and then N_Nam = Name_Interrupt_Priority)
+ then
+ return N;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+
+ return Empty;
+ end Get_Rep_Item;
+
-------------------
-- Get_Full_View --
-------------------
@@ -6036,28 +6065,47 @@
(E : Entity_Id;
Nam : Name_Id) return Node_Id
is
+ Par : constant Entity_Id := Nearest_Ancestor (E);
+ -- In case of a derived type or subtype, this node represents the parent
+ -- type of type E.
+
N : Node_Id;
- Arg : Node_Id;
begin
N := First_Rep_Item (E);
while Present (N) loop
- if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then
- Arg := Get_Pragma_Arg (First (Pragma_Argument_Associations (N)));
+ if Nkind (N) = N_Pragma
+ and then
+ (Pragma_Name (N) = Nam
+ or else (Nam = Name_Priority
+ and then Pragma_Name (N) = Name_Interrupt_Priority))
+ then
+ -- Return N if the pragma doesn't appear in the Rep_Item chain of
+ -- the parent.
- if Is_Entity_Name (Arg) and then Entity (Arg) = E then
+ if No (Par) then
return N;
+
+ elsif not Present_In_Rep_Item (Par, N) then
+ return N;
end if;
elsif Nkind (N) = N_Attribute_Definition_Clause
- and then Chars (N) = Nam
and then Entity (N) = E
+ and then
+ (Chars (N) = Nam
+ or else (Nam = Name_Priority
+ and then Chars (N) = Name_Interrupt_Priority))
then
return N;
elsif Nkind (N) = N_Aspect_Specification
- and then Chars (Identifier (N)) = Nam
and then Entity (N) = E
+ and then
+ (Chars (Identifier (N)) = Nam
+ or else (Nam = Name_Priority
+ and then Chars (Identifier (N)) =
+ Name_Interrupt_Priority))
then
return N;
end if;
@@ -6078,7 +6126,12 @@
begin
N := First_Rep_Item (E);
while Present (N) loop
- if Nkind (N) = N_Pragma and then Pragma_Name (N) = Nam then
+ if Nkind (N) = N_Pragma
+ and then
+ (Pragma_Name (N) = Nam
+ or else (Nam = Name_Interrupt_Priority
+ and then Pragma_Name (N) = Name_Priority))
+ then
return N;
end if;
@@ -6088,6 +6141,30 @@
return Empty;
end Get_Rep_Pragma;
+ -------------------------------
+ -- Get_Rep_Pragma_For_Entity --
+ -------------------------------
+
+ function Get_Rep_Pragma_For_Entity
+ (E : Entity_Id; Nam : Name_Id) return Node_Id
+ is
+ Par : constant Entity_Id := Nearest_Ancestor (E);
+ -- In case of a derived type or subtype, this node represents the parent
+ -- type of type E.
+
+ Prag : constant Node_Id := Get_Rep_Pragma (E, Nam);
+
+ begin
+ if No (Par) then
+ return Prag;
+
+ elsif not Present_In_Rep_Item (Par, Prag) then
+ return Prag;
+ end if;
+
+ return Empty;
+ end Get_Rep_Pragma_For_Entity;
+
------------------------
-- Has_Attach_Handler --
------------------------
@@ -6112,18 +6189,6 @@
return False;
end Has_Attach_Handler;
- -------------------------------------
- -- Has_Attribute_Definition_Clause --
- -------------------------------------
-
- function Has_Attribute_Definition_Clause
- (E : Entity_Id;
- Id : Attribute_Id) return Boolean
- is
- begin
- return Present (Get_Attribute_Definition_Clause (E, Id));
- end Has_Attribute_Definition_Clause;
-
-----------------
-- Has_Entries --
-----------------
@@ -6185,6 +6250,15 @@
return False;
end Has_Interrupt_Handler;
+ ------------------
+ -- Has_Rep_Item --
+ ------------------
+
+ function Has_Rep_Item (E : Entity_Id; Nam : Name_Id) return Boolean is
+ begin
+ return Present (Get_Rep_Item (E, Nam));
+ end Has_Rep_Item;
+
--------------------
-- Has_Rep_Pragma --
--------------------
@@ -6194,6 +6268,17 @@
return Present (Get_Rep_Pragma (E, Nam));
end Has_Rep_Pragma;
+ -------------------------------
+ -- Has_Rep_Pragma_For_Entity --
+ -------------------------------
+
+ function Has_Rep_Pragma_For_Entity
+ (E : Entity_Id; Nam : Name_Id) return Boolean
+ is
+ begin
+ return Present (Get_Rep_Pragma_For_Entity (E, Nam));
+ end Has_Rep_Pragma_For_Entity;
+
--------------------
-- Has_Unmodified --
--------------------
@@ -6972,6 +7057,27 @@
return Ekind (Id);
end Parameter_Mode;
+ -------------------------
+ -- Present_In_Rep_Item --
+ -------------------------
+
+ function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean is
+ Ritem : Node_Id;
+
+ begin
+ Ritem := First_Rep_Item (E);
+
+ while Present (Ritem) loop
+ if Ritem = N then
+ return True;
+ end if;
+
+ Next_Rep_Item (Ritem);
+ end loop;
+
+ return False;
+ end Present_In_Rep_Item;
+
--------------------------
-- Primitive_Operations --
--------------------------
@@ -7654,7 +7760,6 @@
W ("Itype_Printed", Flag202 (Id));
W ("Kill_Elaboration_Checks", Flag32 (Id));
W ("Kill_Range_Checks", Flag33 (Id));
- W ("Kill_Tag_Checks", Flag34 (Id));
W ("Known_To_Have_Preelab_Init", Flag207 (Id));
W ("Low_Bound_Tested", Flag205 (Id));
W ("Machine_Radix_10", Flag84 (Id));
===================================================================
@@ -729,11 +729,11 @@
-- declared the entity. Normally this is just the Parent of the entity.
-- One exception arises with child units, where the parent of the entity
-- is a selected component/defining program unit name. Another exception
+-- is that if the entity is an incomplete type that has been completed or
+-- a private type, then we obtain the declaration node denoted by the
+-- full type, i.e. the full type declaration node. Also note that for
+-- subprograms, this returns the {function,procedure}_specification, not
+-- the subprogram_declaration.
-- Default_Aspect_Component_Value (Node19)
-- Present in array types. Holds the static value specified in a
@@ -2907,13 +2907,6 @@
-- This is currently only used in one odd situation in Sem_Ch3 for
-- record types, and it would be good to get rid of it???
-
-- Known_To_Have_Preelab_Init (Flag207)
-- Present in all type and subtype entities. If set, then the type is
-- known to have preelaborable initialization. In the case of a partial
@@ -4852,7 +4845,6 @@
-- Is_VMS_Exception (Flag133)
-- Kill_Elaboration_Checks (Flag32)
-- Kill_Range_Checks (Flag33)
- -- Kill_Tag_Checks (Flag34)
-- Low_Bound_Tested (Flag205)
-- Materialize_Entity (Flag168)
-- Needs_Debug_Info (Flag147)
@@ -6310,7 +6302,6 @@
function Itype_Printed (Id : E) return B;
function Kill_Elaboration_Checks (Id : E) return B;
function Kill_Range_Checks (Id : E) return B;
- function Kill_Tag_Checks (Id : E) return B;
function Known_To_Have_Preelab_Init (Id : E) return B;
function Last_Assignment (Id : E) return N;
function Last_Entity (Id : E) return E;
@@ -6907,7 +6898,6 @@
procedure Set_Itype_Printed (Id : E; V : B := True);
procedure Set_Kill_Elaboration_Checks (Id : E; V : B := True);
procedure Set_Kill_Range_Checks (Id : E; V : B := True);
- procedure Set_Kill_Tag_Checks (Id : E; V : B := True);
procedure Set_Known_To_Have_Preelab_Init (Id : E; V : B := True);
procedure Set_Last_Assignment (Id : E; V : N);
procedure Set_Last_Entity (Id : E; V : E);
@@ -7200,15 +7190,25 @@
-- value returned is the N_Attribute_Definition_Clause node, otherwise
-- Empty is returned.
+ function Get_Rep_Item
+ (E : Entity_Id;
+ Nam : Name_Id) return Node_Id;
+ -- Searches the Rep_Item chain for a given entity E, for the first
+ -- occurrence of a rep item (pragma, attribute definition clause, or aspect
+ -- specification) whose name matches the given name. If one is found, it is
+ -- returned, otherwise Empty is returned. A special case is that when Nam
+ -- is Name_Priority, the call will also find Interrupt_Priority.
+
function Get_Rep_Item_For_Entity
(E : Entity_Id;
Nam : Name_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of a
-- rep item (pragma, attribute definition clause, or aspect specification)
-- whose name matches the given name. If one is found, it is returned,
- -- otherwise Empty is returned. Unlike the other Get routines for the
- -- Rep_Item chain, this only returns items whose entity matches E (it
- -- does not return items from the parent chain).
+ -- otherwise Empty is returned. This routine only returns items whose
+ -- entity matches E (it does not return items from the parent chain). A
+ -- special case is that when Nam is Name_Priority, the call will also find
+ -- Interrupt_Priority.
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for a record
@@ -7218,20 +7218,34 @@
function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id;
-- Searches the Rep_Item chain for the given entity E, for an instance
-- a representation pragma with the given name Nam. If found then the
- -- value returned is the N_Pragma node, otherwise Empty is returned.
+ -- value returned is the N_Pragma node, otherwise Empty is returned. A
+ -- special case is that when Nam is Name_Priority, the call will also find
+ -- Interrupt_Priority.
+ function Get_Rep_Pragma_For_Entity
+ (E : Entity_Id; Nam : Name_Id) return Node_Id;
+ -- Same as Get_Rep_Pragma except that this routine returns a pragma that
+ -- doesn't appear in the Rep Item chain of the parent of E (if any).
+
+ function Has_Rep_Item (E : Entity_Id; Nam : Name_Id) return Boolean;
+ -- Searches the Rep_Item chain for the given entity E, for an instance
+ -- of rep item with the given name Nam. If found then True is returned,
+ -- otherwise False indicates that no matching entry was found.
+
function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance
-- of representation pragma with the given name Nam. If found then True
-- is returned, otherwise False indicates that no matching entry was found.
- function Has_Attribute_Definition_Clause
- (E : Entity_Id;
- Id : Attribute_Id) return Boolean;
- -- Searches the Rep_Item chain for a given entity E, for an instance of an
- -- attribute definition clause with the given attribute Id. If found, True
- -- is returned, otherwise False indicates that no matching entry was found.
+ function Has_Rep_Pragma_For_Entity
+ (E : Entity_Id; Nam : Name_Id) return Boolean;
+ -- Same as Has_Rep_Pragma except that this routine doesn't return True if
+ -- the representation pragma is also present in the Rep Item chain of the
+ -- parent of E (if any).
+ function Present_In_Rep_Item (E : Entity_Id; N : Node_Id) return Boolean;
+ -- Return True if N is present in the Rep_Item chain for a given entity E
+
procedure Record_Rep_Item (E : Entity_Id; N : Node_Id);
-- N is the node for a representation pragma, representation clause, an
-- attribute definition clause, or an aspect specification that applies to
@@ -7650,7 +7664,6 @@
pragma Inline (Itype_Printed);
pragma Inline (Kill_Elaboration_Checks);
pragma Inline (Kill_Range_Checks);
- pragma Inline (Kill_Tag_Checks);
pragma Inline (Known_To_Have_Preelab_Init);
pragma Inline (Last_Assignment);
pragma Inline (Last_Entity);
@@ -8056,7 +8069,6 @@
pragma Inline (Set_Itype_Printed);
pragma Inline (Set_Kill_Elaboration_Checks);
pragma Inline (Set_Kill_Range_Checks);
- pragma Inline (Set_Kill_Tag_Checks);
pragma Inline (Set_Known_To_Have_Preelab_Init);
pragma Inline (Set_Last_Assignment);
pragma Inline (Set_Last_Entity);
===================================================================
@@ -7378,12 +7378,10 @@
function Tag_Checks_Suppressed (E : Entity_Id) return Boolean is
begin
- if Present (E) then
- if Kill_Tag_Checks (E) then
- return True;
- elsif Checks_May_Be_Suppressed (E) then
- return Is_Check_Suppressed (E, Tag_Check);
- end if;
+ if Present (E)
+ and then Checks_May_Be_Suppressed (E)
+ then
+ return Is_Check_Suppressed (E, Tag_Check);
end if;
return Scope_Suppress (Tag_Check);
===================================================================
@@ -571,10 +571,9 @@
-- error message for bad placement is given.
procedure Check_Duplicate_Pragma (E : Entity_Id);
- -- Check if a pragma of the same name as the current pragma is already
+ -- Check if a rep item of the same name as the current pragma is already
-- chained as a rep pragma to the given entity. If so give a message
-- about the duplicate, and then raise Pragma_Exit so does not return.
- -- Also checks for delayed aspect specification node in the chain.
procedure Check_Duplicated_Export_Name (Nam : Node_Id);
-- Nam is an N_String_Literal node containing the external name set by
@@ -1598,7 +1597,8 @@
----------------------------
procedure Check_Duplicate_Pragma (E : Entity_Id) is
- P : Node_Id;
+ Id : Entity_Id := E;
+ P : Node_Id;
begin
-- Nothing to do if this pragma comes from an aspect specification,
@@ -1610,7 +1610,8 @@
end if;
-- Otherwise current pragma may duplicate previous pragma or a
- -- previously given aspect specification for the same pragma.
+ -- previously given aspect specification or attribute definition
+ -- clause for the same pragma.
P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
@@ -1618,12 +1619,25 @@
Error_Msg_Name_1 := Pragma_Name (N);
Error_Msg_Sloc := Sloc (P);
+ -- For a single protected or a single task object, the error is
+ -- issued on the original entity.
+
+ if Ekind (Id) = E_Task_Type
+ or else Ekind (Id) = E_Protected_Type
+ then
+ Id := Defining_Identifier (Original_Node (Parent (Id)));
+ end if;
+
if Nkind (P) = N_Aspect_Specification
or else From_Aspect_Specification (P)
then
- Error_Msg_NE ("aspect% for & previously given#", N, E);
+ Error_Msg_NE ("aspect% for & previously given#", N, Id);
+
+ elsif Nkind (P) = N_Pragma then
+ Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
+
else
- Error_Msg_NE ("pragma% for & duplicates pragma#", N, E);
+ Error_Msg_NE ("pragma% for & duplicates clause#", N, Id);
end if;
raise Pragma_Exit;
@@ -2917,7 +2931,7 @@
end Pragma_Misplaced;
------------------------------------
- -- Process Atomic_Shared_Volatile --
+ -- Process_Atomic_Shared_Volatile --
------------------------------------
procedure Process_Atomic_Shared_Volatile is
@@ -6597,6 +6611,7 @@
end if;
Set_Is_Ada_2005_Only (Entity (E_Id));
+ Record_Rep_Item (Entity (E_Id), N);
else
Check_Arg_Count (0);
@@ -6644,6 +6659,7 @@
end if;
Set_Is_Ada_2012_Only (Entity (E_Id));
+ Record_Rep_Item (Entity (E_Id), N);
else
Check_Arg_Count (0);
@@ -7149,6 +7165,7 @@
Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1);
end if;
end Atomic_Components;
+
--------------------
-- Attach_Handler --
--------------------
@@ -7931,6 +7948,7 @@
when Pragma_CPU => CPU : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
+ Ent : Entity_Id;
begin
Ada_2012_Pragma;
@@ -7945,6 +7963,12 @@
Arg := Get_Pragma_Arg (Arg1);
Analyze_And_Resolve (Arg, Any_Integer);
+ Ent := Defining_Unit_Name (Specification (P));
+
+ if Nkind (Ent) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (Ent);
+ end if;
+
-- Must be static
if not Is_Static_Expression (Arg) then
@@ -7984,6 +8008,7 @@
elsif Nkind (P) = N_Task_Definition then
Arg := Get_Pragma_Arg (Arg1);
+ Ent := Defining_Identifier (Parent (P));
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
@@ -7997,15 +8022,12 @@
Pragma_Misplaced;
end if;
- if Has_Pragma_CPU (P) then
- Error_Pragma ("duplicate pragma% not allowed");
- else
- Set_Has_Pragma_CPU (P, True);
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
- if Nkind (P) = N_Task_Definition then
- Record_Rep_Item (Defining_Identifier (Parent (P)), N);
- end if;
- end if;
+ Check_Duplicate_Pragma (Ent);
+
+ Record_Rep_Item (Ent, N);
end CPU;
-----------
@@ -8249,6 +8271,8 @@
or else Ekind (E) = E_Exception
then
Set_Discard_Names (E);
+ Record_Rep_Item (E, N);
+
else
Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1);
@@ -8267,6 +8291,7 @@
when Pragma_Dispatching_Domain => Dispatching_Domain : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
+ Ent : Entity_Id;
begin
Ada_2012_Pragma;
@@ -8282,6 +8307,7 @@
if Nkind (P) = N_Task_Definition then
Arg := Get_Pragma_Arg (Arg1);
+ Ent := Defining_Identifier (Parent (P));
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
@@ -8289,21 +8315,18 @@
Preanalyze_Spec_Expression (Arg, RTE (RE_Dispatching_Domain));
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
+
+ Check_Duplicate_Pragma (Ent);
+
+ Record_Rep_Item (Ent, N);
+
-- Anything else is incorrect
else
Pragma_Misplaced;
end if;
-
- if Has_Pragma_Dispatching_Domain (P) then
- Error_Pragma ("duplicate pragma% not allowed");
- else
- Set_Has_Pragma_Dispatching_Domain (P, True);
-
- if Nkind (P) = N_Task_Definition then
- Record_Rep_Item (Defining_Identifier (Parent (P)), N);
- end if;
- end if;
end Dispatching_Domain;
---------------
@@ -10235,6 +10258,7 @@
when Pragma_Interrupt_Priority => Interrupt_Priority : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
+ Ent : Entity_Id;
begin
Check_Ada_83_Warning;
@@ -10255,12 +10279,15 @@
Pragma_Misplaced;
return;
- elsif Has_Pragma_Priority (P) then
- Error_Pragma ("duplicate pragma% not allowed");
+ else
+ Ent := Defining_Identifier (Parent (P));
- else
- Set_Has_Pragma_Priority (P, True);
- Record_Rep_Item (Defining_Identifier (Parent (P)), N);
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
+
+ Check_Duplicate_Pragma (Ent);
+
+ Record_Rep_Item (Ent, N);
end if;
end Interrupt_Priority;
@@ -12295,6 +12322,7 @@
when Pragma_Priority => Priority : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
+ Ent : Entity_Id;
begin
Check_No_Identifiers;
@@ -12305,6 +12333,12 @@
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
+ Ent := Defining_Unit_Name (Specification (P));
+
+ if Nkind (Ent) = N_Defining_Program_Unit_Name then
+ Ent := Defining_Identifier (Ent);
+ end if;
+
Arg := Get_Pragma_Arg (Arg1);
Analyze_And_Resolve (Arg, Standard_Integer);
@@ -12356,6 +12390,7 @@
elsif Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
Arg := Get_Pragma_Arg (Arg1);
+ Ent := Defining_Identifier (Parent (P));
-- The expression must be analyzed in the special manner
-- described in "Handling of Default and Per-Object
@@ -12373,16 +12408,12 @@
Pragma_Misplaced;
end if;
- if Has_Pragma_Priority (P) then
- Error_Pragma ("duplicate pragma% not allowed");
- else
- Set_Has_Pragma_Priority (P, True);
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
- if Nkind_In (P, N_Protected_Definition, N_Task_Definition) then
- Record_Rep_Item (Defining_Identifier (Parent (P)), N);
- -- exp_ch9 should use this ???
- end if;
- end if;
+ Check_Duplicate_Pragma (Ent);
+
+ Record_Rep_Item (Ent, N);
end Priority;
-----------------------------------
@@ -12968,26 +12999,24 @@
if Nkind (P) = N_Subprogram_Body then
Check_In_Main_Program;
- -- Tasks
+ -- Only Task and subprogram cases allowed
- elsif Nkind (P) = N_Task_Definition then
- null;
-
- -- Anything else is incorrect
-
- else
+ elsif Nkind (P) /= N_Task_Definition then
Pragma_Misplaced;
end if;
+ -- Check duplicate pragma before we set the corresponding flag
+
if Has_Relative_Deadline_Pragma (P) then
Error_Pragma ("duplicate pragma% not allowed");
- else
- Set_Has_Relative_Deadline_Pragma (P, True);
+ end if;
- if Nkind (P) = N_Task_Definition then
- Record_Rep_Item (Defining_Identifier (Parent (P)), N);
- end if;
- end if;
+ -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
+ -- Relative_Deadline pragma node cannot be inserted in the Rep
+ -- Item chain of Ent since it is rewritten by the expander as a
+ -- procedure call statement that will break the chain.
+
+ Set_Has_Relative_Deadline_Pragma (P, True);
end Relative_Deadline;
------------------------
@@ -13458,7 +13487,6 @@
end if;
Record_Rep_Item (Defining_Identifier (Parent (P)), N);
- -- ??? exp_ch9 should use this!
end if;
end Storage_Size;
@@ -13877,7 +13905,8 @@
-- pragma Task_Info (EXPRESSION);
when Pragma_Task_Info => Task_Info : declare
- P : constant Node_Id := Parent (N);
+ P : constant Node_Id := Parent (N);
+ Ent : Entity_Id;
begin
GNAT_Pragma;
@@ -13896,11 +13925,13 @@
return;
end if;
- if Has_Task_Info_Pragma (P) then
- Error_Pragma ("duplicate pragma% not allowed");
- else
- Set_Has_Task_Info_Pragma (P, True);
- end if;
+ Ent := Defining_Identifier (Parent (P));
+
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
+
+ Check_Duplicate_Pragma (Ent);
+ Record_Rep_Item (Ent, N);
end Task_Info;
---------------
@@ -13912,6 +13943,7 @@
when Pragma_Task_Name => Task_Name : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
+ Ent : Entity_Id;
begin
Check_No_Identifiers;
@@ -13930,12 +13962,13 @@
Pragma_Misplaced;
end if;
- if Has_Task_Name_Pragma (P) then
- Error_Pragma ("duplicate pragma% not allowed");
- else
- Set_Has_Task_Name_Pragma (P, True);
- Record_Rep_Item (Defining_Identifier (Parent (P)), N);
- end if;
+ Ent := Defining_Identifier (Parent (P));
+
+ -- Check duplicate pragma before we chain the pragma in the Rep
+ -- Item chain of Ent.
+
+ Check_Duplicate_Pragma (Ent);
+ Record_Rep_Item (Ent, N);
end Task_Name;
------------------
@@ -14143,6 +14176,7 @@
Check_Arg_Is_Local_Name (Arg1);
Find_Type (Type_Id);
+
Typ := Entity (Type_Id);
if Typ = Any_Type
@@ -14287,6 +14321,7 @@
end if;
Set_Universal_Aliasing (Implementation_Base_Type (E_Id));
+ Record_Rep_Item (E_Id, N);
end Universal_Alias;
--------------------
===================================================================
@@ -49,6 +49,7 @@
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch9; use Sem_Ch9;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
@@ -1323,6 +1324,11 @@
-- for a description of how we handle aspect visibility).
elsif Has_Delayed_Aspects (E) then
+ -- Retrieve the visibility to the discriminants in order to
+ -- analyze properly the aspects.
+
+ Push_Scope_And_Install_Discriminants (E);
+
declare
Ritem : Node_Id;
@@ -1339,6 +1345,8 @@
Ritem := Next_Rep_Item (Ritem);
end loop;
end;
+
+ Uninstall_Discriminants_And_Pop_Scope (E);
end if;
-- If an incomplete type is still not frozen, this may be a
@@ -1536,6 +1544,10 @@
procedure Add_To_Result (N : Node_Id);
-- N is a freezing action to be appended to the Result
+ function After_Last_Declaration return Boolean;
+ -- If Loc is a freeze_entity that appears after the last declaration
+ -- in the scope, inhibit error messages on late completion.
+
procedure Check_Current_Instance (Comp_Decl : Node_Id);
-- Check that an Access or Unchecked_Access attribute with a prefix
-- which is the current instance type can only be applied when the type
@@ -1546,10 +1558,6 @@
-- integer literal without an explicit corresponding size clause. The
-- caller has checked that Utype is a modular integer type.
- function After_Last_Declaration return Boolean;
- -- If Loc is a freeze_entity that appears after the last declaration
- -- in the scope, inhibit error messages on late completion.
-
procedure Freeze_Record_Type (Rec : Entity_Id);
-- Freeze each component, handle some representation clauses, and freeze
-- primitive operations if this is a tagged type.
@@ -2513,39 +2521,15 @@
end;
end if;
- -- Deal with delayed aspect specifications. The analysis of the aspect
- -- is required to be delayed to the freeze point, so we evaluate the
- -- pragma or attribute definition clause in the tree at this point.
+ -- Deal with delayed aspect specifications. The analysis of the
+ -- aspect is required to be delayed to the freeze point, so we
+ -- evaluate the pragma or attribute definition clause in the tree at
+ -- this point. We also analyze the aspect specification node at the
+ -- freeze point when the aspect doesn't correspond to
+ -- pragma/attribute definition clause.
if Has_Delayed_Aspects (E) then
- declare
- Ritem : Node_Id;
- Aitem : Node_Id;
-
- begin
- -- Look for aspect specification entries for this entity
-
- Ritem := First_Rep_Item (E);
- while Present (Ritem) loop
- if Nkind (Ritem) = N_Aspect_Specification
- and then Entity (Ritem) = E
- and then Is_Delayed_Aspect (Ritem)
- and then Scope (E) = Current_Scope
- then
- Aitem := Aspect_Rep_Item (Ritem);
-
- -- Skip if this is an aspect with no corresponding pragma
- -- or attribute definition node (such as Default_Value).
-
- if Present (Aitem) then
- Set_Parent (Aitem, Ritem);
- Analyze (Aitem);
- end if;
- end if;
-
- Next_Rep_Item (Ritem);
- end loop;
- end;
+ Evaluate_Aspects_At_Freeze_Point (E);
end if;
-- Here to freeze the entity
@@ -2555,7 +2539,6 @@
-- Case of entity being frozen is other than a type
if not Is_Type (E) then
-
-- If entity is exported or imported and does not have an external
-- name, now is the time to provide the appropriate default name.
-- Skip this if the entity is stubbed, since we don't need a name
===================================================================
@@ -2259,10 +2259,35 @@
end if;
if Wmsg then
+ -- Check whether the context is an Init_Proc
+
if Inside_Init_Proc then
- Error_Msg_NEL
- ("\?& will be raised for objects of this type",
- N, Standard_Constraint_Error, Eloc);
+ declare
+ Conc_Typ : constant Entity_Id :=
+ Corresponding_Concurrent_Type
+ (Entity (Parameter_Type (First
+ (Parameter_Specifications
+ (Parent (Current_Scope))))));
+
+ begin
+ -- Don't complain if the corresponding concurrent type
+ -- doesn't come from source (i.e. a single task/protected
+ -- object).
+
+ if Present (Conc_Typ)
+ and then not Comes_From_Source (Conc_Typ)
+ then
+ Error_Msg_NEL
+ ("\?& will be raised at run time",
+ N, Standard_Constraint_Error, Eloc);
+
+ else
+ Error_Msg_NEL
+ ("\?& will be raised for objects of this type",
+ N, Standard_Constraint_Error, Eloc);
+ end if;
+ end;
+
else
Error_Msg_NEL
("\?& will be raised at run time",
===================================================================
@@ -2215,6 +2215,14 @@
Attribute_Variable_Indexing =>
Error_Msg_N ("illegal attribute", N);
+ -- Attributes related to Ada 2012 aspects. Attribute definition clause
+ -- exists for these, but they cannot be queried.
+
+ when Attribute_CPU |
+ Attribute_Dispatching_Domain |
+ Attribute_Interrupt_Priority =>
+ Error_Msg_N ("illegal attribute", N);
+
------------------
-- Abort_Signal --
------------------
@@ -6286,12 +6294,18 @@
-- Attributes related to Ada 2012 iterators (placeholder ???)
- when Attribute_Constant_Indexing => null;
- when Attribute_Default_Iterator => null;
- when Attribute_Implicit_Dereference => null;
- when Attribute_Iterator_Element => null;
- when Attribute_Variable_Indexing => null;
+ when Attribute_Constant_Indexing |
+ Attribute_Default_Iterator |
+ Attribute_Implicit_Dereference |
+ Attribute_Iterator_Element |
+ Attribute_Variable_Indexing => null;
+ -- Atributes related to Ada 2012 aspects
+
+ when Attribute_CPU |
+ Attribute_Dispatching_Domain |
+ Attribute_Interrupt_Priority => null;
+
--------------
-- Adjacent --
--------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -165,15 +165,31 @@
-- If the type is a task type, then assign the value of the
-- storage size to the Size variable associated with the task.
- -- task_typeZ := expression
+ -- Insert the assignment right after the declaration of the Size
+ -- variable.
+ -- Generate:
+
+ -- task_typeZ := expression
+
if Ekind (Ent) = E_Task_Type then
- Insert_Action (N,
- Make_Assignment_Statement (Loc,
- Name => New_Reference_To (Storage_Size_Variable (Ent), Loc),
- Expression =>
- Convert_To (RTE (RE_Size_Type), Expression (N))));
+ declare
+ Assign : Node_Id;
+ begin
+ Assign :=
+ Make_Assignment_Statement (Loc,
+ Name =>
+ New_Reference_To (Storage_Size_Variable (Ent), Loc),
+ Expression =>
+ Convert_To (RTE (RE_Size_Type), Expression (N)));
+
+ Insert_After
+ (Parent (Storage_Size_Variable (Entity (N))), Assign);
+
+ Analyze (Assign);
+ end;
+
-- For Storage_Size for an access type, create a variable to hold
-- the value of the specified size with name typeV and expand an
-- assignment statement to initialize this value.
===================================================================
@@ -209,10 +209,16 @@
begin
if N = Name_AST_Entry then
return Pragma_AST_Entry;
+ elsif N = Name_CPU then
+ return Pragma_CPU;
+ elsif N = Name_Dispatching_Domain then
+ return Pragma_Dispatching_Domain;
elsif N = Name_Fast_Math then
return Pragma_Fast_Math;
elsif N = Name_Interface then
return Pragma_Interface;
+ elsif N = Name_Interrupt_Priority then
+ return Pragma_Interrupt_Priority;
elsif N = Name_Priority then
return Pragma_Priority;
elsif N = Name_Relative_Deadline then
@@ -410,8 +416,11 @@
begin
return N in First_Pragma_Name .. Last_Pragma_Name
or else N = Name_AST_Entry
+ or else N = Name_CPU
+ or else N = Name_Dispatching_Domain
or else N = Name_Fast_Math
or else N = Name_Interface
+ or else N = Name_Interrupt_Priority
or else N = Name_Relative_Deadline
or else N = Name_Priority
or else N = Name_Storage_Size
===================================================================
@@ -46,6 +46,7 @@
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch9; use Sem_Ch9;
with Sem_Dim; use Sem_Dim;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
@@ -693,27 +694,28 @@
L : constant List_Id := Aspect_Specifications (N);
Ins_Node : Node_Id := N;
- -- Insert pragmas (except Pre/Post/Invariant/Predicate) after this node
+ -- Insert pragmas/attribute definition clause after this node when no
+ -- delayed analysis is required.
-- The general processing involves building an attribute definition
- -- clause or a pragma node that corresponds to the aspect. Then one
- -- of two things happens:
+ -- clause or a pragma node that corresponds to the aspect. Then in order
+ -- to delay the evaluation of this aspect to the freeze point, we attach
+ -- the corresponding pragma/attribute definition clause to the aspect
+ -- specification node, which is then placed in the Rep Item chain. In
+ -- this case we mark the entity by setting the flag Has_Delayed_Aspects
+ -- and we evaluate the rep item at the freeze point. When the aspect
+ -- doesn't have a corresponding pragma/attribute definition clause, then
+ -- its analysis is simply delayed at the freeze point.
- -- If we are required to delay the evaluation of this aspect to the
- -- freeze point, we attach the corresponding pragma/attribute definition
- -- clause to the aspect specification node, which is then placed in the
- -- Rep Item chain. In this case we mark the entity by setting the flag
- -- Has_Delayed_Aspects and we evaluate the rep item at the freeze point.
+ -- Some special cases don't require delay analysis, thus the aspect is
+ -- analyzed right now.
- -- If no delay is required, we just insert the pragma or attribute
- -- after the declaration, and it will get processed by the normal
- -- circuit. The From_Aspect_Specification flag is set on the pragma
- -- or attribute definition node in either case to activate special
- -- processing (e.g. not traversing the list of homonyms for inline).
+ -- Note that there is a special handling for
+ -- Pre/Post/Test_Case/Contract_Case aspects. In this case, we do not
+ -- have to worry about delay issues, since the pragmas themselves deal
+ -- with delay of visibility for the expression analysis. Thus, we just
+ -- insert the pragma after the node N.
- Delay_Required : Boolean := False;
- -- Set True if delay is required
-
begin
pragma Assert (Present (L));
@@ -722,82 +724,98 @@
Aspect := First (L);
Aspect_Loop : while Present (Aspect) loop
declare
+ Expr : constant Node_Id := Expression (Aspect);
+ Id : constant Node_Id := Identifier (Aspect);
Loc : constant Source_Ptr := Sloc (Aspect);
- Id : constant Node_Id := Identifier (Aspect);
- Expr : constant Node_Id := Expression (Aspect);
Nam : constant Name_Id := Chars (Id);
A_Id : constant Aspect_Id := Get_Aspect_Id (Nam);
Anod : Node_Id;
+ Delay_Required : Boolean := True;
+ -- Set False if delay is not required
+
Eloc : Source_Ptr := No_Location;
-- Source location of expression, modified when we split PPC's. It
-- is set below when Expr is present.
- procedure Check_False_Aspect_For_Derived_Type;
- -- This procedure checks for the case of a false aspect for a
- -- derived type, which improperly tries to cancel an aspect
- -- inherited from the parent;
+ procedure Analyze_Aspect_External_Or_Link_Name;
+ -- This routine performs the analysis of the External_Name or
+ -- Link_Name aspects.
- -----------------------------------------
- -- Check_False_Aspect_For_Derived_Type --
- -----------------------------------------
+ procedure Analyze_Aspect_Implicit_Dereference;
+ -- This routine performs the analysis of the Implicit_Dereference
+ -- aspects.
- procedure Check_False_Aspect_For_Derived_Type is
+ ------------------------------------------
+ -- Analyze_Aspect_External_Or_Link_Name --
+ ------------------------------------------
+
+ procedure Analyze_Aspect_External_Or_Link_Name is
begin
- -- We are only checking derived types
+ -- Verify that there is an Import/Export aspect defined for the
+ -- entity. The processing of that aspect in turn checks that
+ -- there is a Convention aspect declared. The pragma is
+ -- constructed when processing the Convention aspect.
- if not Is_Derived_Type (E) then
- return;
- end if;
+ declare
+ A : Node_Id;
- case A_Id is
- when Aspect_Atomic | Aspect_Shared =>
- if not Is_Atomic (E) then
- return;
- end if;
+ begin
+ A := First (L);
- when Aspect_Atomic_Components =>
- if not Has_Atomic_Components (E) then
- return;
- end if;
+ while Present (A) loop
+ exit when Chars (Identifier (A)) = Name_Export
+ or else Chars (Identifier (A)) = Name_Import;
+ Next (A);
+ end loop;
- when Aspect_Discard_Names =>
- if not Discard_Names (E) then
- return;
- end if;
+ if No (A) then
+ Error_Msg_N
+ ("Missing Import/Export for Link/External name",
+ Aspect);
+ end if;
+ end;
+ end Analyze_Aspect_External_Or_Link_Name;
- when Aspect_Pack =>
- if not Is_Packed (E) then
- return;
- end if;
+ -----------------------------------------
+ -- Analyze_Aspect_Implicit_Dereference --
+ -----------------------------------------
- when Aspect_Unchecked_Union =>
- if not Is_Unchecked_Union (E) then
- return;
- end if;
+ procedure Analyze_Aspect_Implicit_Dereference is
+ begin
+ if not Is_Type (E)
+ or else not Has_Discriminants (E)
+ then
+ Error_Msg_N
+ ("Aspect must apply to a type with discriminants", N);
- when Aspect_Volatile =>
- if not Is_Volatile (E) then
- return;
- end if;
+ else
+ declare
+ Disc : Entity_Id;
- when Aspect_Volatile_Components =>
- if not Has_Volatile_Components (E) then
- return;
- end if;
+ begin
+ Disc := First_Discriminant (E);
- when others =>
- return;
- end case;
+ while Present (Disc) loop
+ if Chars (Expr) = Chars (Disc)
+ and then Ekind (Etype (Disc)) =
+ E_Anonymous_Access_Type
+ then
+ Set_Has_Implicit_Dereference (E);
+ Set_Has_Implicit_Dereference (Disc);
+ return;
+ end if;
- -- Fall through means we are canceling an inherited aspect
+ Next_Discriminant (Disc);
+ end loop;
- Error_Msg_Name_1 := Nam;
- Error_Msg_NE
- ("derived type& inherits aspect%, cannot cancel", Expr, E);
- end Check_False_Aspect_For_Derived_Type;
+ -- Error if no proper access discriminant.
- -- Start of processing for Aspect_Loop
+ Error_Msg_NE
+ ("not an access discriminant of&", Expr, E);
+ end;
+ end if;
+ end Analyze_Aspect_Implicit_Dereference;
begin
-- Skip aspect if already analyzed (not clear if this is needed)
@@ -926,199 +944,25 @@
when No_Aspect =>
raise Program_Error;
- -- Aspects taking an optional boolean argument
+ -- Case 1: Aspects corresponding to attribute definition
+ -- clauses.
- when Boolean_Aspects =>
- Set_Is_Boolean_Aspect (Aspect);
-
- -- Special treatment for Aspect_Lock_Free since it is the
- -- only Boolean_Aspect that doesn't correspond to a pragma.
-
- if A_Id = Aspect_Lock_Free then
- if Ekind (E) /= E_Protected_Type then
- Error_Msg_N
- ("aspect % only applies to protected objects",
- Aspect);
- end if;
-
- -- Set the Uses_Lock_Free flag to True if there is no
- -- expression or if the expression is True.
-
- if No (Expr) or else Is_True (Static_Boolean (Expr)) then
- Set_Uses_Lock_Free (E);
- end if;
-
- goto Continue;
-
- -- For Import/Export, Verify that there is an aspect
- -- Convention that will incorporate the Import/Export
- -- aspect, and eventual Link/External names.
-
- elsif A_Id = Aspect_Import or else A_Id = Aspect_Export then
- declare
- A : Node_Id;
-
- begin
- A := First (L);
- while Present (A) loop
- exit when Chars (Identifier (A)) = Name_Convention;
- Next (A);
- end loop;
-
- if No (A) then
- Error_Msg_N
- ("missing Convention aspect for Export/Import",
- Aspect);
- end if;
- end;
-
- goto Continue;
- end if;
-
- -- For all other aspects we just create a matching pragma
- -- and insert it, if the expression is missing or set to
- -- True. If the expression is False, we can ignore the
- -- aspect with the exception that in the case of a derived
- -- type, we must check for an illegal attempt to cancel an
- -- inherited aspect.
-
- if Present (Expr)
- and then Is_False (Static_Boolean (Expr))
- then
- Check_False_Aspect_For_Derived_Type;
- goto Continue;
- end if;
-
- -- If True, build corresponding pragma node
-
- Aitem :=
- Make_Pragma (Loc,
- Pragma_Argument_Associations => New_List (Ent),
- Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Chars (Id)));
-
- -- Never need to delay for boolean aspects
-
- pragma Assert (not Delay_Required);
-
- -- Library unit aspects. These are boolean aspects, but we
- -- have to do special things with the insertion, since the
- -- pragma belongs inside the declarations of a package.
-
- when Library_Unit_Aspects =>
- if Present (Expr)
- and then Is_False (Static_Boolean (Expr))
- then
- goto Continue;
- end if;
-
- -- Build corresponding pragma node
-
- Aitem :=
- Make_Pragma (Loc,
- Pragma_Argument_Associations => New_List (Ent),
- Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Chars (Id)));
-
- -- This requires special handling in the case of a package
- -- declaration, the pragma needs to be inserted in the list
- -- of declarations for the associated package. There is no
- -- issue of visibility delay for these aspects.
-
- if Nkind (N) = N_Package_Declaration then
- if Nkind (Parent (N)) /= N_Compilation_Unit then
- Error_Msg_N
- ("incorrect context for library unit aspect&", Id);
- else
- Prepend
- (Aitem, Visible_Declarations (Specification (N)));
- end if;
-
- goto Continue;
- end if;
-
- -- If not package declaration, no delay is required
-
- pragma Assert (not Delay_Required);
-
- -- Aspects related to container iterators. These aspects denote
- -- subprograms, and thus must be delayed.
-
- when Aspect_Constant_Indexing |
- Aspect_Variable_Indexing =>
-
- if not Is_Type (E) or else not Is_Tagged_Type (E) then
- Error_Msg_N ("indexing applies to a tagged type", N);
- end if;
-
- Aitem :=
- Make_Attribute_Definition_Clause (Loc,
- Name => Ent,
- Chars => Chars (Id),
- Expression => Relocate_Node (Expr));
-
- Delay_Required := True;
- Set_Is_Delayed_Aspect (Aspect);
-
- when Aspect_Default_Iterator |
- Aspect_Iterator_Element =>
-
- Aitem :=
- Make_Attribute_Definition_Clause (Loc,
- Name => Ent,
- Chars => Chars (Id),
- Expression => Relocate_Node (Expr));
-
- Delay_Required := True;
- Set_Is_Delayed_Aspect (Aspect);
-
- when Aspect_Implicit_Dereference =>
- if not Is_Type (E)
- or else not Has_Discriminants (E)
- then
- Error_Msg_N
- ("Aspect must apply to a type with discriminants", N);
- goto Continue;
-
- else
- declare
- Disc : Entity_Id;
-
- begin
- Disc := First_Discriminant (E);
- while Present (Disc) loop
- if Chars (Expr) = Chars (Disc)
- and then Ekind (Etype (Disc)) =
- E_Anonymous_Access_Type
- then
- Set_Has_Implicit_Dereference (E);
- Set_Has_Implicit_Dereference (Disc);
- goto Continue;
- end if;
-
- Next_Discriminant (Disc);
- end loop;
-
- -- Error if no proper access discriminant.
-
- Error_Msg_NE
- ("not an access discriminant of&", Expr, E);
- end;
-
- goto Continue;
- end if;
-
- -- Aspects corresponding to attribute definition clauses
-
when Aspect_Address |
Aspect_Alignment |
Aspect_Bit_Order |
Aspect_Component_Size |
+ Aspect_Constant_Indexing |
+ Aspect_CPU |
+ Aspect_Default_Iterator |
+ Aspect_Dispatching_Domain |
Aspect_External_Tag |
Aspect_Input |
+ Aspect_Interrupt_Priority |
+ Aspect_Iterator_Element |
Aspect_Machine_Radix |
Aspect_Object_Size |
Aspect_Output |
+ Aspect_Priority |
Aspect_Read |
Aspect_Scalar_Storage_Order |
Aspect_Size |
@@ -1128,8 +972,20 @@
Aspect_Storage_Size |
Aspect_Stream_Size |
Aspect_Value_Size |
+ Aspect_Variable_Indexing |
Aspect_Write =>
+ -- Indexing aspects apply only to tagged type
+
+ if (A_Id = Aspect_Constant_Indexing
+ or else A_Id = Aspect_Variable_Indexing)
+ and then not (Is_Type (E)
+ and then Is_Tagged_Type (E))
+ then
+ Error_Msg_N ("indexing applies to a tagged type", N);
+ goto Continue;
+ end if;
+
-- Construct the attribute definition clause
Aitem :=
@@ -1138,23 +994,13 @@
Chars => Chars (Id),
Expression => Relocate_Node (Expr));
- -- A delay is required except in the common case where
- -- the expression is a literal, in which case it is fine
- -- to take care of it right away.
+ -- Case 2: Aspects cooresponding to pragmas
- if Nkind_In (Expr, N_Integer_Literal, N_String_Literal) then
- pragma Assert (not Delay_Required);
- null;
- else
- Delay_Required := True;
- Set_Is_Delayed_Aspect (Aspect);
- end if;
+ -- Case 2a: Aspects corresponding to pragmas with two
+ -- arguments, where the first argument is a local name
+ -- referring to the entity, and the second argument is the
+ -- aspect definition expression.
- -- Aspects corresponding to pragmas with two arguments, where
- -- the first argument is a local name referring to the entity,
- -- and the second argument is the aspect definition expression
- -- which is an expression that does not get analyzed.
-
when Aspect_Suppress |
Aspect_Unsuppress =>
@@ -1168,11 +1014,6 @@
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Chars (Id)));
- -- We don't have to play the delay game here, since the only
- -- values are check names which don't get analyzed anyway.
-
- pragma Assert (not Delay_Required);
-
when Aspect_Synchronization =>
-- The aspect corresponds to pragma Implemented.
@@ -1186,12 +1027,54 @@
Pragma_Identifier =>
Make_Identifier (Sloc (Id), Name_Implemented));
- pragma Assert (not Delay_Required);
+ -- No delay is required since the only values are: By_Entry
+ -- | By_Protected_Procedure | By_Any | Optional which don't
+ -- get analyzed anyway.
- -- Aspects corresponding to pragmas with two arguments, where
- -- the second argument is a local name referring to the entity,
- -- and the first argument is the aspect definition expression.
+ Delay_Required := False;
+ when Aspect_Attach_Handler =>
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Name_Attach_Handler),
+ Pragma_Argument_Associations =>
+ New_List (Ent, Relocate_Node (Expr)));
+
+ when Aspect_Dynamic_Predicate |
+ Aspect_Predicate |
+ Aspect_Static_Predicate =>
+
+ -- Construct the pragma (always a pragma Predicate, with
+ -- flags recording whether it is static/dynamic).
+
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations =>
+ New_List (Ent, Relocate_Node (Expr)),
+ Class_Present => Class_Present (Aspect),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Name_Predicate));
+
+ -- If the type is private, indicate that its completion
+ -- has a freeze node, because that is the one that will be
+ -- visible at freeze time.
+
+ Set_Has_Predicates (E);
+
+ if Is_Private_Type (E)
+ and then Present (Full_View (E))
+ then
+ Set_Has_Predicates (Full_View (E));
+ Set_Has_Delayed_Aspects (Full_View (E));
+ Ensure_Freeze_Node (Full_View (E));
+ end if;
+
+ -- Case 2b: Aspects corresponding to pragmas with two
+ -- arguments, where the second argument is a local name
+ -- referring to the entity, and the first argument is the
+ -- aspect definition expression.
+
when Aspect_Convention =>
-- The aspect may be part of the specification of an import
@@ -1215,56 +1098,36 @@
L_Assoc := Empty;
E_Assoc := Empty;
- -- Loop to look for Import/Export/Link_Name/External_Name
-
A := First (L);
while Present (A) loop
A_Name := Chars (Identifier (A));
- -- Import/Export
-
if A_Name = Name_Import
- or else
- A_Name = Name_Export
+ or else A_Name = Name_Export
then
- -- Forbid duplicates, at most one can appear
-
if Found then
- Error_Msg_Name_1 := A_Name;
- Error_Msg_Name_2 := P_Name;
- Error_Msg_N
- ("% aspect conflicts with previous % aspect",
- A);
+ Error_Msg_N ("conflicting", A);
else
Found := True;
end if;
- -- Record name of pragma to generate
-
P_Name := A_Name;
- -- Capture Link_Name
-
elsif A_Name = Name_Link_Name then
L_Assoc := Make_Pragma_Argument_Association (Loc,
- Chars => A_Name,
+ Chars => A_Name,
Expression => Relocate_Node (Expression (A)));
- -- Capture External_Name
-
elsif A_Name = Name_External_Name then
E_Assoc := Make_Pragma_Argument_Association (Loc,
- Chars => A_Name,
+ Chars => A_Name,
Expression => Relocate_Node (Expression (A)));
end if;
Next (A);
end loop;
- -- Construct pragma
-
Arg_List := New_List (Relocate_Node (Expr), Ent);
-
if Present (L_Assoc) then
Append_To (Arg_List, L_Assoc);
end if;
@@ -1296,103 +1159,89 @@
-- We don't have to play the delay game here, since the only
-- values are ON/OFF which don't get analyzed anyway.
- pragma Assert (not Delay_Required);
+ Delay_Required := False;
- -- Default_Value and Default_Component_Value aspects. These
- -- are specially handled because they have no corresponding
- -- pragmas or attributes.
+ -- Case 2c: Aspects corresponding to pragmas with three
+ -- arguments.
- when Aspect_Default_Value | Aspect_Default_Component_Value =>
- Error_Msg_Name_1 := Chars (Id);
+ -- Invariant aspects have a first argument that references the
+ -- entity, a second argument that is the expression and a third
+ -- argument that is an appropriate message.
- if not Is_Type (E) then
- Error_Msg_N ("aspect% can only apply to a type", Id);
- goto Continue;
+ when Aspect_Invariant |
+ Aspect_Type_Invariant =>
- elsif not Is_First_Subtype (E) then
- Error_Msg_N ("aspect% cannot apply to subtype", Id);
- goto Continue;
+ -- Analysis of the pragma will verify placement legality:
+ -- an invariant must apply to a private type, or appear in
+ -- the private part of a spec and apply to a completion.
- elsif A_Id = Aspect_Default_Value
- and then not Is_Scalar_Type (E)
- then
- Error_Msg_N
- ("aspect% can only be applied to scalar type", Id);
- goto Continue;
+ -- Construct the pragma
- elsif A_Id = Aspect_Default_Component_Value then
- if not Is_Array_Type (E) then
- Error_Msg_N
- ("aspect% can only be applied to array type", Id);
- goto Continue;
- elsif not Is_Scalar_Type (Component_Type (E)) then
- Error_Msg_N
- ("aspect% requires scalar components", Id);
- goto Continue;
- end if;
- end if;
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations =>
+ New_List (Ent, Relocate_Node (Expr)),
+ Class_Present => Class_Present (Aspect),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Name_Invariant));
- Aitem := Empty;
- Delay_Required := True;
- Set_Is_Delayed_Aspect (Aspect);
- Set_Has_Default_Aspect (Base_Type (Entity (Ent)));
+ -- Add message unless exception messages are suppressed
- if Is_Scalar_Type (E) then
- Set_Default_Aspect_Value (Entity (Ent), Expr);
- else
- Set_Default_Aspect_Component_Value (Entity (Ent), Expr);
+ if not Opt.Exception_Locations_Suppressed then
+ Append_To (Pragma_Argument_Associations (Aitem),
+ Make_Pragma_Argument_Association (Eloc,
+ Chars => Name_Message,
+ Expression =>
+ Make_String_Literal (Eloc,
+ Strval => "failed invariant from "
+ & Build_Location_String (Eloc))));
end if;
- when Aspect_Attach_Handler =>
- Aitem :=
- Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Name_Attach_Handler),
- Pragma_Argument_Associations =>
- New_List (Ent, Relocate_Node (Expr)));
+ -- For Invariant case, insert immediately after the entity
+ -- declaration. We do not have to worry about delay issues
+ -- since the pragma processing takes care of this.
- Set_From_Aspect_Specification (Aitem, True);
- Set_Corresponding_Aspect (Aitem, Aspect);
+ Set_Is_Delayed_Aspect (Aspect);
+ Delay_Required := False;
- pragma Assert (not Delay_Required);
+ -- Case 3 : Aspects that don't correspond to pragma/attribute
+ -- definition clause.
- when Aspect_Priority |
- Aspect_Interrupt_Priority |
- Aspect_Dispatching_Domain |
- Aspect_CPU =>
- declare
- Pname : Name_Id;
+ -- Case 3a: The aspects listed below don't correspond to
+ -- pragmas/attributes but do require delayed analysis.
- begin
- if A_Id = Aspect_Priority then
- Pname := Name_Priority;
+ when Aspect_Default_Value |
+ Aspect_Default_Component_Value =>
+ Aitem := Empty;
- elsif A_Id = Aspect_Interrupt_Priority then
- Pname := Name_Interrupt_Priority;
+ -- Case 3b: The aspects listed below don't correspond to
+ -- pragmas/attributes and don't need delayed analysis.
- elsif A_Id = Aspect_CPU then
- Pname := Name_CPU;
+ -- For Implicit_Dereference, External_Name and Link_Name, only
+ -- the legality checks are done during the analysis, thus no
+ -- delay is required.
- else
- Pname := Name_Dispatching_Domain;
- end if;
+ when Aspect_Implicit_Dereference =>
+ Analyze_Aspect_Implicit_Dereference;
+ goto Continue;
- Aitem :=
- Make_Pragma (Loc,
- Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Pname),
- Pragma_Argument_Associations =>
- New_List
- (Make_Pragma_Argument_Association
- (Sloc => Sloc (Id),
- Expression => Relocate_Node (Expr))));
+ when Aspect_External_Name |
+ Aspect_Link_Name =>
+ Analyze_Aspect_External_Or_Link_Name;
+ goto Continue;
- Set_From_Aspect_Specification (Aitem, True);
- Set_Corresponding_Aspect (Aitem, Aspect);
+ when Aspect_Dimension =>
+ Analyze_Aspect_Dimension (N, Id, Expr);
+ goto Continue;
- pragma Assert (not Delay_Required);
- end;
+ when Aspect_Dimension_System =>
+ Analyze_Aspect_Dimension_System (N, Id, Expr);
+ goto Continue;
+ -- Case 4: Special handling for aspects
+ -- Pre/Post/Test_Case/Contract_Case whose corresponding pragmas
+ -- take care of the delay.
+
-- Aspects Pre/Post generate Precondition/Postcondition pragmas
-- with a first argument that is the expression, and a second
-- argument that is an informative message if the test fails.
@@ -1493,97 +1342,6 @@
goto Continue;
end;
- -- Invariant aspects generate a corresponding pragma with a
- -- first argument that is the entity, a second argument that is
- -- the expression and a third argument that is an appropriate
- -- message. This is inserted right after the declaration, to
- -- get the required pragma placement. The pragma processing
- -- takes care of the required delay.
-
- when Aspect_Invariant |
- Aspect_Type_Invariant =>
-
- -- Analysis of the pragma will verify placement legality:
- -- an invariant must apply to a private type, or appear in
- -- the private part of a spec and apply to a completion.
-
- -- Construct the pragma
-
- Aitem :=
- Make_Pragma (Loc,
- Pragma_Argument_Associations =>
- New_List (Ent, Relocate_Node (Expr)),
- Class_Present => Class_Present (Aspect),
- Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Name_Invariant));
-
- -- Add message unless exception messages are suppressed
-
- if not Opt.Exception_Locations_Suppressed then
- Append_To (Pragma_Argument_Associations (Aitem),
- Make_Pragma_Argument_Association (Eloc,
- Chars => Name_Message,
- Expression =>
- Make_String_Literal (Eloc,
- Strval => "failed invariant from "
- & Build_Location_String (Eloc))));
- end if;
-
- Set_From_Aspect_Specification (Aitem, True);
- Set_Corresponding_Aspect (Aitem, Aspect);
- Set_Is_Delayed_Aspect (Aspect);
-
- -- For Invariant case, insert immediately after the entity
- -- declaration. We do not have to worry about delay issues
- -- since the pragma processing takes care of this.
-
- Insert_After (N, Aitem);
- goto Continue;
-
- -- Predicate aspects generate a corresponding pragma with a
- -- first argument that is the entity, and the second argument
- -- is the expression.
-
- when Aspect_Dynamic_Predicate |
- Aspect_Predicate |
- Aspect_Static_Predicate =>
-
- -- Construct the pragma (always a pragma Predicate, with
- -- flags recording whether it is static/dynamic).
-
- Aitem :=
- Make_Pragma (Loc,
- Pragma_Argument_Associations =>
- New_List (Ent, Relocate_Node (Expr)),
- Class_Present => Class_Present (Aspect),
- Pragma_Identifier =>
- Make_Identifier (Sloc (Id), Name_Predicate));
-
- Set_From_Aspect_Specification (Aitem, True);
- Set_Corresponding_Aspect (Aitem, Aspect);
-
- -- Make sure we have a freeze node (it might otherwise be
- -- missing in cases like subtype X is Y, and we would not
- -- have a place to build the predicate function).
-
- -- If the type is private, indicate that its completion
- -- has a freeze node, because that is the one that will be
- -- visible at freeze time.
-
- Set_Has_Predicates (E);
-
- if Is_Private_Type (E)
- and then Present (Full_View (E))
- then
- Set_Has_Predicates (Full_View (E));
- Set_Has_Delayed_Aspects (Full_View (E));
- Ensure_Freeze_Node (Full_View (E));
- end if;
-
- Ensure_Freeze_Node (E);
- Set_Is_Delayed_Aspect (Aspect);
- Delay_Required := True;
-
when Aspect_Contract_Case |
Aspect_Test_Case =>
declare
@@ -1655,188 +1413,195 @@
Pragma_Argument_Associations =>
Args);
- Set_From_Aspect_Specification (Aitem, True);
- Set_Corresponding_Aspect (Aitem, Aspect);
- Set_Is_Delayed_Aspect (Aspect);
+ Delay_Required := False;
+ end;
- -- Insert immediately after the entity declaration
+ -- Case 5: Special handling for aspects with an optional
+ -- boolean argument.
- Insert_After (N, Aitem);
+ -- In the general case, the corresponding pragma cannot be
+ -- generated yet because the evaluation of the boolean needs to
+ -- be delayed til the freeze point.
- goto Continue;
- end;
+ when Boolean_Aspects |
+ Library_Unit_Aspects =>
- when Aspect_Dimension =>
- Analyze_Aspect_Dimension (N, Id, Expr);
- goto Continue;
+ Set_Is_Boolean_Aspect (Aspect);
- when Aspect_Dimension_System =>
- Analyze_Aspect_Dimension_System (N, Id, Expr);
- goto Continue;
+ -- Lock_Free aspect only apply to protected objects
- when Aspect_External_Name |
- Aspect_Link_Name =>
+ if A_Id = Aspect_Lock_Free then
+ if Ekind (E) /= E_Protected_Type then
+ Error_Msg_N
+ ("aspect % only applies to a protected object",
+ Aspect);
- -- Verify that there is an Import/Export aspect defined for
- -- the entity. The processing of that aspect in turn checks
- -- that there is a Convention aspect declared. The pragma is
- -- constructed when processing the Convention aspect.
+ else
+ -- Set the Uses_Lock_Free flag to True if there is no
+ -- expression or if the expression is True. ??? The
+ -- evaluation of this aspect should be delayed to the
+ -- freeze point.
- declare
- A : Node_Id;
-
- begin
- A := First (L);
- while Present (A) loop
- exit when Chars (Identifier (A)) = Name_Export
- or else Chars (Identifier (A)) = Name_Import;
- Next (A);
- end loop;
-
- if No (A) then
- Error_Msg_N
- ("Missing Import/Export for Link/External name",
- Aspect);
+ if No (Expr)
+ or else Is_True (Static_Boolean (Expr))
+ then
+ Set_Uses_Lock_Free (E);
+ end if;
end if;
- end;
- goto Continue;
- end case;
+ goto Continue;
- -- If a delay is required, we delay the freeze (not much point in
- -- delaying the aspect if we don't delay the freeze!). The pragma
- -- or attribute clause if there is one is then attached to the
- -- aspect specification which is placed in the rep item list.
+ elsif A_Id = Aspect_Import
+ or else A_Id = Aspect_Export
+ then
- if Delay_Required then
- if Present (Aitem) then
- Set_From_Aspect_Specification (Aitem, True);
+ -- Verify that there is an aspect Convention that will
+ -- incorporate the Import/Export aspect, and eventual
+ -- Link/External names.
- if Nkind (Aitem) = N_Pragma then
- Set_Corresponding_Aspect (Aitem, Aspect);
- end if;
+ declare
+ A : Node_Id;
- Set_Is_Delayed_Aspect (Aitem);
- Set_Aspect_Rep_Item (Aspect, Aitem);
- end if;
+ begin
+ A := First (L);
+ while Present (A) loop
+ exit when Chars (Identifier (A)) = Name_Convention;
+ Next (A);
+ end loop;
- Ensure_Freeze_Node (E);
- Set_Has_Delayed_Aspects (E);
- Record_Rep_Item (E, Aspect);
+ if No (A) then
+ Error_Msg_N
+ ("missing Convention aspect for Export/Import",
+ Aspect);
+ end if;
+ end;
- -- If no delay required, insert the pragma/clause in the tree
+ goto Continue;
+ end if;
- else
- Set_From_Aspect_Specification (Aitem, True);
+ -- This requires special handling in the case of a package
+ -- declaration, the pragma needs to be inserted in the list
+ -- of declarations for the associated package. There is no
+ -- issue of visibility delay for these aspects.
- if Nkind (Aitem) = N_Pragma then
- Set_Corresponding_Aspect (Aitem, Aspect);
- end if;
+ if A_Id in Library_Unit_Aspects
+ and then Nkind (N) = N_Package_Declaration
+ and then Nkind (Parent (N)) /= N_Compilation_Unit
+ then
+ Error_Msg_N
+ ("incorrect context for library unit aspect&", Id);
+ goto Continue;
+ end if;
- -- If this is a compilation unit, we will put the pragma in
- -- the Pragmas_After list of the N_Compilation_Unit_Aux node.
+ -- Special handling when the aspect has no expression. In
+ -- this case the value is considered to be True. Thus, we
+ -- simply insert the pragma, no delay is required.
- if Nkind (Parent (Ins_Node)) = N_Compilation_Unit then
- declare
- Aux : constant Node_Id :=
- Aux_Decls_Node (Parent (Ins_Node));
+ if No (Expr) then
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (Ent),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Chars (Id)));
- begin
- pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux);
+ Delay_Required := False;
- if No (Pragmas_After (Aux)) then
- Set_Pragmas_After (Aux, Empty_List);
- end if;
+ -- In general cases, the corresponding pragma/attribute
+ -- definition clause will be inserted later at the freezing
+ -- point.
- -- For Pre_Post put at start of list, otherwise at end
+ else
+ Aitem := Empty;
+ end if;
+ end case;
- if A_Id in Pre_Post_Aspects then
- Prepend (Aitem, Pragmas_After (Aux));
- else
- Append (Aitem, Pragmas_After (Aux));
- end if;
- end;
+ -- Attach the corresponding pragma/attribute definition clause to
+ -- the aspect specification node.
- -- Here if not compilation unit case
+ if Present (Aitem) then
+ Set_From_Aspect_Specification (Aitem, True);
- else
- case A_Id is
+ if Nkind (Aitem) = N_Pragma then
+ Set_Corresponding_Aspect (Aitem, Aspect);
+ end if;
+ end if;
- -- For Pre/Post cases, insert immediately after the
- -- entity declaration, since that is the required pragma
- -- placement.
+ -- In the context of a compilation unit, we directly put the
+ -- pragma in the Pragmas_After list of the
+ -- N_Compilation_Unit_Aux node. No delay is required here.
- when Pre_Post_Aspects =>
- Insert_After (N, Aitem);
+ if Nkind (Parent (N)) = N_Compilation_Unit
+ and then (Present (Aitem) or else Is_Boolean_Aspect (Aspect))
+ then
+ declare
+ Aux : constant Node_Id := Aux_Decls_Node (Parent (N));
- -- For Priority aspects, insert into the task or
- -- protected definition, which we need to create if it's
- -- not there. The same applies to CPU and
- -- Dispatching_Domain but only to tasks.
+ begin
+ pragma Assert (Nkind (Aux) = N_Compilation_Unit_Aux);
- when Aspect_Priority |
- Aspect_Interrupt_Priority |
- Aspect_Dispatching_Domain |
- Aspect_CPU =>
- declare
- T : Node_Id; -- the type declaration
- L : List_Id; -- list of decls of task/protected
+ -- For a Boolean aspect, create the corresponding pragma if
+ -- no expression or if the value is True.
- begin
- if Nkind (N) = N_Object_Declaration then
- T := Parent (Etype (Defining_Identifier (N)));
- else
- T := N;
- end if;
+ if Is_Boolean_Aspect (Aspect)
+ and then No (Aitem)
+ then
+ if Is_True (Static_Boolean (Expr)) then
+ Aitem :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (Ent),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Id), Chars (Id)));
- if Nkind (T) = N_Protected_Type_Declaration
- and then A_Id /= Aspect_Dispatching_Domain
- and then A_Id /= Aspect_CPU
- then
- pragma Assert
- (Present (Protected_Definition (T)));
+ Set_From_Aspect_Specification (Aitem, True);
+ Set_Corresponding_Aspect (Aitem, Aspect);
- L := Visible_Declarations
- (Protected_Definition (T));
+ else
+ goto Continue;
+ end if;
+ end if;
- elsif Nkind (T) = N_Task_Type_Declaration then
- if No (Task_Definition (T)) then
- Set_Task_Definition
- (T,
- Make_Task_Definition
- (Sloc (T),
- Visible_Declarations => New_List,
- End_Label => Empty));
- end if;
+ if No (Pragmas_After (Aux)) then
+ Set_Pragmas_After (Aux, Empty_List);
+ end if;
- L := Visible_Declarations (Task_Definition (T));
+ Append (Aitem, Pragmas_After (Aux));
+ goto Continue;
+ end;
+ end if;
- else
- raise Program_Error;
- end if;
+ -- The evaluation of the aspect is delayed to the freezing point.
+ -- The pragma or attribute clause if there is one is then attached
+ -- to the aspect specification which is placed in the rep item
+ -- list.
- Prepend (Aitem, To => L);
+ if Delay_Required then
+ if Present (Aitem) then
+ Set_Is_Delayed_Aspect (Aitem);
+ Set_Aspect_Rep_Item (Aspect, Aitem);
+ Set_Parent (Aitem, Aspect);
+ end if;
- -- Analyze rewritten pragma. Otherwise, its
- -- analysis is done too late, after the task or
- -- protected object has been created.
+ Set_Is_Delayed_Aspect (Aspect);
+ Set_Has_Delayed_Aspects (E);
+ Record_Rep_Item (E, Aspect);
- Analyze (Aitem);
- end;
+ -- When delay is not required and the context is not a compilation
+ -- unit, we simply insert the pragma/attribute definition clause
+ -- in sequence.
- -- For all other cases, insert in sequence
-
- when others =>
- Insert_After (Ins_Node, Aitem);
- Ins_Node := Aitem;
- end case;
- end if;
+ else
+ Insert_After (Ins_Node, Aitem);
+ Ins_Node := Aitem;
end if;
end;
<<Continue>>
Next (Aspect);
end loop Aspect_Loop;
+
+ if Has_Delayed_Aspects (E) then
+ Ensure_Freeze_Node (E);
+ end if;
end Analyze_Aspect_Specifications;
-----------------------
@@ -2293,18 +2058,29 @@
return False;
end if;
- -- Otherwise current clause may duplicate previous clause or a
- -- previously given aspect specification for the same aspect.
+ -- Otherwise current clause may duplicate previous clause, or a
+ -- previously given pragma or aspect specification for the same
+ -- aspect.
A := Get_Rep_Item_For_Entity (U_Ent, Chars (N));
if Present (A) then
- if Entity (A) = U_Ent then
- Error_Msg_Name_1 := Chars (N);
- Error_Msg_Sloc := Sloc (A);
+ Error_Msg_Name_1 := Chars (N);
+ Error_Msg_Sloc := Sloc (A);
+
+ if Nkind (A) = N_Aspect_Specification
+ or else From_Aspect_Specification (A)
+ then
Error_Msg_NE ("aspect% for & previously given#", N, U_Ent);
- return True;
+
+ elsif Nkind (A) = N_Pragma then
+ Error_Msg_NE ("clause% for & duplicates pragma#", N, U_Ent);
+
+ else
+ Error_Msg_NE ("clause% for & duplicates clause#", N, U_Ent);
end if;
+
+ return True;
end if;
return False;
@@ -2436,9 +2212,13 @@
if Etype (Nam) = Any_Type then
return;
- -- Must be declared in current scope
+ -- Must be declared in current scope or in case of an aspect
+ -- specification, must be the current scope.
- elsif Scope (Ent) /= Current_Scope then
+ elsif Scope (Ent) /= Current_Scope
+ and then (not From_Aspect_Specification (N)
+ or else Ent /= Current_Scope)
+ then
Error_Msg_N ("entity must be declared in this scope", Nam);
return;
@@ -2963,6 +2743,44 @@
when Attribute_Constant_Indexing =>
Check_Indexing_Functions;
+ ---------
+ -- CPU --
+ ---------
+
+ when Attribute_CPU => CPU :
+ begin
+ -- CPU attribute definition clause not allowed except from aspect
+ -- specification.
+
+ if From_Aspect_Specification (N) then
+ if not Is_Task_Type (U_Ent) then
+ Error_Msg_N ("CPU can only be defined for task", Nam);
+
+ elsif Duplicate_Clause then
+ null;
+
+ else
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ -- The visibility to the discriminants must be restored
+
+ Push_Scope_And_Install_Discriminants (U_Ent);
+ Preanalyze_Spec_Expression (Expr, RTE (RE_CPU_Range));
+ Uninstall_Discriminants_And_Pop_Scope (U_Ent);
+
+ if not Is_Static_Expression (Expr) then
+ Check_Restriction (Static_Priorities, Expr);
+ end if;
+ end if;
+
+ else
+ Error_Msg_N
+ ("attribute& cannot be set with definition clause", N);
+ end if;
+ end CPU;
+
----------------------
-- Default_Iterator --
----------------------
@@ -2996,6 +2814,45 @@
end if;
end Default_Iterator;
+ ------------------------
+ -- Dispatching_Domain --
+ ------------------------
+
+ when Attribute_Dispatching_Domain => Dispatching_Domain :
+ begin
+ -- Dispatching_Domain attribute definition clause not allowed
+ -- except from aspect specification.
+
+ if From_Aspect_Specification (N) then
+ if not Is_Task_Type (U_Ent) then
+ Error_Msg_N ("Dispatching_Domain can only be defined" &
+ "for task",
+ Nam);
+
+ elsif Duplicate_Clause then
+ null;
+
+ else
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ -- The visibility to the discriminants must be restored
+
+ Push_Scope_And_Install_Discriminants (U_Ent);
+
+ Preanalyze_Spec_Expression
+ (Expr, RTE (RE_Dispatching_Domain));
+
+ Uninstall_Discriminants_And_Pop_Scope (U_Ent);
+ end if;
+
+ else
+ Error_Msg_N
+ ("attribute& cannot be set with definition clause", N);
+ end if;
+ end Dispatching_Domain;
+
------------------
-- External_Tag --
------------------
@@ -3055,6 +2912,48 @@
Analyze_Stream_TSS_Definition (TSS_Stream_Input);
Set_Has_Specified_Stream_Input (Ent);
+ ------------------------
+ -- Interrupt_Priority --
+ ------------------------
+
+ when Attribute_Interrupt_Priority => Interrupt_Priority :
+ begin
+ -- Interrupt_Priority attribute definition clause not allowed
+ -- except from aspect specification.
+
+ if From_Aspect_Specification (N) then
+ if not (Is_Protected_Type (U_Ent)
+ or else Is_Task_Type (U_Ent))
+ then
+ Error_Msg_N
+ ("Interrupt_Priority can only be defined for task" &
+ "and protected object",
+ Nam);
+
+ elsif Duplicate_Clause then
+ null;
+
+ else
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ -- The visibility to the discriminants must be restored
+
+ Push_Scope_And_Install_Discriminants (U_Ent);
+
+ Preanalyze_Spec_Expression
+ (Expr, RTE (RE_Interrupt_Priority));
+
+ Uninstall_Discriminants_And_Pop_Scope (U_Ent);
+ end if;
+
+ else
+ Error_Msg_N
+ ("attribute& cannot be set with definition clause", N);
+ end if;
+ end Interrupt_Priority;
+
----------------------
-- Iterator_Element --
----------------------
@@ -3147,6 +3046,49 @@
Analyze_Stream_TSS_Definition (TSS_Stream_Output);
Set_Has_Specified_Stream_Output (Ent);
+ --------------
+ -- Priority --
+ --------------
+
+ when Attribute_Priority => Priority :
+ begin
+ -- Priority attribute definition clause not allowed except from
+ -- aspect specification.
+
+ if From_Aspect_Specification (N) then
+ if not (Is_Protected_Type (U_Ent)
+ or else Is_Task_Type (U_Ent))
+ then
+ Error_Msg_N
+ ("Priority can only be defined for task and protected" &
+ "object",
+ Nam);
+
+ elsif Duplicate_Clause then
+ null;
+
+ else
+ -- The expression must be analyzed in the special manner
+ -- described in "Handling of Default and Per-Object
+ -- Expressions" in sem.ads.
+
+ -- The visibility to the discriminants must be restored
+
+ Push_Scope_And_Install_Discriminants (U_Ent);
+ Preanalyze_Spec_Expression (Expr, Standard_Integer);
+ Uninstall_Discriminants_And_Pop_Scope (U_Ent);
+
+ if not Is_Static_Expression (Expr) then
+ Check_Restriction (Static_Priorities, Expr);
+ end if;
+ end if;
+
+ else
+ Error_Msg_N
+ ("attribute& cannot be set with definition clause", N);
+ end if;
+ end Priority;
+
----------
-- Read --
----------
@@ -3508,7 +3450,6 @@
when Attribute_Storage_Size => Storage_Size : declare
Btype : constant Entity_Id := Base_Type (U_Ent);
- Sprag : Node_Id;
begin
if Is_Task_Type (U_Ent) then
@@ -3551,16 +3492,6 @@
then
Set_No_Pool_Assigned (Btype);
end if;
-
- else -- Is_Task_Type (U_Ent)
- Sprag := Get_Rep_Pragma (Btype, Name_Storage_Size);
-
- if Present (Sprag) then
- Error_Msg_Sloc := Sloc (Sprag);
- Error_Msg_N
- ("Storage_Size already specified#", Nam);
- return;
- end if;
end if;
Set_Has_Storage_Size_Clause (Btype);
@@ -4221,7 +4152,14 @@
-- the subtype name in the saved expression so that they will not cause
-- trouble in the preanalysis.
- if Has_Delayed_Aspects (E) then
+ if Has_Delayed_Aspects (E)
+ and then Scope (E) = Current_Scope
+ then
+ -- Retrieve the visibility to the discriminants in order to properly
+ -- analyze the aspects.
+
+ Push_Scope_And_Install_Discriminants (E);
+
declare
Ritem : Node_Id;
@@ -4233,7 +4171,6 @@
if Nkind (Ritem) = N_Aspect_Specification
and then Entity (Ritem) = E
and then Is_Delayed_Aspect (Ritem)
- and then Scope (E) = Current_Scope
then
Check_Aspect_At_Freeze_Point (Ritem);
end if;
@@ -4241,6 +4178,8 @@
Next_Rep_Item (Ritem);
end loop;
end;
+
+ Uninstall_Discriminants_And_Pop_Scope (E);
end if;
end Analyze_Freeze_Entity;
@@ -6185,18 +6124,17 @@
procedure Check_Aspect_At_End_Of_Declarations (ASN : Node_Id) is
Ent : constant Entity_Id := Entity (ASN);
Ident : constant Node_Id := Identifier (ASN);
+ A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
+ End_Decl_Expr : constant Node_Id := Entity (Ident);
+ -- Expression to be analyzed at end of declarations
+
Freeze_Expr : constant Node_Id := Expression (ASN);
-- Expression from call to Check_Aspect_At_Freeze_Point
- End_Decl_Expr : constant Node_Id := Entity (Ident);
- -- Expression to be analyzed at end of declarations
-
T : constant Entity_Id := Etype (Freeze_Expr);
-- Type required for preanalyze call
- A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
-
Err : Boolean;
-- Set False if error
@@ -6206,9 +6144,14 @@
-- preanalyzed just after the freeze point.
begin
+ -- Case of aspects Dimension, Dimension_System and Synchronization
+
+ if A_Id = Aspect_Synchronization then
+ return;
+
-- Case of stream attributes, just have to compare entities
- if A_Id = Aspect_Input or else
+ elsif A_Id = Aspect_Input or else
A_Id = Aspect_Output or else
A_Id = Aspect_Read or else
A_Id = Aspect_Write
@@ -6286,11 +6229,11 @@
Ident : constant Node_Id := Identifier (ASN);
-- Identifier (use Entity field to save expression)
- T : Entity_Id;
+ A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
+
+ T : Entity_Id := Empty;
-- Type required for preanalyze call
- A_Id : constant Aspect_Id := Get_Aspect_Id (Chars (Ident));
-
begin
-- On entry to this procedure, Entity (Ident) contains a copy of the
-- original expression from the aspect, saved for this purpose.
@@ -6312,34 +6255,17 @@
when No_Aspect =>
raise Program_Error;
- -- Library unit aspects should be impossible (never delayed)
+ -- Aspects taking an optional boolean argument.
- when Library_Unit_Aspects =>
- raise Program_Error;
+ when Boolean_Aspects |
+ Library_Unit_Aspects =>
+ T := Standard_Boolean;
- -- Aspects taking an optional boolean argument. Should be impossible
- -- since these are never delayed.
-
- when Boolean_Aspects =>
- raise Program_Error;
-
- -- Contract_Case aspects apply to subprograms, hence should never be
- -- delayed.
-
- when Aspect_Contract_Case =>
- raise Program_Error;
-
- -- Test_Case aspects apply to entries and subprograms, hence should
- -- never be delayed.
-
- when Aspect_Test_Case =>
- raise Program_Error;
-
when Aspect_Attach_Handler =>
T := RTE (RE_Interrupt_ID);
when Aspect_Convention =>
- null;
+ return;
-- Default_Value is resolved with the type entity in question
@@ -6400,13 +6326,19 @@
Aspect_Value_Size =>
T := Any_Integer;
- -- Stream attribute. Special case, the expression is just an entity
+ when Aspect_Synchronization =>
+ return;
+
+ -- Special case, the expression of these aspects is just an entity
-- that does not need any resolution, so just analyze.
- when Aspect_Input |
- Aspect_Output |
- Aspect_Read |
- Aspect_Write =>
+ when Aspect_Input |
+ Aspect_Output |
+ Aspect_Read |
+ Aspect_Suppress |
+ Aspect_Unsuppress |
+ Aspect_Warnings |
+ Aspect_Write =>
Analyze (Expression (ASN));
return;
@@ -6416,34 +6348,30 @@
when Aspect_Constant_Indexing |
Aspect_Default_Iterator |
Aspect_Iterator_Element |
- Aspect_Implicit_Dereference |
Aspect_Variable_Indexing =>
Analyze (Expression (ASN));
return;
- -- Suppress/Unsuppress/Synchronization/Warnings should not be delayed
+ -- Invariant/Predicate take boolean expressions
- when Aspect_Suppress |
- Aspect_Unsuppress |
- Aspect_Synchronization |
- Aspect_Warnings =>
- raise Program_Error;
-
- -- Pre/Post/Invariant/Predicate take boolean expressions
-
when Aspect_Dynamic_Predicate |
Aspect_Invariant |
- Aspect_Pre |
- Aspect_Precondition |
- Aspect_Post |
- Aspect_Postcondition |
Aspect_Predicate |
Aspect_Static_Predicate |
Aspect_Type_Invariant =>
T := Standard_Boolean;
- when Aspect_Dimension |
- Aspect_Dimension_System =>
+ -- Here is the list of aspects that don't require delay analysis.
+
+ when Aspect_Contract_Case |
+ Aspect_Dimension |
+ Aspect_Dimension_System |
+ Aspect_Implicit_Dereference |
+ Aspect_Post |
+ Aspect_Postcondition |
+ Aspect_Pre |
+ Aspect_Precondition |
+ Aspect_Test_Case =>
raise Program_Error;
end case;
@@ -7661,6 +7589,227 @@
end if;
end Check_Size;
+ --------------------------------------
+ -- Evaluate_Aspects_At_Freeze_Point --
+ --------------------------------------
+
+ procedure Evaluate_Aspects_At_Freeze_Point (E : Entity_Id) is
+ ASN : Node_Id;
+ A_Id : Aspect_Id;
+ Ritem : Node_Id;
+
+ procedure Analyze_Aspect_Default_Value (ASN : Node_Id);
+ -- This routine analyzes an Aspect_Default_Value or
+ -- Aspect_Default_Component_Value denoted by the aspect specification
+ -- node ASN.
+
+ procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id);
+ -- Given an aspect specification node ASN whose expression is an
+ -- optional Boolean, this routines creates the corresponding pragma at
+ -- the freezing point.
+
+ ----------------------------------
+ -- Analyze_Aspect_Default_Value --
+ ----------------------------------
+
+ procedure Analyze_Aspect_Default_Value (ASN : Node_Id) is
+ Ent : constant Entity_Id := Entity (ASN);
+ Expr : constant Node_Id := Expression (ASN);
+ Id : constant Node_Id := Identifier (ASN);
+
+ begin
+ Error_Msg_Name_1 := Chars (Id);
+
+ if not Is_Type (Ent) then
+ Error_Msg_N ("aspect% can only apply to a type", Id);
+ return;
+
+ elsif not Is_First_Subtype (Ent) then
+ Error_Msg_N ("aspect% cannot apply to subtype", Id);
+ return;
+
+ elsif A_Id = Aspect_Default_Value
+ and then not Is_Scalar_Type (Ent)
+ then
+ Error_Msg_N ("aspect% can only be applied to scalar type", Id);
+ return;
+
+ elsif A_Id = Aspect_Default_Component_Value then
+ if not Is_Array_Type (Ent) then
+ Error_Msg_N ("aspect% can only be applied to array type", Id);
+ return;
+
+ elsif not Is_Scalar_Type (Component_Type (Ent)) then
+ Error_Msg_N ("aspect% requires scalar components", Id);
+ return;
+ end if;
+ end if;
+
+ Set_Has_Default_Aspect (Base_Type (Ent));
+
+ if Is_Scalar_Type (Ent) then
+ Set_Default_Aspect_Value (Ent, Expr);
+ else
+ Set_Default_Aspect_Component_Value (Ent, Expr);
+ end if;
+ end Analyze_Aspect_Default_Value;
+
+ -------------------------------------
+ -- Make_Pragma_From_Boolean_Aspect --
+ -------------------------------------
+
+ procedure Make_Pragma_From_Boolean_Aspect (ASN : Node_Id) is
+ Ident : constant Node_Id := Identifier (ASN);
+ A_Name : constant Name_Id := Chars (Ident);
+ A_Id : constant Aspect_Id := Get_Aspect_Id (A_Name);
+ Ent : constant Entity_Id := Entity (ASN);
+ Expr : constant Node_Id := Expression (ASN);
+ Loc : constant Source_Ptr := Sloc (ASN);
+
+ Prag : Node_Id;
+
+ procedure Check_False_Aspect_For_Derived_Type;
+ -- This procedure checks for the case of a false aspect for a derived
+ -- type, which improperly tries to cancel an aspect inherited from
+ -- the parent.
+
+ -----------------------------------------
+ -- Check_False_Aspect_For_Derived_Type --
+ -----------------------------------------
+
+ procedure Check_False_Aspect_For_Derived_Type is
+ Par : Node_Id;
+
+ begin
+ -- We are only checking derived types
+
+ if not Is_Derived_Type (E) then
+ return;
+ end if;
+
+ Par := Nearest_Ancestor (E);
+
+ case A_Id is
+ when Aspect_Atomic | Aspect_Shared =>
+ if not Is_Atomic (Par) then
+ return;
+ end if;
+
+ when Aspect_Atomic_Components =>
+ if not Has_Atomic_Components (Par) then
+ return;
+ end if;
+
+ when Aspect_Discard_Names =>
+ if not Discard_Names (Par) then
+ return;
+ end if;
+
+ when Aspect_Pack =>
+ if not Is_Packed (Par) then
+ return;
+ end if;
+
+ when Aspect_Unchecked_Union =>
+ if not Is_Unchecked_Union (Par) then
+ return;
+ end if;
+
+ when Aspect_Volatile =>
+ if not Is_Volatile (Par) then
+ return;
+ end if;
+
+ when Aspect_Volatile_Components =>
+ if not Has_Volatile_Components (Par) then
+ return;
+ end if;
+
+ when others =>
+ return;
+ end case;
+
+ -- Fall through means we are canceling an inherited aspect
+
+ Error_Msg_Name_1 := A_Name;
+ Error_Msg_NE ("derived type& inherits aspect%, cannot cancel",
+ Expr,
+ E);
+
+ end Check_False_Aspect_For_Derived_Type;
+
+ -- Start of processing for Make_Pragma_From_Boolean_Aspect
+
+ begin
+ if Is_False (Static_Boolean (Expr)) then
+ Check_False_Aspect_For_Derived_Type;
+
+ else
+ Prag :=
+ Make_Pragma (Loc,
+ Pragma_Argument_Associations => New_List (
+ New_Occurrence_Of (Ent, Sloc (Ident))),
+ Pragma_Identifier =>
+ Make_Identifier (Sloc (Ident), Chars (Ident)));
+
+ Set_From_Aspect_Specification (Prag, True);
+ Set_Corresponding_Aspect (Prag, ASN);
+ Set_Aspect_Rep_Item (ASN, Prag);
+ Set_Is_Delayed_Aspect (Prag);
+ Set_Parent (Prag, ASN);
+ end if;
+
+ end Make_Pragma_From_Boolean_Aspect;
+
+ -- Start of processing for Evaluate_Aspects_At_Freeze_Point
+
+ begin
+ -- Must be declared in current scope
+
+ if Scope (E) /= Current_Scope then
+ return;
+ end if;
+
+ -- Look for aspect specification entries for this entity
+
+ ASN := First_Rep_Item (E);
+
+ while Present (ASN) loop
+ if Nkind (ASN) = N_Aspect_Specification
+ and then Entity (ASN) = E
+ and then Is_Delayed_Aspect (ASN)
+ then
+ A_Id := Get_Aspect_Id (Chars (Identifier (ASN)));
+
+ case A_Id is
+ -- For aspects whose expression is an optional Boolean, make
+ -- the corresponding pragma at the freezing point.
+
+ when Boolean_Aspects |
+ Library_Unit_Aspects =>
+ Make_Pragma_From_Boolean_Aspect (ASN);
+
+ -- Special handling for aspects that don't correspond to
+ -- pragmas/attributes.
+
+ when Aspect_Default_Value |
+ Aspect_Default_Component_Value =>
+ Analyze_Aspect_Default_Value (ASN);
+
+ when others => null;
+ end case;
+
+ Ritem := Aspect_Rep_Item (ASN);
+
+ if Present (Ritem) then
+ Analyze (Ritem);
+ end if;
+ end if;
+
+ Next_Rep_Item (ASN);
+ end loop;
+ end Evaluate_Aspects_At_Freeze_Point;
+
-------------------------
-- Get_Alignment_Value --
-------------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2012, 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- --
@@ -237,7 +237,7 @@
-- The visibility of aspects is tricky. First, the visibility is delayed
-- to the freeze point. This is not too complicated, what we do is simply
-- to leave the aspect "laying in wait" for the freeze point, and at that
- -- point materialize and analye the corresponding attribute definition
+ -- point materialize and analyze the corresponding attribute definition
-- clause or pragma. There is some special processing for preconditions
-- and postonditions, where the pragmas themselves deal with the required
-- delay, but basically the approach is the same, delay analysis of the
@@ -307,4 +307,8 @@
-- Performs the processing described above at the freeze all point, and
-- issues appropriate error messages if the visibility has indeed changed.
-- Again, ASN is the N_Aspect_Specification node for the aspect.
+
+ procedure Evaluate_Aspects_At_Freeze_Point (E : Entity_Id);
+ -- This routines evaluates all the delayed aspects for entity E at freezing
+ -- point.
end Sem_Ch13;
===================================================================
@@ -374,7 +374,13 @@
Name_Default_Storage_Pool : constant Name_Id := N + $; -- Ada 12
Name_Disable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
Name_Discard_Names : constant Name_Id := N + $;
- Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12
+
+ -- Note: Dispatching_Domain is not in this list because its name matches
+ -- the name of the corresponding attribute. However, it is included in the
+ -- definition of the type Pragma_Id, and the functions Get_Pragma_Id and
+ -- Is_Pragma_Id correctly recognize and process Dispatching_Domain.
+ -- Dispatching_Domain is a standard Ada 2012 pragma.
+
Name_Elaboration_Checks : constant Name_Id := N + $; -- GNAT
Name_Eliminate : constant Name_Id := N + $; -- GNAT
Name_Enable_Atomic_Synchronization : constant Name_Id := N + $; -- GNAT
@@ -456,7 +462,13 @@
Name_CPP_Constructor : constant Name_Id := N + $; -- GNAT
Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT
Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT
- Name_CPU : constant Name_Id := N + $; -- Ada 12
+
+ -- Note: CPU is not in this list because its name matches the name of
+ -- the corresponding attribute. However, it is included in the definition
+ -- of the type Pragma_Id, and the functions Get_Pragma_Id and Is_Pragma_Id
+ -- correctly recognize and process CPU. CPU is a standard Ada 2012
+ -- pragma.
+
Name_Debug : constant Name_Id := N + $; -- GNAT
Name_Elaborate : constant Name_Id := N + $; -- Ada 83
Name_Elaborate_All : constant Name_Id := N + $;
@@ -489,11 +501,16 @@
-- Note: Interface is not in this list because its name matches an Ada 05
-- keyword. However it is included in the definition of the type
-- Attribute_Id, and the functions Get_Pragma_Id and Is_Pragma_Id correctly
- -- recognize and process Name_Storage_Size.
+ -- recognize and process Name_Interface.
Name_Interface_Name : constant Name_Id := N + $; -- GNAT
Name_Interrupt_Handler : constant Name_Id := N + $;
- Name_Interrupt_Priority : constant Name_Id := N + $;
+
+ -- Note: Interrupt_Priority is not in this list because its name matches
+ -- the name of the corresponding attribute. However, it is included in the
+ -- definition of the type Pragma_Id, and the functions Get_Pragma_Id and
+ -- Is_Pragma_Id correctly recognize and process Interrupt_Priority.
+
Name_Invariant : constant Name_Id := N + $; -- GNAT
Name_Java_Constructor : constant Name_Id := N + $; -- GNAT
Name_Java_Interface : constant Name_Id := N + $; -- GNAT
@@ -754,6 +771,7 @@
Name_Constant_Indexing : constant Name_Id := N + $; -- GNAT
Name_Constrained : constant Name_Id := N + $;
Name_Count : constant Name_Id := N + $;
+ Name_CPU : constant Name_Id := N + $; -- Ada 12
Name_Default_Bit_Order : constant Name_Id := N + $; -- GNAT
Name_Default_Iterator : constant Name_Id := N + $; -- GNAT
Name_Definite : constant Name_Id := N + $;
@@ -761,6 +779,7 @@
Name_Denorm : constant Name_Id := N + $;
Name_Descriptor_Size : constant Name_Id := N + $;
Name_Digits : constant Name_Id := N + $;
+ Name_Dispatching_Domain : constant Name_Id := N + $; -- Ada 12
Name_Elaborated : constant Name_Id := N + $; -- GNAT
Name_Emax : constant Name_Id := N + $; -- Ada 83
Name_Enabled : constant Name_Id := N + $; -- GNAT
@@ -782,6 +801,7 @@
Name_Img : constant Name_Id := N + $; -- GNAT
Name_Implicit_Dereference : constant Name_Id := N + $; -- GNAT
Name_Integer_Value : constant Name_Id := N + $; -- GNAT
+ Name_Interrupt_Priority : constant Name_Id := N + $; -- Ada 12
Name_Invalid_Value : constant Name_Id := N + $; -- GNAT
Name_Iterator_Element : constant Name_Id := N + $; -- GNAT
Name_Large : constant Name_Id := N + $; -- Ada 83
@@ -1329,6 +1349,7 @@
Attribute_Constant_Indexing,
Attribute_Constrained,
Attribute_Count,
+ Attribute_CPU,
Attribute_Default_Bit_Order,
Attribute_Default_Iterator,
Attribute_Definite,
@@ -1336,6 +1357,7 @@
Attribute_Denorm,
Attribute_Descriptor_Size,
Attribute_Digits,
+ Attribute_Dispatching_Domain,
Attribute_Elaborated,
Attribute_Emax,
Attribute_Enabled,
@@ -1357,6 +1379,7 @@
Attribute_Img,
Attribute_Implicit_Dereference,
Attribute_Integer_Value,
+ Attribute_Interrupt_Priority,
Attribute_Invalid_Value,
Attribute_Iterator_Element,
Attribute_Large,
@@ -1576,7 +1599,6 @@
Pragma_Default_Storage_Pool,
Pragma_Disable_Atomic_Synchronization,
Pragma_Discard_Names,
- Pragma_Dispatching_Domain,
Pragma_Elaboration_Checks,
Pragma_Eliminate,
Pragma_Enable_Atomic_Synchronization,
@@ -1644,7 +1666,6 @@
Pragma_CPP_Constructor,
Pragma_CPP_Virtual,
Pragma_CPP_Vtable,
- Pragma_CPU,
Pragma_Debug,
Pragma_Elaborate,
Pragma_Elaborate_All,
@@ -1675,7 +1696,6 @@
Pragma_Inspection_Point,
Pragma_Interface_Name,
Pragma_Interrupt_Handler,
- Pragma_Interrupt_Priority,
Pragma_Invariant,
Pragma_Java_Constructor,
Pragma_Java_Interface,
@@ -1749,8 +1769,11 @@
-- match existing attribute names.
Pragma_AST_Entry,
+ Pragma_CPU,
+ Pragma_Dispatching_Domain,
Pragma_Fast_Math,
Pragma_Interface,
+ Pragma_Interrupt_Priority,
Pragma_Priority,
Pragma_Storage_Size,
Pragma_Storage_Unit,
@@ -1829,8 +1852,9 @@
function Is_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized pragma. Note that
- -- pragmas AST_Entry, Fast_Math, Priority, Storage_Size, and Storage_Unit
- -- are recognized as pragmas by this function even though their names are
+ -- pragmas AST_Entry, CPU, Dispatching_Domain, Fast_Math,
+ -- Interrupt_Priority, Priority, Storage_Size, and Storage_Unit are
+ -- recognized as pragmas by this function even though their names are
-- separate from the other pragma names. For this reason, clients should
-- always use this function, rather than do range tests on Name_Id values.
@@ -1870,9 +1894,9 @@
-- Returns Id of pragma corresponding to given name. Returns Unknown_Pragma
-- if N is not a name of a known (Ada defined or GNAT-specific) pragma.
-- Note that the function also works correctly for names of pragmas that
- -- are not included in the main list of pragma Names (AST_Entry, Priority,
- -- Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns
- -- Pragma_Storage_Size).
+ -- are not included in the main list of pragma Names (AST_Entry, CPU,
+ -- Dispatching_Domain, Interrupt_Priority, Priority, Storage_Size, and
+ -- Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
-- Returns Id of queuing policy corresponding to given name. It is an error
===================================================================
@@ -2636,6 +2636,99 @@
Actions := Build_Assignment (Id, Expression (Decl));
end if;
+ -- CPU, Dispatching_Domain, Priority and Size components are
+ -- filled with the corresponding rep item expression of the
+ -- concurrent type (if any).
+
+ elsif Ekind (Scope (Id)) = E_Record_Type
+ and then Present (Corresponding_Concurrent_Type (Scope (Id)))
+ and then (Chars (Id) = Name_uCPU
+ or else Chars (Id) = Name_uDispatching_Domain
+ or else Chars (Id) = Name_uPriority)
+ then
+ declare
+ Exp : Node_Id;
+ Nam : Name_Id;
+ Ritem : Node_Id;
+
+ begin
+ if Chars (Id) = Name_uCPU then
+ Nam := Name_CPU;
+
+ elsif Chars (Id) = Name_uDispatching_Domain then
+ Nam := Name_Dispatching_Domain;
+
+ elsif Chars (Id) = Name_uPriority then
+ Nam := Name_Priority;
+ end if;
+
+ -- Get the Rep Item (aspect specification, attribute
+ -- definition clause or pragma) of the corresponding
+ -- concurrent type.
+
+ Ritem :=
+ Get_Rep_Item
+ (Corresponding_Concurrent_Type (Scope (Id)), Nam);
+
+ if Present (Ritem) then
+ -- Pragma case
+
+ if Nkind (Ritem) = N_Pragma then
+ Exp := First (Pragma_Argument_Associations (Ritem));
+
+ if Nkind (Exp) = N_Pragma_Argument_Association then
+ Exp := Expression (Exp);
+ end if;
+
+ -- Conversion for Priority expression
+
+ if Nam = Name_Priority then
+ if Pragma_Name (Ritem) = Name_Priority
+ and then not GNAT_Mode
+ then
+ Exp := Convert_To (RTE (RE_Priority), Exp);
+ else
+ Exp :=
+ Convert_To (RTE (RE_Any_Priority), Exp);
+ end if;
+ end if;
+
+ -- Aspect/Attribute definition clause case
+
+ else
+ Exp := Expression (Ritem);
+
+ -- Conversion for Priority expression
+
+ if Nam = Name_Priority then
+ if Chars (Ritem) = Name_Priority
+ and then not GNAT_Mode
+ then
+ Exp := Convert_To (RTE (RE_Priority), Exp);
+ else
+ Exp :=
+ Convert_To (RTE (RE_Any_Priority), Exp);
+ end if;
+ end if;
+ end if;
+
+ -- Conversion for Dispatching_Domain value
+
+ if Nam = Name_Dispatching_Domain then
+ Exp :=
+ Unchecked_Convert_To
+ (RTE (RE_Dispatching_Domain_Access), Exp);
+ end if;
+
+ Actions := Build_Assignment (Id, Exp);
+
+ -- Nothing needed if no Rep Item
+
+ else
+ Actions := No_List;
+ end if;
+ end;
+
-- Composite component with its own Init_Proc
elsif not Is_Interface (Typ)