From 1d571f3b00a155910504a2b219c77b839aebbb16 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 19 Nov 2004 11:56:37 +0100 Subject: [PATCH] einfo.ads, einfo.adb: Remove Is_Psected flag, no longer used * einfo.ads, einfo.adb: Remove Is_Psected flag, no longer used (Has_Rep_Pragma): New function (Has_Attribute_Definition_Clause): New function (Record_Rep_Pragma): Moved here from sem_ch13.adb (Get_Rep_Pragma): Remove junk kludge for Stream_Convert pragma * sem_ch13.ads, sem_ch13.adb (Record_Rep_Pragma): Moved to einfo.adb * exp_prag.adb: (Expand_Pragma_Common_Object): New procedure (Expand_Pragma_Psect_Object): New procedure These procedures contain the revised and cleaned up processing for these two pragmas. This processing was formerly in Sem_Prag, but is more appropriately moved here. The cleanup involves making sure that the pragmas are properly attached to the tree, and that no nodes are improperly shared. * sem_prag.adb: Move expansion of Common_Object and Psect_Object pragmas to Exp_Prag, which is more appropriate. Attach these two pragmas to the Rep_Item chain Use Rep_Item chain to check for duplicates Remove use of Is_Psected flag, no longer needed. Use new Make_String_Literal function with string. * exp_attr.adb (Expand_Fpt_Attribute): The floating-point attributes that are functions return universal values, that have to be converted to the context type. Use new Make_String_Literal function with string. (Get_Stream_Convert_Pragma): New function, replaces the use of Get_Rep_Pragma, which had to be kludged to work in this case. * freeze.adb: Use new Has_Rep_Pragma function * exp_intr.adb, exp_ch3.adb, sem_attr.adb: Use new Make_String_Literal function with string. Use new Has_Rep_Pragma function. * tbuild.ads, tbuild.adb (Make_String_Literal): New function, takes string argument. From-SVN: r90904 --- gcc/ada/einfo.adb | 113 +++++++++++++-------------- gcc/ada/einfo.ads | 62 ++++++++++----- gcc/ada/exp_attr.adb | 70 +++++++++++++---- gcc/ada/exp_ch3.adb | 14 +--- gcc/ada/exp_intr.adb | 7 +- gcc/ada/exp_prag.adb | 164 ++++++++++++++++++++++++++++++++++++-- gcc/ada/freeze.adb | 8 +- gcc/ada/sem_attr.adb | 11 ++- gcc/ada/sem_ch13.adb | 10 --- gcc/ada/sem_ch13.ads | 5 -- gcc/ada/sem_prag.adb | 182 +++++++------------------------------------ gcc/ada/tbuild.adb | 17 ++++ gcc/ada/tbuild.ads | 6 ++ 13 files changed, 373 insertions(+), 296 deletions(-) diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 5f613dc3efd..85af819efb2 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -386,7 +386,6 @@ package body Einfo is -- Vax_Float Flag151 -- Entry_Accepted Flag152 - -- Is_Psected Flag153 -- Has_Per_Object_Constraint Flag154 -- Has_Private_Declaration Flag155 -- Referenced Flag156 @@ -421,7 +420,7 @@ package body Einfo is -- Has_Xref_Entry Flag182 -- Must_Be_On_Byte_Boundary Flag183 - -- Note: there are no unused flags currently! + -- (unused) Flag153 -------------------------------- -- Attribute Access Functions -- @@ -1587,11 +1586,6 @@ package body Einfo is return Flag53 (Id); end Is_Private_Descendant; - function Is_Psected (Id : E) return B is - begin - return Flag153 (Id); - end Is_Psected; - function Is_Public (Id : E) return B is begin pragma Assert (Nkind (Id) in N_Entity); @@ -3547,11 +3541,6 @@ package body Einfo is Set_Flag53 (Id, V); end Set_Is_Private_Descendant; - procedure Set_Is_Psected (Id : E; V : B := True) is - begin - Set_Flag153 (Id, V); - end Set_Is_Psected; - procedure Set_Is_Public (Id : E; V : B := True) is begin pragma Assert (Nkind (Id) in N_Entity); @@ -4806,6 +4795,10 @@ package body Einfo is -- Scans the Discriminants to see whether any are Completely_Hidden -- (the mechanism for describing non-specified stored discriminants) + ---------------------------------------- + -- Has_Completely_Hidden_Discriminant -- + ---------------------------------------- + function Has_Completely_Hidden_Discriminant (Id : E) return Boolean is Ent : Entity_Id := Id; @@ -4813,7 +4806,6 @@ package body Einfo is pragma Assert (Ekind (Id) = E_Discriminant); while Present (Ent) and then Ekind (Ent) = E_Discriminant loop - if Is_Completely_Hidden (Ent) then return True; end if; @@ -4921,9 +4913,8 @@ package body Einfo is ------------------------------------- function Get_Attribute_Definition_Clause - (E : Entity_Id; - Id : Attribute_Id) - return Node_Id + (E : Entity_Id; + Id : Attribute_Id) return Node_Id is N : Node_Id; @@ -4947,40 +4938,16 @@ package body Einfo is -------------------- function Get_Rep_Pragma (E : Entity_Id; Nam : Name_Id) return Node_Id is - N : Node_Id; - Typ : Entity_Id; + N : Node_Id; begin N := First_Rep_Item (E); - while Present (N) loop if Nkind (N) = N_Pragma and then Chars (N) = Nam then - - if Nam = Name_Stream_Convert then - - -- For tagged types this pragma is not inherited, so we - -- must verify that it is defined for the given type and - -- not an ancestor. - - Typ := Entity (Expression - (First (Pragma_Argument_Associations (N)))); - - if not Is_Tagged_Type (E) - or else E = Typ - or else (Is_Private_Type (Typ) - and then E = Full_View (Typ)) - then - return N; - else - Next_Rep_Item (N); - end if; - - else - return N; - end if; - else - Next_Rep_Item (N); + return N; end if; + + Next_Rep_Item (N); end loop; return Empty; @@ -5010,6 +4977,18 @@ package body Einfo is 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 -- ----------------- @@ -5020,8 +4999,8 @@ package body Einfo is begin pragma Assert (Is_Concurrent_Type (Id)); - Ent := First_Entity (Id); + Ent := First_Entity (Id); while Present (Ent) loop if Is_Entry (Ent) then Result := True; @@ -5089,6 +5068,15 @@ package body Einfo is end loop; end Has_Private_Ancestor; + -------------------- + -- 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; + ------------------------------ -- Implementation_Base_Type -- ------------------------------ @@ -5127,7 +5115,6 @@ package body Einfo is begin Item := First_Rep_Item (Id); - while Present (Item) loop if Nkind (Item) = N_Pragma and then Get_Pragma_Id (Chars (Item)) = Pragma_Inline_Always @@ -5206,9 +5193,10 @@ package body Einfo is else declare - C : Entity_Id := First_Component (Btype); + C : Entity_Id; begin + C := First_Component (Btype); while Present (C) loop if Is_By_Reference_Type (Etype (C)) or else Is_Volatile (Etype (C)) @@ -5376,9 +5364,10 @@ package body Einfo is else declare - C : E := First_Component (Btype); + C : E; begin + C := First_Component (Btype); while Present (C) loop if Is_Limited_Type (Etype (C)) then return True; @@ -5464,9 +5453,10 @@ package body Einfo is else declare - C : Entity_Id := First_Component (Btype); + C : Entity_Id; begin + C := First_Component (Btype); while Present (C) loop if Is_Return_By_Reference_Type (Etype (C)) then return True; @@ -5529,7 +5519,6 @@ package body Einfo is begin Comp_Id := Next_Entity (Id); - while Present (Comp_Id) loop exit when Ekind (Comp_Id) = E_Component; Comp_Id := Next_Entity (Comp_Id); @@ -5664,7 +5653,6 @@ package body Einfo is else N := 0; T := First_Index (Id); - while Present (T) loop N := N + 1; T := Next (T); @@ -5685,7 +5673,6 @@ package body Einfo is begin N := 0; Discr := First_Discriminant (Id); - while Present (Discr) loop N := N + 1; Discr := Next_Discriminant (Discr); @@ -5704,9 +5691,9 @@ package body Einfo is begin pragma Assert (Is_Concurrent_Type (Id)); + N := 0; Ent := First_Entity (Id); - while Present (Ent) loop if Is_Entry (Ent) then N := N + 1; @@ -5729,7 +5716,6 @@ package body Einfo is begin N := 0; Formal := First_Formal (Id); - while Present (Formal) loop N := N + 1; Formal := Next_Formal (Formal); @@ -5747,6 +5733,16 @@ package body Einfo is return Ekind (Id); end Parameter_Mode; + --------------------- + -- Record_Rep_Item -- + --------------------- + + procedure Record_Rep_Item (E : Entity_Id; N : Node_Id) is + begin + Set_Next_Rep_Item (N, First_Rep_Item (E)); + Set_First_Rep_Item (E, N); + end Record_Rep_Item; + --------------- -- Root_Type -- --------------- @@ -5804,9 +5800,10 @@ package body Einfo is ----------------- function Scope_Depth (Id : E) return Uint is - Scop : Entity_Id := Id; + Scop : Entity_Id; begin + Scop := Id; while Is_Record_Type (Scop) loop Scop := Scope (Scop); end loop; @@ -6246,7 +6243,6 @@ package body Einfo is W ("Is_Preelaborated", Flag59 (Id)); W ("Is_Private_Composite", Flag107 (Id)); W ("Is_Private_Descendant", Flag53 (Id)); - W ("Is_Psected", Flag153 (Id)); W ("Is_Public", Flag10 (Id)); W ("Is_Pure", Flag44 (Id)); W ("Is_Remote_Call_Interface", Flag62 (Id)); @@ -6372,14 +6368,13 @@ package body Einfo is Index : E; begin - Write_Attribute (" Component Type ", - Component_Type (Id)); + Write_Attribute + (" Component Type ", Component_Type (Id)); Write_Eol; Write_Str (Prefix); Write_Str (" Indices "); Index := First_Index (Id); - while Present (Index) loop Write_Attribute (" ", Etype (Index)); Index := Next_Index (Index); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 863f624da92..d77f811ec57 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2191,10 +2191,6 @@ package Einfo is -- Is_Protected_Type (synthesized) -- Applies to all entities, true for protected types and subtypes --- Is_Psected (Flag153) --- Present in entities for objects, true if a valid Psect_Object --- pragma applies to the object. Used to detect duplicate pragmas. - -- Is_Public (Flag10) -- Present in all entities. Set to indicate that an entity defined in -- one compilation unit can be referenced from other compilation units. @@ -4167,7 +4163,6 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) - -- Is_Psected (Flag153) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) -- Never_Set_In_Source (Flag115) @@ -4746,7 +4741,6 @@ package Einfo is -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) - -- Is_Psected (Flag153) -- Is_Shared_Passive (Flag60) -- Is_True_Constant (Flag163) -- Is_Volatile (Flag16) @@ -5186,7 +5180,6 @@ package Einfo is function Is_Preelaborated (Id : E) return B; function Is_Private_Composite (Id : E) return B; function Is_Private_Descendant (Id : E) return B; - function Is_Psected (Id : E) return B; function Is_Public (Id : E) return B; function Is_Pure (Id : E) return B; function Is_Remote_Call_Interface (Id : E) return B; @@ -5662,7 +5655,6 @@ package Einfo is procedure Set_Is_Preelaborated (Id : E; V : B := True); procedure Set_Is_Private_Composite (Id : E; V : B := True); procedure Set_Is_Private_Descendant (Id : E; V : B := True); - procedure Set_Is_Psected (Id : E; V : B := True); procedure Set_Is_Public (Id : E; V : B := True); procedure Set_Is_Pure (Id : E; V : B := True); procedure Set_Is_Remote_Call_Interface (Id : E; V : B := True); @@ -5868,26 +5860,56 @@ package Einfo is procedure Next_Stored_Discriminant (N : in out Node_Id) renames Proc_Next_Stored_Discriminant; - ------------------------------- - -- Miscellaneous Subprograms -- - ------------------------------- + ---------------------------------------------- + -- Subprograms for Accessing Rep Item Chain -- + ---------------------------------------------- - procedure Append_Entity (Id : Entity_Id; V : Entity_Id); - -- Add an entity to the list of entities declared in the scope V + -- The First_Rep_Item field of every entity points to a linked list + -- (linked through Next_Rep_Item) of representation pragmas and + -- attribute definition clauses that apply to the item. Note that + -- in the case of types, it is assumed that any such rep items for + -- a base type also apply to all subtypes. This is implemented by + -- having the chain for subtypes link onto the chain for the base + -- type, so that any new entries for the subtype are added at the + -- start of the chain. + + function Get_Attribute_Definition_Clause + (E : Entity_Id; + Id : Attribute_Id) return Node_Id; + -- Searches the Rep_Item chain for a given entity E, for an instance + -- of an attribute definition clause with the given attibute Id Id. If + -- found, the value returned is the N_Attribute_Definition_Clause node, + -- otherwise Empty is returned. 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 -- of a representation pragma with the given name Nam. If found then -- the value returned is the N_Pragma node, otherwise Empty is returned. - function Get_Attribute_Definition_Clause - (E : Entity_Id; - Id : Attribute_Id) - return Node_Id; + 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 attibute Id Id. If - -- found, the value returned is the N_Attribute_Definition_Clause node, - -- otherwise Empty is returned. + -- found, True is returned, otherwise False indicates that no matching + -- entry was found. + + procedure Record_Rep_Item (E : Entity_Id; N : Node_Id); + -- N is the node for either a representation pragma or an attribute + -- definition clause that applies to entity E. This procedure links + -- the node N onto the Rep_Item chain for entity E. + + ------------------------------- + -- Miscellaneous Subprograms -- + ------------------------------- + + procedure Append_Entity (Id : Entity_Id; V : Entity_Id); + -- Add an entity to the list of entities declared in the scope V function Is_Entity_Name (N : Node_Id) return Boolean; -- Test if the node N is the name of an entity (i.e. is an identifier, @@ -6183,7 +6205,6 @@ package Einfo is pragma Inline (Is_Private_Descendant); pragma Inline (Is_Private_Type); pragma Inline (Is_Protected_Type); - pragma Inline (Is_Psected); pragma Inline (Is_Public); pragma Inline (Is_Pure); pragma Inline (Is_Real_Type); @@ -6499,7 +6520,6 @@ package Einfo is pragma Inline (Set_Is_Preelaborated); pragma Inline (Set_Is_Private_Composite); pragma Inline (Set_Is_Private_Descendant); - pragma Inline (Set_Is_Psected); pragma Inline (Set_Is_Public); pragma Inline (Set_Is_Pure); pragma Inline (Set_Is_Remote_Call_Interface); diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 1ba1e03ca14..ae9a5cb0984 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -138,6 +138,11 @@ package body Exp_Attr is -- defining it, is returned. In both cases, inheritance of representation -- aspects is thus taken into account. + function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id; + -- Given a type, find a corresponding stream convert pragma that applies to + -- the implementation base type of this type (Typ). If found, return the + -- pragma node, otherwise return Empty if no pragma is found. + function Is_Constrained_Packed_Array (Typ : Entity_Id) return Boolean; -- Utility for array attributes, returns true on packed constrained -- arrays, and on access to same. @@ -297,9 +302,11 @@ package body Exp_Attr is -- The generated call is given the provided set of parameters, and then -- wrapped in a conversion which converts the result to the target type + -- We use the base type as the target because a range check may be + -- required. Rewrite (N, - Unchecked_Convert_To (Etype (N), + Unchecked_Convert_To (Base_Type (Etype (N)), Make_Function_Call (Loc, Name => Fnm, Parameter_Associations => Args))); @@ -909,12 +916,9 @@ package body Exp_Attr is if Pent = Standard_Standard or else Pent = Standard_ASCII then - Name_Buffer (1 .. Verbose_Library_Version'Length) := - Verbose_Library_Version; - Name_Len := Verbose_Library_Version'Length; Rewrite (N, Make_String_Literal (Loc, - Strval => String_From_Name_Buffer)); + Strval => Verbose_Library_Version)); -- All other cases @@ -1804,9 +1808,7 @@ package body Exp_Attr is -- from which it is derived. The extra conversion is required -- for the derived case. - Prag := - Get_Rep_Pragma - (Implementation_Base_Type (P_Type), Name_Stream_Convert); + Prag := Get_Stream_Convert_Pragma (P_Type); if Present (Prag) then Arg2 := Next (First (Pragma_Argument_Associations (Prag))); @@ -2380,9 +2382,7 @@ package body Exp_Attr is -- it is derived to type strmtyp. The conversion to acttyp is -- required for the derived case. - Prag := - Get_Rep_Pragma - (Implementation_Base_Type (P_Type), Name_Stream_Convert); + Prag := Get_Stream_Convert_Pragma (P_Type); if Present (Prag) then Arg3 := @@ -2795,9 +2795,7 @@ package body Exp_Attr is -- where Itemx is the expression of the type conversion (i.e. -- the actual object), and typex is the type of Itemx. - Prag := - Get_Rep_Pragma - (Implementation_Base_Type (P_Type), Name_Stream_Convert); + Prag := Get_Stream_Convert_Pragma (P_Type); if Present (Prag) then Arg2 := Next (First (Pragma_Argument_Associations (Prag))); @@ -4017,9 +4015,7 @@ package body Exp_Attr is -- it is derived to type strmtyp. The conversion to acttyp is -- required for the derived case. - Prag := - Get_Rep_Pragma - (Implementation_Base_Type (P_Type), Name_Stream_Convert); + Prag := Get_Stream_Convert_Pragma (P_Type); if Present (Prag) then Arg3 := @@ -4326,6 +4322,46 @@ package body Exp_Attr is return Etype (Indx); end Get_Index_Subtype; + ------------------------------- + -- Get_Stream_Convert_Pragma -- + ------------------------------- + + function Get_Stream_Convert_Pragma (T : Entity_Id) return Node_Id is + Typ : Entity_Id; + N : Node_Id; + + begin + -- Note: we cannot use Get_Rep_Pragma here because of the peculiarity + -- that a stream convert pragma for a tagged type is not inherited from + -- its parent. Probably what is wrong here is that it is basically + -- incorrect to consider a stream convert pragma to be a representation + -- pragma at all ??? + + N := First_Rep_Item (Implementation_Base_Type (T)); + while Present (N) loop + if Nkind (N) = N_Pragma and then Chars (N) = Name_Stream_Convert then + + -- For tagged types this pragma is not inherited, so we + -- must verify that it is defined for the given type and + -- not an ancestor. + + Typ := + Entity (Expression (First (Pragma_Argument_Associations (N)))); + + if not Is_Tagged_Type (T) + or else T = Typ + or else (Is_Private_Type (Typ) and then T = Full_View (Typ)) + then + return N; + end if; + end if; + + Next_Rep_Item (N); + end loop; + + return Empty; + end Get_Stream_Convert_Pragma; + --------------------------------- -- Is_Constrained_Packed_Array -- --------------------------------- diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 52394d376c2..0d3d72d35fd 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -57,7 +57,6 @@ with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; -with Stringt; use Stringt; with Snames; use Snames; with Tbuild; use Tbuild; with Ttypes; use Ttypes; @@ -1118,15 +1117,10 @@ package body Exp_Ch3 is -- This is just a workaround that must be improved later??? if With_Default_Init then - declare - S : String_Id; - Null_String : Node_Id; - begin - Start_String; - S := End_String; - Null_String := Make_String_Literal (Loc, Strval => S); - Append_To (Args, Null_String); - end; + Append_To (Args, + Make_String_Literal (Loc, + Strval => "")); + else Decls := Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type); Decl := Last (Decls); diff --git a/gcc/ada/exp_intr.adb b/gcc/ada/exp_intr.adb index f7014d25f93..7f99eb5ad0b 100644 --- a/gcc/ada/exp_intr.adb +++ b/gcc/ada/exp_intr.adb @@ -110,21 +110,18 @@ package body Exp_Intr is Loc : constant Source_Ptr := Sloc (N); P : Node_Id; E : Entity_Id; - S : String_Id; begin -- Climb up parents to see if we are in exception handler P := Parent (N); loop - -- Case of not in exception handler + -- Case of not in exception handler, replace by null string if No (P) then - Start_String; - S := End_String; Rewrite (N, Make_String_Literal (Loc, - Strval => S)); + Strval => "")); exit; -- Case of in exception handler diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 1ffbf5bc18c..cbaef5b5a15 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -58,22 +58,31 @@ package body Exp_Prag is function Arg1 (N : Node_Id) return Node_Id; function Arg2 (N : Node_Id) return Node_Id; - -- Obtain specified Pragma_Argument_Association + -- Obtain specified pragma argument expression procedure Expand_Pragma_Abort_Defer (N : Node_Id); procedure Expand_Pragma_Assert (N : Node_Id); + procedure Expand_Pragma_Common_Object (N : Node_Id); procedure Expand_Pragma_Import (N : Node_Id); procedure Expand_Pragma_Import_Export_Exception (N : Node_Id); procedure Expand_Pragma_Inspection_Point (N : Node_Id); procedure Expand_Pragma_Interrupt_Priority (N : Node_Id); + procedure Expand_Pragma_Psect_Object (N : Node_Id); ---------- -- Arg1 -- ---------- function Arg1 (N : Node_Id) return Node_Id is + Arg : constant Node_Id := First (Pragma_Argument_Associations (N)); begin - return First (Pragma_Argument_Associations (N)); + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; end Arg1; ---------- @@ -81,8 +90,23 @@ package body Exp_Prag is ---------- function Arg2 (N : Node_Id) return Node_Id is + Arg1 : constant Node_Id := First (Pragma_Argument_Associations (N)); begin - return Next (Arg1 (N)); + if No (Arg1) then + return Empty; + else + declare + Arg : constant Node_Id := Next (Arg1); + begin + if Present (Arg) + and then Nkind (Arg) = N_Pragma_Argument_Association + then + return Expression (Arg); + else + return Arg; + end if; + end; + end if; end Arg2; --------------------- @@ -105,6 +129,9 @@ package body Exp_Prag is when Pragma_Assert => Expand_Pragma_Assert (N); + when Pragma_Common_Object => + Expand_Pragma_Common_Object (N); + when Pragma_Export_Exception => Expand_Pragma_Import_Export_Exception (N); @@ -120,6 +147,9 @@ package body Exp_Prag is when Pragma_Interrupt_Priority => Expand_Pragma_Interrupt_Priority (N); + when Pragma_Psect_Object => + Expand_Pragma_Psect_Object (N); + -- All other pragmas need no expander action when others => null; @@ -195,7 +225,7 @@ package body Exp_Prag is procedure Expand_Pragma_Assert (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Cond : constant Node_Id := Expression (Arg1 (N)); + Cond : constant Node_Id := Arg1 (N); Msg : String_Id; begin @@ -222,7 +252,7 @@ package body Exp_Prag is -- First, we need to prepare the character literal if Present (Arg2 (N)) then - Msg := Strval (Expr_Value_S (Expression (Arg2 (N)))); + Msg := Strval (Expr_Value_S (Arg2 (N))); else Build_Location_String (Loc); Msg := String_From_Name_Buffer; @@ -265,6 +295,114 @@ package body Exp_Prag is end if; end Expand_Pragma_Assert; + --------------------------------- + -- Expand_Pragma_Common_Object -- + --------------------------------- + + -- Add series of pragmas to replicate semantic effect in DEC Ada + + -- pragma Linker_Section (internal_name, external_name); + -- pragma Machine_Attribute (internal_name, "overlaid"); + -- pragma Machine_Attribute (internal_name, "global"); + -- pragma Machine_Attribute (internal_name, "initialize"); + + -- For now we do nothing with the size attribute ??? + + -- Really this expansion would be much better in the back end. The + -- front end should not need to know about target dependent, back end + -- dependent semantics ??? + + procedure Expand_Pragma_Common_Object (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); + + Internal : constant Node_Id := Arg1 (N); + External : constant Node_Id := Arg2 (N); + + Psect : Node_Id; + -- Psect value upper cased as string literal + + Iloc : constant Source_Ptr := Sloc (Internal); + Eloc : constant Source_Ptr := Sloc (External); + Ploc : Source_Ptr; + + begin + -- Acquire Psect value and fold to upper case + + if Present (External) then + if Nkind (External) = N_String_Literal then + String_To_Name_Buffer (Strval (External)); + else + Get_Name_String (Chars (External)); + end if; + + Set_All_Upper_Case; + + Psect := + Make_String_Literal (Eloc, + Strval => String_From_Name_Buffer); + + else + Get_Name_String (Chars (Internal)); + Set_All_Upper_Case; + Psect := + Make_String_Literal (Iloc, + Strval => String_From_Name_Buffer); + end if; + + Ploc := Sloc (Psect); + + -- Insert pragmas + + Insert_List_After_And_Analyze (N, New_List ( + + -- The Linker_Section pragma ensures the correct section + + Make_Pragma (Loc, + Chars => Name_Linker_Section, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Iloc, + Expression => New_Copy_Tree (Internal)), + Make_Pragma_Argument_Association (Ploc, + Expression => New_Copy_Tree (Psect)))), + + -- Machine_Attribute "overlaid" ensures that this section + -- overlays any other sections of the same name. + + Make_Pragma (Loc, + Chars => Name_Machine_Attribute, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Iloc, + Expression => New_Copy_Tree (Internal)), + Make_Pragma_Argument_Association (Eloc, + Expression => + Make_String_Literal (Sloc => Ploc, + Strval => "overlaid")))), + + -- Machine_Attribute "global" ensures that section is visible + + Make_Pragma (Loc, + Chars => Name_Machine_Attribute, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Iloc, + Expression => New_Copy_Tree (Internal)), + Make_Pragma_Argument_Association (Eloc, + Expression => + Make_String_Literal (Sloc => Ploc, + Strval => "global")))), + + -- Machine_Attribute "initialize" ensures section is demand zeroed + + Make_Pragma (Loc, + Chars => Name_Machine_Attribute, + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Iloc, + Expression => New_Copy_Tree (Internal)), + Make_Pragma_Argument_Association (Eloc, + Expression => + Make_String_Literal (Sloc => Ploc, + Strval => "initialize")))))); + end Expand_Pragma_Common_Object; + -------------------------- -- Expand_Pragma_Import -- -------------------------- @@ -281,7 +419,7 @@ package body Exp_Prag is -- seen (i.e. this elaboration cannot be deferred to the freeze point). procedure Expand_Pragma_Import (N : Node_Id) is - Def_Id : constant Entity_Id := Entity (Expression (Arg2 (N))); + Def_Id : constant Entity_Id := Entity (Arg2 (N)); Typ : Entity_Id; Init_Call : Node_Id; @@ -340,7 +478,7 @@ package body Exp_Prag is end if; declare - Id : constant Entity_Id := Entity (Expression (Arg1 (N))); + Id : constant Entity_Id := Entity (Arg1 (N)); Call : constant Node_Id := Register_Exception_Call (Id); Loc : constant Source_Ptr := Sloc (N); @@ -579,4 +717,16 @@ package body Exp_Prag is end if; end Expand_Pragma_Interrupt_Priority; + -------------------------------- + -- Expand_Pragma_Psect_Object -- + -------------------------------- + + -- Convert to Common_Object, and expand the resulting pragma + + procedure Expand_Pragma_Psect_Object (N : Node_Id) is + begin + Set_Chars (N, Name_Common_Object); + Expand_Pragma_Common_Object (N); + end Expand_Pragma_Psect_Object; + end Exp_Prag; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 1623b41f7b0..e49ec85e4c6 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2235,17 +2235,17 @@ package body Freeze is -- inherited the indication from elsewhere (e.g. an address -- clause, which is not good enough in RM terms!) - if Present (Get_Rep_Pragma (E, Name_Atomic)) + if Has_Rep_Pragma (E, Name_Atomic) or else - Present (Get_Rep_Pragma (E, Name_Atomic_Components)) + Has_Rep_Pragma (E, Name_Atomic_Components) then Error_Msg_N ("stand alone atomic constant must be " & "imported ('R'M 'C.6(13))", E); - elsif Present (Get_Rep_Pragma (E, Name_Volatile)) + elsif Has_Rep_Pragma (E, Name_Volatile) or else - Present (Get_Rep_Pragma (E, Name_Volatile_Components)) + Has_Rep_Pragma (E, Name_Volatile_Components) then Error_Msg_N ("stand alone volatile constant must be " & diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index cc9017331e7..57c06a599a1 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1232,7 +1232,7 @@ package body Sem_Attr is if Is_Limited_Type (P_Type) and then Comes_From_Source (N) and then not Present (TSS (Btyp, Nam)) - and then No (Get_Rep_Pragma (Btyp, Name_Stream_Convert)) + and then not Has_Rep_Pragma (Btyp, Name_Stream_Convert) then Error_Msg_Name_1 := Aname; Error_Msg_NE @@ -3480,22 +3480,21 @@ package body Sem_Attr is when Attribute_Target_Name => Target_Name : declare TN : constant String := Sdefault.Target_Name.all; - TL : Integer := TN'Last; + TL : Natural; begin Check_Standard_Prefix; Check_E0; - Start_String; + + TL := TN'Last; if TN (TL) = '/' or else TN (TL) = '\' then TL := TL - 1; end if; - Store_String_Chars (TN (TN'First .. TL)); - Rewrite (N, Make_String_Literal (Loc, - Strval => End_String)); + Strval => TN (TN'First .. TL))); Analyze_And_Resolve (N, Standard_String); end Target_Name; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 6613ee6b393..3ece55021e7 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3411,16 +3411,6 @@ package body Sem_Ch13 is end if; end New_Stream_Procedure; - --------------------- - -- Record_Rep_Item -- - --------------------- - - procedure Record_Rep_Item (T : Entity_Id; N : Node_Id) is - begin - Set_Next_Rep_Item (N, First_Rep_Item (T)); - Set_First_Rep_Item (T, N); - end Record_Rep_Item; - ------------------------ -- Rep_Item_Too_Early -- ------------------------ diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index bfcade0e783..2a296b6cf28 100644 --- a/gcc/ada/sem_ch13.ads +++ b/gcc/ada/sem_ch13.ads @@ -90,11 +90,6 @@ package Sem_Ch13 is -- If the size is too small, and an error message is given, then both -- Esize and RM_Size are reset to the allowed minimum value in T. - procedure Record_Rep_Item (T : Entity_Id; N : Node_Id); - -- N is the node for either a representation pragma or an attribute - -- definition clause that applies to type T. This procedure links - -- the node N onto the Rep_Item chain for the type T. - function Rep_Item_Too_Early (T : Entity_Id; N : Node_Id) return Boolean; -- Called at the start of processing a representation clause or a -- representation pragma. Used to check that the representation item diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index b196c36d3c8..e21038f054d 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -875,13 +875,11 @@ package body Sem_Prag is procedure Check_Arg_Is_String_Literal (Arg : Node_Id) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin if Nkind (Argx) /= N_String_Literal then Error_Pragma_Arg ("argument for pragma% must be string literal", Argx); end if; - end Check_Arg_Is_String_Literal; ------------------------------------------ @@ -917,7 +915,6 @@ package body Sem_Prag is procedure Check_At_Most_N_Arguments (N : Nat) is Arg : Node_Id; - begin if Arg_Count > N then Arg := Arg1; @@ -997,7 +994,6 @@ package body Sem_Prag is procedure Check_First_Subtype (Arg : Node_Id) is Argx : constant Node_Id := Get_Pragma_Arg (Arg); - begin if not Is_First_Subtype (Entity (Argx)) then Error_Pragma_Arg @@ -1198,11 +1194,9 @@ package body Sem_Prag is procedure Check_No_Identifiers is Arg_Node : Node_Id; - begin if Arg_Count > 0 then Arg_Node := Arg1; - while Present (Arg_Node) loop Check_No_Identifier (Arg_Node); Next (Arg_Node); @@ -1280,8 +1274,9 @@ package body Sem_Prag is when N_Index_Or_Discriminant_Constraint => declare - IDC : Entity_Id := First (Constraints (Constr)); + IDC : Entity_Id; begin + IDC := First (Constraints (Constr)); while Present (IDC) loop Check_Static_Constraint (IDC); Next (IDC); @@ -1476,10 +1471,8 @@ package body Sem_Prag is Comp := First (Component_Items (Clist)); while Present (Comp) loop - Check_Component (Comp); Next (Comp); - end loop; end Check_Variant; @@ -2280,9 +2273,12 @@ package body Sem_Prag is ("pragma% must designate an object", Arg_Internal); end if; - if Is_Psected (Def_Id) then + if Has_Rep_Pragma (Def_Id, Name_Common_Object) + or else + Has_Rep_Pragma (Def_Id, Name_Psect_Object) + then Error_Pragma_Arg - ("previous Psect_Object applies, pragma % not permitted", + ("previous Common/Psect_Object applies, pragma % not permitted", Arg_Internal); end if; @@ -2463,12 +2459,12 @@ package body Sem_Prag is begin Process_Extended_Import_Export_Internal_Arg (Arg_Internal); - Hom_Id := Entity (Arg_Internal); Ent := Empty; Ambiguous := False; - -- Loop through homonyms (overloadings) of Hom_Id + -- Loop through homonyms (overloadings) of the entity + Hom_Id := Entity (Arg_Internal); while Present (Hom_Id) loop Def_Id := Get_Base_Subprogram (Hom_Id); @@ -4064,7 +4060,6 @@ package body Sem_Prag is else Bad_Class; end if; - end Set_Mechanism_Value; --------------------------- @@ -8401,13 +8396,7 @@ package body Sem_Prag is External : Node_Id renames Args (2); Size : Node_Id renames Args (3); - R_Internal : Node_Id; - R_External : Node_Id; - - MA : Node_Id; - Str : String_Id; - - Def_Id : Entity_Id; + Def_Id : Entity_Id; procedure Check_Too_Long (Arg : Node_Id); -- Posts message if the argument is an identifier with more @@ -8451,9 +8440,7 @@ package body Sem_Prag is Gather_Associations (Names, Args); Process_Extended_Import_Export_Internal_Arg (Internal); - R_Internal := Relocate_Node (Internal); - - Def_Id := Entity (R_Internal); + Def_Id := Entity (Internal); if Ekind (Def_Id) /= E_Constant and then Ekind (Def_Id) /= E_Variable @@ -8462,38 +8449,39 @@ package body Sem_Prag is ("pragma% must designate an object", Internal); end if; - Check_Too_Long (R_Internal); + Check_Too_Long (Internal); if Is_Imported (Def_Id) or else Is_Exported (Def_Id) then Error_Pragma_Arg ("cannot use pragma% for imported/exported object", - R_Internal); + Internal); end if; - if Is_Concurrent_Type (Etype (R_Internal)) then + if Is_Concurrent_Type (Etype (Internal)) then Error_Pragma_Arg ("cannot specify pragma % for task/protected object", - R_Internal); + Internal); end if; - if Is_Psected (Def_Id) then - Error_Msg_N ("?duplicate Psect_Object pragma", N); - else - Set_Is_Psected (Def_Id); + if Has_Rep_Pragma (Def_Id, Name_Common_Object) + or else + Has_Rep_Pragma (Def_Id, Name_Psect_Object) + then + Error_Msg_N ("?duplicate Common/Psect_Object pragma", N); end if; if Ekind (Def_Id) = E_Constant then Error_Pragma_Arg - ("cannot specify pragma % for a constant", R_Internal); + ("cannot specify pragma % for a constant", Internal); end if; - if Is_Record_Type (Etype (R_Internal)) then + if Is_Record_Type (Etype (Internal)) then declare Ent : Entity_Id; Decl : Entity_Id; begin - Ent := First_Entity (Etype (R_Internal)); + Ent := First_Entity (Etype (Internal)); while Present (Ent) loop Decl := Declaration_Node (Ent); @@ -8503,7 +8491,7 @@ package body Sem_Prag is and then Warn_On_Export_Import then Error_Msg_N - ("?object for pragma % has defaults", R_Internal); + ("?object for pragma % has defaults", Internal); exit; else @@ -8517,120 +8505,13 @@ package body Sem_Prag is Check_Too_Long (Size); end if; - -- Make Psect case-insensitive. - if Present (External) then Check_Too_Long (External); - - if Nkind (External) = N_String_Literal then - String_To_Name_Buffer (Strval (External)); - else - Get_Name_String (Chars (External)); - end if; - - Set_All_Upper_Case; - Start_String; - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - Str := End_String; - R_External := Make_String_Literal - (Sloc => Sloc (External), Strval => Str); - else - Get_Name_String (Chars (Internal)); - Set_All_Upper_Case; - Start_String; - Store_String_Chars (Name_Buffer (1 .. Name_Len)); - Str := End_String; - R_External := Make_String_Literal - (Sloc => Sloc (Internal), Strval => Str); end if; - -- Transform into pragma Linker_Section, add attributes to - -- match what DEC Ada does. Ignore size for now? + -- If all error tests pass, link pragma on to the rep item chain - Rewrite (N, - Make_Pragma - (Sloc (N), - Name_Linker_Section, - New_List - (Make_Pragma_Argument_Association - (Sloc => Sloc (R_Internal), - Expression => R_Internal), - Make_Pragma_Argument_Association - (Sloc => Sloc (R_External), - Expression => R_External)))); - - Analyze (N); - - -- Add Machine_Attribute of "overlaid", so the section overlays - -- other sections of the same name. - - Start_String; - Store_String_Chars ("overlaid"); - Str := End_String; - - MA := - Make_Pragma - (Sloc (N), - Name_Machine_Attribute, - New_List - (Make_Pragma_Argument_Association - (Sloc => Sloc (R_Internal), - Expression => R_Internal), - Make_Pragma_Argument_Association - (Sloc => Sloc (R_External), - Expression => - Make_String_Literal - (Sloc => Sloc (R_External), - Strval => Str)))); - Analyze (MA); - - -- Add Machine_Attribute of "global", so the section is visible - -- everywhere - - Start_String; - Store_String_Chars ("global"); - Str := End_String; - - MA := - Make_Pragma - (Sloc (N), - Name_Machine_Attribute, - New_List - (Make_Pragma_Argument_Association - (Sloc => Sloc (R_Internal), - Expression => R_Internal), - - Make_Pragma_Argument_Association - (Sloc => Sloc (R_External), - Expression => - Make_String_Literal - (Sloc => Sloc (R_External), - Strval => Str)))); - Analyze (MA); - - -- Add Machine_Attribute of "initialize", so the section is - -- demand zeroed. - - Start_String; - Store_String_Chars ("initialize"); - Str := End_String; - - MA := - Make_Pragma - (Sloc (N), - Name_Machine_Attribute, - New_List - (Make_Pragma_Argument_Association - (Sloc => Sloc (R_Internal), - Expression => R_Internal), - - Make_Pragma_Argument_Association - (Sloc => Sloc (R_External), - Expression => - Make_String_Literal - (Sloc => Sloc (R_External), - Strval => Str)))); - Analyze (MA); + Record_Rep_Item (Def_Id, N); end Psect_Object; ---------- @@ -9830,12 +9711,11 @@ package body Sem_Prag is end if; Vpart := Variant_Part (Clist); + Variant := First (Variants (Vpart)); while Present (Variant) loop - Check_Variant (Variant); Next (Variant); - end loop; end if; @@ -9921,7 +9801,6 @@ package body Sem_Prag is Check_At_Least_N_Arguments (1); Arg_Node := Arg1; - while Present (Arg_Node) loop Check_No_Identifier (Arg_Node); @@ -10117,9 +9996,9 @@ package body Sem_Prag is if Is_Enumeration_Type (E) then declare - Lit : Entity_Id := First_Literal (E); - + Lit : Entity_Id; begin + Lit := First_Literal (E); while Present (Lit) loop Set_Warnings_Off (Lit); Next_Literal (Lit); @@ -10201,10 +10080,9 @@ package body Sem_Prag is Result : Entity_Id; begin - Result := Def_Id; - -- Follow subprogram renaming chain + Result := Def_Id; while Is_Subprogram (Result) and then (Is_Generic_Instance (Result) diff --git a/gcc/ada/tbuild.adb b/gcc/ada/tbuild.adb index 60242a5e8c2..046826f617a 100644 --- a/gcc/ada/tbuild.adb +++ b/gcc/ada/tbuild.adb @@ -35,6 +35,7 @@ with Rident; use Rident; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Uintp; use Uintp; package body Tbuild is @@ -334,6 +335,22 @@ package body Tbuild is UI_From_Int (RT_Exception_Code'Pos (Reason))); end Make_Raise_Storage_Error; + ------------------------- + -- Make_String_Literal -- + ------------------------- + + function Make_String_Literal + (Sloc : Source_Ptr; + Strval : String) return Node_Id + is + begin + Start_String; + Store_String_Chars (Strval); + return + Make_String_Literal (Sloc, + Strval => End_String); + end Make_String_Literal; + --------------------------- -- Make_Unsuppress_Block -- --------------------------- diff --git a/gcc/ada/tbuild.ads b/gcc/ada/tbuild.ads index 7aac7295600..e96d22a0601 100644 --- a/gcc/ada/tbuild.ads +++ b/gcc/ada/tbuild.ads @@ -156,6 +156,12 @@ package Tbuild is -- A convenient form of Make_Raise_Storage_Error where the Reason -- is given simply as an enumeration value, rather than a Uint code. + function Make_String_Literal + (Sloc : Source_Ptr; + Strval : String) return Node_Id; + -- A convenient form of Make_String_Literal, where the string value + -- is given as a normal string instead of a String_Id value. + function Make_Unsuppress_Block (Loc : Source_Ptr; Check : Name_Id;