This patch restores the original error messages for duplicated pragma and attribute definition clause and cleans up the ??? comments.
Tested on x86_64-pc-linux-gnu, committed on trunk 2012-06-14 Vincent Pucci <pu...@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.
Index: sem_aux.adb =================================================================== --- sem_aux.adb (revision 188605) +++ sem_aux.adb (working copy) @@ -32,7 +32,6 @@ with Atree; use Atree; with Einfo; use Einfo; -with Namet; use Namet; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; @@ -418,6 +417,155 @@ 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 -- ------------------------------- @@ -832,7 +980,7 @@ ---------------------- 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 Index: sem_aux.ads =================================================================== --- sem_aux.ads (revision 188605) +++ sem_aux.ads (working copy) @@ -39,6 +39,7 @@ -- require more than minimal semantic knowledge. with Alloc; use Alloc; +with Namet; use Namet; with Table; with Types; use Types; @@ -155,6 +156,52 @@ -- 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 Index: exp_ch9.adb =================================================================== --- exp_ch9.adb (revision 188605) +++ exp_ch9.adb (working copy) @@ -11604,7 +11604,7 @@ -- 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 => @@ -11619,7 +11619,8 @@ 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 @@ -13337,11 +13338,11 @@ 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 @@ -13724,7 +13725,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 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), @@ -13907,7 +13908,7 @@ -- 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. @@ -13916,7 +13917,8 @@ (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)); Index: einfo.adb =================================================================== --- einfo.adb (revision 188606) +++ einfo.adb (working copy) @@ -32,12 +32,12 @@ 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 @@ -5979,41 +5979,6 @@ 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 -- ------------------- @@ -6054,114 +6019,6 @@ 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 -- ------------------------ @@ -6247,36 +6104,7 @@ 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 -- -------------------- Index: einfo.ads =================================================================== --- einfo.ads (revision 188606) +++ einfo.ads (working copy) @@ -29,7 +29,6 @@ -- -- ------------------------------------------------------------------------------ -with Namet; use Namet; with Snames; use Snames; with Types; use Types; with Uintp; use Uintp; @@ -7189,67 +7188,11 @@ -- 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 Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 188605) +++ sem_prag.adb (working copy) @@ -1613,7 +1613,7 @@ -- 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); @@ -1630,12 +1630,8 @@ or else From_Aspect_Specification (P) then Error_Msg_NE ("aspect% for & previously given#", N, Id); - - elsif Nkind (P) = N_Pragma then + else Error_Msg_NE ("pragma% for & duplicates pragma#", N, Id); - - else - Error_Msg_NE ("pragma% for & duplicates clause#", N, Id); end if; raise Pragma_Exit; @@ -8024,7 +8020,6 @@ -- Item chain of Ent. Check_Duplicate_Pragma (Ent); - Record_Rep_Item (Ent, N); end CPU; @@ -8317,7 +8312,6 @@ -- Item chain of Ent. Check_Duplicate_Pragma (Ent); - Record_Rep_Item (Ent, N); -- Anything else is incorrect @@ -10284,7 +10278,6 @@ -- Item chain of Ent. Check_Duplicate_Pragma (Ent); - Record_Rep_Item (Ent, N); end if; end Interrupt_Priority; @@ -12410,7 +12403,6 @@ -- Item chain of Ent. Check_Duplicate_Pragma (Ent); - Record_Rep_Item (Ent, N); end Priority; @@ -13928,7 +13920,12 @@ -- 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; @@ -13965,7 +13962,12 @@ -- 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; Index: sem_eval.adb =================================================================== --- sem_eval.adb (revision 188605) +++ sem_eval.adb (working copy) @@ -4685,8 +4685,12 @@ 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 Index: exp_intr.adb =================================================================== --- exp_intr.adb (revision 188605) +++ exp_intr.adb (working copy) @@ -44,6 +44,7 @@ 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; Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 188605) +++ sem_ch13.adb (working copy) @@ -2058,24 +2058,13 @@ -- 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;