diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 12 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/gnatcmd.adb | 37 | ||||
| -rw-r--r-- | gcc/ada/par-prag.adb | 1 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 32 | ||||
| -rw-r--r-- | gcc/ada/snames.ads-tmpl | 2 |
6 files changed, 89 insertions, 23 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1d3d0aaa649..10cf7299dc0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,15 @@ +2010-01-27 Vincent Celier <celier@adacore.com> + + * gnatcmd.adb: When there is only one main specified, the package + support Switches (<main>) and attribute Switches is specified for the + main, use these switches, instead of Default_Switches ("Ada"). + +2010-01-27 Robert Dewar <dewar@adacore.com> + + * sem_prag.adb, par-prag.adb, snames.ads-tmpl: pragma Dimension initial + implementation. + * exp_disp.adb: Minor reformatting + 2010-01-27 Tristan Gingold <gingold@adacore.com> * seh_init.c: Use __ImageBase instead of _ImageBase. diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 2d4a634f83d..11ae6dff5c7 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -1443,11 +1443,11 @@ package body Exp_Disp is Thunk_Id : out Entity_Id; Thunk_Code : out Node_Id) is - Loc : constant Source_Ptr := Sloc (Prim); - Actuals : constant List_Id := New_List; - Decl : constant List_Id := New_List; - Formals : constant List_Id := New_List; - Target : constant Entity_Id := Ultimate_Alias (Prim); + Loc : constant Source_Ptr := Sloc (Prim); + Actuals : constant List_Id := New_List; + Decl : constant List_Id := New_List; + Formals : constant List_Id := New_List; + Target : constant Entity_Id := Ultimate_Alias (Prim); Controlling_Typ : Entity_Id; Decl_1 : Node_Id; @@ -1464,8 +1464,8 @@ package body Exp_Disp is Thunk_Id := Empty; Thunk_Code := Empty; - -- In case of primitives that are functions without formals and - -- a controlling result there is no need to build the thunk. + -- In case of primitives that are functions without formals and a + -- controlling result there is no need to build the thunk. if not Present (First_Formal (Target)) then pragma Assert (Ekind (Target) = E_Function @@ -1477,8 +1477,8 @@ package body Exp_Disp is -- of the controlling formal is the covered interface type (instead of -- the target tagged type). Done to avoid problems with discriminated -- tagged types because, if the controlling type has discriminants with - -- default values, then the type conversions done inside the body of the - -- thunk (after the displacement of the pointer to the base of the + -- default values, then the type conversions done inside the body of + -- the thunk (after the displacement of the pointer to the base of the -- actual object) generate code that modify its contents. -- Note: This special management is not done for predefined primitives @@ -1493,7 +1493,7 @@ package body Exp_Disp is Ftyp := Etype (Formal); -- Use the interface type as the type of the controlling formal (see - -- comment above) + -- comment above). if not Is_Controlling_Formal (Formal) or else Is_Predefined_Dispatching_Operation (Prim) @@ -1547,7 +1547,6 @@ package body Exp_Disp is and then Ftyp = Controlling_Typ then -- Generate: - -- type T is access all <<type of the target formal>> -- S : Storage_Offset := Storage_Offset!(Formal) -- - Offset_To_Top (address!(Formal)) @@ -1608,8 +1607,8 @@ package body Exp_Disp is New_Reference_To (Defining_Identifier (Decl_1), Loc))); elsif Ftyp = Controlling_Typ then - -- Generate: + -- Generate: -- S1 : Storage_Offset := Storage_Offset!(Formal'Address) -- - Offset_To_Top (Formal'Address) -- S2 : Addr_Ptr := Addr_Ptr!(S1) @@ -1690,6 +1689,8 @@ package body Exp_Disp is Set_Is_Thunk (Thunk_Id); + -- Procedure case + if Ekind (Target) = E_Procedure then Thunk_Code := Make_Subprogram_Body (Loc, @@ -1705,8 +1706,9 @@ package body Exp_Disp is Name => New_Occurrence_Of (Target, Loc), Parameter_Associations => Actuals)))); - else pragma Assert (Ekind (Target) = E_Function); + -- Function case + else pragma Assert (Ekind (Target) = E_Function); Thunk_Code := Make_Subprogram_Body (Loc, Specification => diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 8d246759e48..6ab6821a63d 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -1807,12 +1807,14 @@ begin Element : Package_Element; - Default_Switches_Array : Array_Element_Id; + Switches_Array : Array_Element_Id; The_Switches : Prj.Variable_Value; Current : Prj.String_List_Id; The_String : String_Element; + Main : String_Access := null; + begin if Pkg /= No_Package then Element := Project_Tree.Packages.Table (Pkg); @@ -1838,8 +1840,37 @@ begin -- name of the programming language. else + -- First check if there is a single main + + for J in 1 .. Last_Switches.Last loop + if Last_Switches.Table (J) (1) /= '-' then + if Main = null then + Main := Last_Switches.Table (J); + + else + Main := null; + exit; + end if; + end if; + end loop; + + if Main /= null then + Switches_Array := + Prj.Util.Value_Of + (Name => Name_Switches, + In_Arrays => Element.Decl.Arrays, + In_Tree => Project_Tree); + Name_Len := 0; + Add_Str_To_Name_Buffer (Main.all); + The_Switches := Prj.Util.Value_Of + (Index => Name_Find, + Src_Index => 0, + In_Array => Switches_Array, + In_Tree => Project_Tree); + end if; + if The_Switches.Kind = Prj.Undefined then - Default_Switches_Array := + Switches_Array := Prj.Util.Value_Of (Name => Name_Default_Switches, In_Arrays => Element.Decl.Arrays, @@ -1847,7 +1878,7 @@ begin The_Switches := Prj.Util.Value_Of (Index => Name_Ada, Src_Index => 0, - In_Array => Default_Switches_Array, + In_Array => Switches_Array, In_Tree => Project_Tree); end if; end if; diff --git a/gcc/ada/par-prag.adb b/gcc/ada/par-prag.adb index 8d823cedd61..9b5b0ab76a3 100644 --- a/gcc/ada/par-prag.adb +++ b/gcc/ada/par-prag.adb @@ -1081,6 +1081,7 @@ begin Pragma_Convention | Pragma_Debug_Policy | Pragma_Detect_Blocking | + Pragma_Dimension | Pragma_Discard_Names | Pragma_Eliminate | Pragma_Elaborate | diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 31799333ede..29b4cdf7db6 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6490,6 +6490,24 @@ package body Sem_Prag is Check_Valid_Configuration_Pragma; Detect_Blocking := True; + --------------- + -- Dimension -- + --------------- + + when Pragma_Dimension => + GNAT_Pragma; + Check_Arg_Count (4); + Check_No_Identifiers; + Check_Arg_Is_Local_Name (Arg1); + + if not Is_Type (Arg1) then + Error_Pragma ("first argument for pragma% must be subtype"); + end if; + + Check_Arg_Is_Static_Expression (Arg2, Standard_Integer); + Check_Arg_Is_Static_Expression (Arg3, Standard_Integer); + Check_Arg_Is_Static_Expression (Arg4, Standard_Integer); + ------------------- -- Discard_Names -- ------------------- @@ -12450,14 +12468,13 @@ package body Sem_Prag is ----------------------------------------- -- This function makes use of the following static table which indicates - -- whether a given pragma is significant. A value of -1 in this table - -- indicates that the reference is significant. A value of zero indicates - -- than appearance as any argument is insignificant, a positive value - -- indicates that appearance in that parameter position is significant. + -- whether a given pragma is significant. - -- A value of 99 flags a special case requiring a special check (this is - -- used for cases not covered by this standard encoding, e.g. pragma Check - -- where the first argument is not significant, but the others are). + -- -1 indicates that references in any argument position are significant + -- 0 indicates that appearence in any argument is not significant + -- +n indicates that appearence as argument n is significant, but all + -- other arguments are not significant + -- 99 special processing required (e.g. for pragma Check) Sig_Flags : constant array (Pragma_Id) of Int := (Pragma_AST_Entry => -1, @@ -12498,6 +12515,7 @@ package body Sem_Prag is Pragma_Debug => -1, Pragma_Debug_Policy => 0, Pragma_Detect_Blocking => -1, + Pragma_Dimension => -1, Pragma_Discard_Names => 0, Pragma_Elaborate => -1, Pragma_Elaborate_All => -1, diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index d906caf52d2..89bbe4c7e40 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -428,6 +428,7 @@ package Snames is Name_CPP_Virtual : constant Name_Id := N + $; -- GNAT Name_CPP_Vtable : constant Name_Id := N + $; -- GNAT Name_Debug : constant Name_Id := N + $; -- GNAT + Name_Dimension : constant Name_Id := N + $; -- GNAT Name_Elaborate : constant Name_Id := N + $; -- Ada 83 Name_Elaborate_All : constant Name_Id := N + $; Name_Elaborate_Body : constant Name_Id := N + $; @@ -1494,6 +1495,7 @@ package Snames is Pragma_CPP_Virtual, Pragma_CPP_Vtable, Pragma_Debug, + Pragma_Dimension, Pragma_Elaborate, Pragma_Elaborate_All, Pragma_Elaborate_Body, |