From 5245b786fc5507b712ad9dd5fc461962d269f78d Mon Sep 17 00:00:00 2001 From: charlet Date: Fri, 19 Nov 2004 10:56:37 +0000 Subject: * 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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@90904 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/exp_prag.adb | 164 ++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 157 insertions(+), 7 deletions(-) (limited to 'gcc/ada/exp_prag.adb') 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; -- cgit v1.2.1