+2012-06-14 Vincent Pucci <pucci@adacore.com>
+
+ * einfo.adb einfo.ads (Get_Rep_Item): Removed.
+ (Get_Rep_Item_For_Entity): Removed.
+ (Get_Rep_Pragma): Removed.
+ (Get_Rep_Pragma_For_Entity): Removed.
+ (Has_Rep_Item): Removed.
+ (Has_Rep_Pragma): Removed.
+ (Has_Rep_Pragma_For_Entity): Removed.
+ * exp_ch9.adb (Expand_N_Task_Type_Declaration):
+ Has_Rep_Pragma_For_Entity replaced by Has_Rep_Pragma
+ and Get_Rep_Pragma_For_Entity replaced by Get_Rep_Pragma.
+ (Make_Task_Create_Call): Has_Rep_Pragma_For_Entity replaced
+ by Has_Rep_Pragma and Get_Rep_Pragma_For_Entity replaced by
+ Get_Rep_Pragma.
+ * exp_intr.adb: Dependency to Sem_Aux added for call to Get_Rep_Pragma.
+ * sem_aux.adb (Get_Rep_Item): New routine.
+ (Get_Rep_Pragma): New routine.
+ (Has_Rep_Item): New routine.
+ (Has_Rep_Pragma): New routine.
+ (Nearest_Ancestor): Minor reformatting.
+ * sem_aux.ads (Get_Rep_Item): New routine.
+ (Get_Rep_Pragma): New routine.
+ (Has_Rep_Item): New routine.
+ (Has_Rep_Pragma): New routine.
+ * sem_ch13.adb (Duplicate_Clause): Restore original error messages.
+ * sem_eval.adb (Subtypes_Statically_Match): Get_Rep_Item_For_Entity
+ replaced by Get_Rep_Item.
+ * sem_prag.adb (Analyze_Pragma): Restore original error messages.
+ (Check_Duplicate_Pragma): Restore original error messages.
+
2012-06-14 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (Is_Object_Reference): in Ada 2012, qualified
pragma Style_Checks (All_Checks);
-- Turn off subprogram ordering, not used for this unit
-with Atree; use Atree;
-with Nlists; use Nlists;
-with Output; use Output;
-with Sem_Aux; use Sem_Aux; -- wrong dependency ???
-with Sinfo; use Sinfo;
-with Stand; use Stand;
+with Atree; use Atree;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
package body Einfo is
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 --
-------------------
return Empty;
end Get_Record_Representation_Clause;
- -----------------------------
- -- Get_Rep_Item_For_Entity --
- -----------------------------
-
- function Get_Rep_Item_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.
-
- N : Node_Id;
-
- begin
- N := First_Rep_Item (E);
- while Present (N) loop
- 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 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 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 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;
-
- Next_Rep_Item (N);
- end loop;
-
- return Empty;
- end Get_Rep_Item_For_Entity;
-
- --------------------
- -- Get_Rep_Pragma --
- --------------------
-
- function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is
- N : Node_Id;
-
- begin
- N := First_Rep_Item (E);
- while Present (N) loop
- 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;
-
- Next_Rep_Item (N);
- end loop;
-
- 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 --
------------------------
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 --
- --------------------
-
- function Has_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Boolean is
- begin
- 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 --
--------------------
-- --
------------------------------------------------------------------------------
-with Namet; use Namet;
with Snames; use Snames;
with Types; use Types;
with Uintp; use Uintp;
-- value returned is the N_Attribute_Definition_Clause node, otherwise
-- Empty is returned.
- -- What is difference between following two, and why are they named
- -- the way they are ???
-
- 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. 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
-- representation clause, and if found, returns it. Returns Empty
-- if no such clause is found.
- -- I still don't get it, if the first one returns stuff from the parent
- -- it should say so, and it doesn't, and the names make no sense ???
-
- 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. 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.
-
- -- Again, the following two have bizarre names, and unclear specs ???
-
- 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_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
-- Add the _Task_Info component if a Task_Info pragma is present
- if Has_Rep_Pragma_For_Entity (TaskId, Name_Task_Info) then
+ if Has_Rep_Pragma (TaskId, Name_Task_Info, Check_Parents => False) then
Append_To (Cdecls,
Make_Component_Declaration (Loc,
Defining_Identifier =>
Expression => New_Copy (
Expression (First (
Pragma_Argument_Associations (
- Get_Rep_Pragma_For_Entity (TaskId, Name_Task_Info)))))));
+ Get_Rep_Pragma
+ (TaskId, Name_Task_Info, Check_Parents => False)))))));
end if;
-- Add the _CPU component with no expression
Attribute_Name => Name_Unchecked_Access));
-- Priority parameter. Set to Unspecified_Priority unless there is a
- -- 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).
+ -- Priority rep item, in which case we take the value from the pragma
+ -- or attribute definition clause, or there is an Interrupt_Priority
+ -- rep item and no Priority rep item, and we set the ceiling to
+ -- Interrupt_Priority'Last, an implementation-defined value, see
+ -- D.3(10).
if Has_Rep_Item (Ptyp, Name_Priority) then
declare
-- 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 Has_Rep_Pragma_For_Entity (Ttyp, Name_Task_Info) then
+ if Has_Rep_Pragma (Ttyp, Name_Task_Info, Check_Parents => False) then
Append_To (Args,
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_uInit),
-- init call unless there is a Task_Name pragma, in which case we take
-- the value from the pragma.
- if Has_Rep_Pragma_For_Entity (Ttyp, Name_Task_Name) then
+ if Has_Rep_Pragma (Ttyp, Name_Task_Name, Check_Parents => False) then
-- Copy expression in full, because it may be dynamic and have
-- side effects.
(Expression
(First
(Pragma_Argument_Associations
- (Get_Rep_Pragma_For_Entity (Ttyp, Name_Task_Name))))));
+ (Get_Rep_Pragma
+ (Ttyp, Name_Task_Name, Check_Parents => False))))));
else
Append_To (Args, Make_Identifier (Loc, Name_uTask_Name));
with Rident; use Rident;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;
with Atree; use Atree;
with Einfo; use Einfo;
-with Namet; use Namet;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
return Empty;
end First_Tag_Component;
+ ------------------
+ -- Get_Rep_Item --
+ ------------------
+
+ function Get_Rep_Item
+ (E : Entity_Id;
+ Nam : Name_Id;
+ Check_Parents : Boolean := True) return Node_Id
+ is
+ N : Node_Id;
+
+ begin
+ N := First_Rep_Item (E);
+ while Present (N) loop
+ 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
+ if Check_Parents then
+ return N;
+
+ -- If Check_Parents is False, return N if the pragma doesn't
+ -- appear in the Rep_Item chain of the parent.
+
+ else
+ declare
+ Par : constant Entity_Id := Nearest_Ancestor (E);
+ -- This node represents the parent type of type E (if any)
+
+ begin
+ if No (Par) then
+ return N;
+
+ elsif not Present_In_Rep_Item (Par, N) then
+ return N;
+ end if;
+ end;
+ end if;
+
+ elsif Nkind (N) = N_Attribute_Definition_Clause
+ and then
+ (Chars (N) = Nam
+ or else (Nam = Name_Priority
+ and then Chars (N) = Name_Interrupt_Priority))
+ then
+ if Check_Parents then
+ return N;
+
+ elsif Entity (N) = E then
+ return N;
+ end if;
+
+ elsif Nkind (N) = N_Aspect_Specification
+ and then
+ (Chars (Identifier (N)) = Nam
+ or else (Nam = Name_Priority
+ and then Chars (Identifier (N)) =
+ Name_Interrupt_Priority))
+ then
+ if Check_Parents then
+ return N;
+
+ elsif Entity (N) = E then
+ return N;
+ end if;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+
+ return Empty;
+ end Get_Rep_Item;
+
+ --------------------
+ -- Get_Rep_Pragma --
+ --------------------
+
+ function Get_Rep_Pragma
+ (E : Entity_Id;
+ Nam : Name_Id;
+ Check_Parents : Boolean := True) return Node_Id
+ is
+ N : Node_Id;
+
+ begin
+ N := First_Rep_Item (E);
+ while Present (N) loop
+ 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
+ if Check_Parents then
+ return N;
+
+ -- If Check_Parents is False, return N if the pragma doesn't
+ -- appear in the Rep_Item chain of the parent.
+
+ else
+ declare
+ Par : constant Entity_Id := Nearest_Ancestor (E);
+ -- This node represents the parent type of type E (if any)
+
+ begin
+ if No (Par) then
+ return N;
+
+ elsif not Present_In_Rep_Item (Par, N) then
+ return N;
+ end if;
+ end;
+ end if;
+ end if;
+
+ Next_Rep_Item (N);
+ end loop;
+
+ return Empty;
+ end Get_Rep_Pragma;
+
+ ------------------
+ -- Has_Rep_Item --
+ ------------------
+
+ function Has_Rep_Item
+ (E : Entity_Id;
+ Nam : Name_Id;
+ Check_Parents : Boolean := True) return Boolean
+ is
+ begin
+ return Present (Get_Rep_Item (E, Nam, Check_Parents));
+ end Has_Rep_Item;
+
+ --------------------
+ -- Has_Rep_Pragma --
+ --------------------
+
+ function Has_Rep_Pragma
+ (E : Entity_Id;
+ Nam : Name_Id;
+ Check_Parents : Boolean := True) return Boolean
+ is
+ begin
+ return Present (Get_Rep_Pragma (E, Nam, Check_Parents));
+ end Has_Rep_Pragma;
+
-------------------------------
-- Initialization_Suppressed --
-------------------------------
----------------------
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is
- D : constant Node_Id := Original_Node (Declaration_Node (Typ));
+ D : constant Node_Id := Declaration_Node (Typ);
begin
-- If we have a subtype declaration, get the ancestor subtype
-- require more than minimal semantic knowledge.
with Alloc; use Alloc;
+with Namet; use Namet;
with Table;
with Types; use Types;
-- Typ must be a tagged record type. This function returns the Entity for
-- the first _Tag field in the record type.
+ function Get_Rep_Item
+ (E : Entity_Id;
+ Nam : Name_Id;
+ Check_Parents : Boolean := True) 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 Nam. If Check_Parents is False then it
+ -- only returns rep item that has been directly specified to E (and not
+ -- inherited from its parents, if any). 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_Pragma
+ (E : Entity_Id;
+ Nam : Name_Id;
+ Check_Parents : Boolean := True) return Node_Id;
+ -- Searches the Rep_Item chain for a given entity E, for an instance of a
+ -- representation pragma whose name matches the given name Nam. If
+ -- Check_Parents is False then it only returns representation pragma that
+ -- has been directly specified to E (and not inherited from its parents, if
+ -- any). 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 Has_Rep_Item
+ (E : Entity_Id;
+ Nam : Name_Id;
+ Check_Parents : Boolean := True) return Boolean;
+ -- Searches the Rep_Item chain for the given entity E, for an instance of a
+ -- rep item (pragma, attribute definition clause, or aspect specification)
+ -- with the given name Nam. If Check_Parents is False then it only returns
+ -- rep item that has been directly specified to E (and not inherited from
+ -- its parents, if any). 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;
+ Check_Parents : Boolean := True) return Boolean;
+ -- Searches the Rep_Item chain for the given entity E, for an instance of a
+ -- representation pragma with the given name Nam. If Check_Parents is False
+ -- then it only returns representation pragma that has been directly
+ -- specified to E (and not inherited from its parents, if any). If found
+ -- then True is returned, otherwise False indicates that no matching entry
+ -- was found.
+
function In_Generic_Body (Id : Entity_Id) return Boolean;
-- Determine whether entity Id appears inside a generic body
-- previously given pragma or aspect specification for the same
-- aspect.
- A := Get_Rep_Item_For_Entity (U_Ent, Chars (N));
+ A := Get_Rep_Item (U_Ent, Chars (N), Check_Parents => False);
if Present (A) then
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);
-
- 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;
-
+ Error_Msg_NE ("aspect% for & previously given#", N, U_Ent);
return True;
end if;
return False;
else
- Pred1 := Get_Rep_Item_For_Entity (T1, Name_Static_Predicate);
- Pred2 := Get_Rep_Item_For_Entity (T2, Name_Static_Predicate);
+ Pred1 :=
+ Get_Rep_Item
+ (T1, Name_Static_Predicate, Check_Parents => False);
+ Pred2 :=
+ Get_Rep_Item
+ (T2, Name_Static_Predicate, Check_Parents => False);
-- Subtypes statically match if the predicate comes from the
-- same declaration, which can only happen if one is a subtype
-- previously given aspect specification or attribute definition
-- clause for the same pragma.
- P := Get_Rep_Item_For_Entity (E, Pragma_Name (N));
+ P := Get_Rep_Item (E, Pragma_Name (N), Check_Parents => False);
if Present (P) then
Error_Msg_Name_1 := Pragma_Name (N);
or else From_Aspect_Specification (P)
then
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 clause#", N, Id);
+ Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id);
end if;
raise Pragma_Exit;
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
-
Record_Rep_Item (Ent, N);
end CPU;
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
-
Record_Rep_Item (Ent, N);
-- Anything else is incorrect
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
-
Record_Rep_Item (Ent, N);
end if;
end Interrupt_Priority;
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
-
Record_Rep_Item (Ent, N);
end Priority;
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
- Check_Duplicate_Pragma (Ent);
+ if Has_Rep_Pragma
+ (Ent, Name_Task_Info, Check_Parents => False)
+ then
+ Error_Pragma ("duplicate pragma% not allowed");
+ end if;
+
Record_Rep_Item (Ent, N);
end Task_Info;
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
- Check_Duplicate_Pragma (Ent);
+ if Has_Rep_Pragma
+ (Ent, Name_Task_Name, Check_Parents => False)
+ then
+ Error_Pragma ("duplicate pragma% not allowed");
+ end if;
+
Record_Rep_Item (Ent, N);
end Task_Name;
projects / gcc.git / commitdiff