From 3568e5542f2c0d54d8ad3bc4d429cb2335bcec26 Mon Sep 17 00:00:00 2001 From: charlet Date: Thu, 7 Oct 2010 09:08:36 +0000 Subject: [PATCH] 2010-10-07 Ed Schonberg * par-ch5.adb (P_Sequence_Of_Statements): In Ada2012 a label can end a sequence of statements. 2010-10-07 Vincent Celier * gnatcmd.adb (Check_Files): Only add a .ci files if it exists 2010-10-07 Javier Miranda * a-tags.ads, a-tags.adb (Type_Is_Abstract): New subprogram. * rtsfind.ads (RE_Type_Is_Abstract): New entity. * exp_disp.adb (Make_DT): Initialize TSD component Type_Is_Abstract. 2010-10-07 Arnaud Charlet * sem_ch12.adb (Mark_Context): Removed, no longer needed. (Analyze_Package_Instantiation): No longer analyze systematically a generic body in CodePeer mode. * freeze.adb, sem_attr.adb: Update comments. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165081 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/ada/ChangeLog | 22 +++++++++ gcc/ada/a-tags.adb | 20 +++++++- gcc/ada/a-tags.ads | 8 +++ gcc/ada/exp_disp.adb | 17 +++++++ gcc/ada/freeze.adb | 4 +- gcc/ada/gnatcmd.adb | 18 +++++-- gcc/ada/par-ch5.adb | 25 ++++++++-- gcc/ada/rtsfind.ads | 2 + gcc/ada/sem_attr.adb | 9 ++-- gcc/ada/sem_ch12.adb | 137 +-------------------------------------------------- 10 files changed, 110 insertions(+), 152 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 679a335..cf3c16d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,25 @@ +2010-10-07 Ed Schonberg + + * par-ch5.adb (P_Sequence_Of_Statements): In Ada2012 a label can end a + sequence of statements. + +2010-10-07 Vincent Celier + + * gnatcmd.adb (Check_Files): Only add a .ci files if it exists + +2010-10-07 Javier Miranda + + * a-tags.ads, a-tags.adb (Type_Is_Abstract): New subprogram. + * rtsfind.ads (RE_Type_Is_Abstract): New entity. + * exp_disp.adb (Make_DT): Initialize TSD component Type_Is_Abstract. + +2010-10-07 Arnaud Charlet + + * sem_ch12.adb (Mark_Context): Removed, no longer needed. + (Analyze_Package_Instantiation): No longer analyze systematically a + generic body in CodePeer mode. + * freeze.adb, sem_attr.adb: Update comments. + 2010-10-05 Robert Dewar * par-ch5.adb (Test_Statement_Required): Allow all pragmas in Ada 2012 diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb index 07b8e22..6f6a8aa 100644 --- a/gcc/ada/a-tags.adb +++ b/gcc/ada/a-tags.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -949,6 +949,24 @@ package body Ada.Tags is SSD (T).SSD_Table (Position).Kind := Value; end Set_Prim_Op_Kind; + ---------------------- + -- Type_Is_Abstract -- + ---------------------- + + function Type_Is_Abstract (T : Tag) return Boolean is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + return TSD.Type_Is_Abstract; + end Type_Is_Abstract; + ------------------------ -- Wide_Expanded_Name -- ------------------------ diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads index 7ef214b..e03d58d 100644 --- a/gcc/ada/a-tags.ads +++ b/gcc/ada/a-tags.ads @@ -75,6 +75,9 @@ package Ada.Tags is function Interface_Ancestor_Tags (T : Tag) return Tag_Array; pragma Ada_05 (Interface_Ancestor_Tags); + function Type_Is_Abstract (T : Tag) return Boolean; + pragma Ada_05 (Type_Is_Abstract); + Tag_Error : exception; private @@ -103,6 +106,8 @@ private -- +-------------------+ -- | transportable | -- +-------------------+ + -- | type_is_abstract | + -- +-------------------+ -- | rec ctrler offset | -- +-------------------+ -- | Ifaces_Table ---> Interface Data @@ -280,6 +285,9 @@ private -- for being used in remote calls as actuals for classwide formals or as -- return values for classwide functions. + Type_Is_Abstract : Boolean; + -- True if the type is abstract (Ada 2012: AI05-0173) + RC_Offset : SSE.Storage_Offset; -- Controller Offset: Used to give support to tagged controlled objects -- (see Get_Deep_Controller at s-finimp) diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index b5a4642..7e0cba5 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -4679,6 +4679,7 @@ package body Exp_Disp is -- External_Tag => Cstring_Ptr!(Exname'Address)) -- HT_Link => HT_Link'Address, -- Transportable => <>, + -- Type_Is_Abstract => <>, -- RC_Offset => <>, -- [ Size_Func => Size_Prim'Access ] -- [ Interfaces_Table => <> ] @@ -4945,6 +4946,22 @@ package body Exp_Disp is New_Occurrence_Of (Transportable, Loc)); end; + -- Type_Is_Abstract (Ada 2012: AI05-0173). This functionality is + -- not available in the HIE runtime. + + if RTE_Record_Component_Available (RE_Type_Is_Abstract) then + declare + Type_Is_Abstract : Entity_Id; + + begin + Type_Is_Abstract := + Boolean_Literals (Is_Abstract_Type (Typ)); + + Append_To (TSD_Aggr_List, + New_Occurrence_Of (Type_Is_Abstract, Loc)); + end; + end if; + -- RC_Offset: These are the valid values and their meaning: -- >0: For simple types with controlled components is diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index bda6e79..ff32684 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -2249,7 +2249,9 @@ package body Freeze is and then Esize (Rec) >= Scalar_Component_Total_RM_Size -- Never do implicit packing in CodePeer mode since we don't do - -- any packing ever in this mode (why not???) + -- any packing in this mode, since this generates over-complex + -- code that confuses CodePeer, and in general, CodePeer does not + -- care about the internal representation of objects. and then not CodePeer_Mode then diff --git a/gcc/ada/gnatcmd.adb b/gcc/ada/gnatcmd.adb index 855a08d..a91653c 100644 --- a/gcc/ada/gnatcmd.adb +++ b/gcc/ada/gnatcmd.adb @@ -377,6 +377,7 @@ procedure GNATCmd is declare Proj : Project_List; + File : String_Access; begin -- Gnatstack needs to add the .ci file for the binder generated @@ -389,7 +390,6 @@ procedure GNATCmd is if Check_Project (Proj.Project, Project) then declare Main : String_List_Id; - File : String_Access; begin -- Include binder generated files for main programs @@ -541,8 +541,7 @@ procedure GNATCmd is end if; if not Subunit then - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := + File := new String' (Get_Name_String (Unit.File_Names @@ -551,6 +550,11 @@ procedure GNATCmd is (Get_Name_String (Unit.File_Names (Impl).Display_File), "ci")); + + if Is_Regular_File (File.all) then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := File; + end if; end if; end if; @@ -562,8 +566,7 @@ procedure GNATCmd is if Check_Project (Unit.File_Names (Spec).Project, Project) then - Last_Switches.Increment_Last; - Last_Switches.Table (Last_Switches.Last) := + File := new String' (Get_Name_String (Unit.File_Names @@ -572,6 +575,11 @@ procedure GNATCmd is MLib.Fil.Ext_To (Get_Name_String (Unit.File_Names (Spec).File), "ci")); + + if Is_Regular_File (File.all) then + Last_Switches.Increment_Last; + Last_Switches.Table (Last_Switches.Last) := File; + end if; end if; end if; diff --git a/gcc/ada/par-ch5.adb b/gcc/ada/par-ch5.adb index 428dc78..f18197e 100644 --- a/gcc/ada/par-ch5.adb +++ b/gcc/ada/par-ch5.adb @@ -83,7 +83,8 @@ package body Ch5 is -- 5.1 Sequence of Statements -- --------------------------------- - -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} + -- SEQUENCE_OF_STATEMENTS ::= STATEMENT {STATEMENT} {LABEL} + -- Note: the final label is an Ada2012 addition. -- STATEMENT ::= -- {LABEL} SIMPLE_STATEMENT | {LABEL} COMPOUND_STATEMENT @@ -149,6 +150,12 @@ package body Ch5 is -- is required. It is initialized from the Sreq flag, and modified as -- statements are scanned (a statement turns it off, and a label turns -- it back on again since a statement must follow a label). + -- Note : this final requirement is lifted in Ada2012. + + Statement_Seen : Boolean; + -- In Ada2012 a label can end a sequence of statements, but the sequence + -- cannot contain only labels. This flag is set whenever a label is + -- encountered, to enforce this rule at the end of a sequence. Declaration_Found : Boolean := False; -- This flag is set True if a declaration is encountered, so that the @@ -222,8 +229,10 @@ package body Ch5 is if Ada_Version >= Ada_2012 and then not Is_Empty_List (Statement_List) - and then (Nkind (Last (Statement_List)) = N_Label - or else All_Pragmas) + and then + ((Nkind (Last (Statement_List)) = N_Label + and then Statement_Seen) + or else All_Pragmas) then declare Null_Stm : constant Node_Id := @@ -233,8 +242,6 @@ package body Ch5 is Append_To (Statement_List, Null_Stm); end; - -- All pragmas is OK on - -- If not Ada 2012, or not special case above, give error message else @@ -249,6 +256,7 @@ package body Ch5 is begin Statement_List := New_List; Statement_Required := SS_Flags.Sreq; + Statement_Seen := False; loop Ignore (Tok_Semicolon); @@ -765,8 +773,15 @@ package body Ch5 is Statement_Required := False; -- Label starting with << which must precede real statement + -- Note: in Ada2012, the label may end the sequence. when Tok_Less_Less => + if Present (Last (Statement_List)) + and then Nkind (Last (Statement_List)) /= N_Label + then + Statement_Seen := True; + end if; + Append_To (Statement_List, P_Label); Statement_Required := True; diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index c0744c4..94d76be 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -600,6 +600,7 @@ package Rtsfind is RE_Signature, -- Ada.Tags RE_SSD, -- Ada.Tags RE_TSD, -- Ada.Tags + RE_Type_Is_Abstract, -- Ada.Tags RE_Type_Specific_Data, -- Ada.Tags RE_Register_Interface_Offset, -- Ada.Tags RE_Register_Tag, -- Ada.Tags @@ -1770,6 +1771,7 @@ package Rtsfind is RE_Signature => Ada_Tags, RE_SSD => Ada_Tags, RE_TSD => Ada_Tags, + RE_Type_Is_Abstract => Ada_Tags, RE_Type_Specific_Data => Ada_Tags, RE_Register_Interface_Offset => Ada_Tags, RE_Register_Tag => Ada_Tags, diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 71730be..babdfde 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -7950,10 +7950,11 @@ package body Sem_Attr is -- been caught by the compilation of the generic unit. -- Note that we relax this check in CodePeer mode for - -- compatibility with legacy code. - - -- This seems an odd decision??? Why should codepeer mode - -- have a different notion of legality from the compiler??? + -- compatibility with legacy code, since CodePeer is an + -- Ada source code analyzer, not a strict compiler. + -- ??? Note that a better approach would be to have a + -- separate switch to relax this rule, and enable this + -- switch in CodePeer mode. elsif Attr_Id = Attribute_Access and then not CodePeer_Mode diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5f258f2..7b8846f 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -475,12 +475,6 @@ package body Sem_Ch12 is -- of generic formals of a generic package declared with a box or with -- partial parametrization. - procedure Mark_Context (Inst_Decl : Node_Id; Gen_Decl : Node_Id); - -- If the generic unit comes from a different unit, indicate that the - -- unit that contains the instance depends on the body that contains - -- the generic body. Used to determine a more precise dependency graph - -- for use by CodePeer. - procedure Set_Instance_Env (Gen_Unit : Entity_Id; Act_Unit : Entity_Id); @@ -3237,8 +3231,7 @@ package body Sem_Ch12 is or else Enclosing_Body_Present or else Present (Corresponding_Body (Gen_Decl))) and then (Is_In_Main_Unit (N) - or else Might_Inline_Subp - or else CodePeer_Mode) + or else Might_Inline_Subp) and then not Is_Actual_Pack and then not Inline_Now and then (Operating_Mode = Generate_Code @@ -8609,8 +8602,6 @@ package body Sem_Ch12 is Gen_Body_Id := Corresponding_Body (Gen_Decl); end if; - Mark_Context (Act_Decl, Gen_Decl); - -- Establish global variable for sloc adjustment and for error recovery Instantiation_Node := Inst_Node; @@ -8893,7 +8884,6 @@ package body Sem_Ch12 is if Present (Gen_Body_Id) then Gen_Body := Unit_Declaration_Node (Gen_Body_Id); - Mark_Context (Inst_Node, Gen_Decl); if Nkind (Gen_Body) = N_Subprogram_Body_Stub then @@ -10408,131 +10398,6 @@ package body Sem_Ch12 is end if; end Is_Generic_Formal; - ------------------ - -- Mark_Context -- - ------------------ - - procedure Mark_Context (Inst_Decl : Node_Id; Gen_Decl : Node_Id) is - Loc : constant Source_Ptr := Sloc (Inst_Decl); - Inst_CU : constant Unit_Number_Type := Get_Code_Unit (Inst_Decl); - - -- Note that we use Get_Code_Unit to determine the position of the - -- instantiation, because it may itself appear within another instance - -- and we need to mark the context of the enclosing unit, not that of - -- the unit that contains the generic. - - Gen_CU : constant Unit_Number_Type := Get_Source_Unit (Gen_Decl); - Inst : Entity_Id; - Clause : Node_Id; - Scop : Entity_Id; - - procedure Add_Implicit_With (CU : Unit_Number_Type); - -- If a generic is instantiated in the direct or indirect context of - -- the current unit, but there is no with_clause for it in the current - -- context, add a with_clause for it to indicate that the body of the - -- generic should be examined before the current unit. - - procedure Add_Implicit_With (CU : Unit_Number_Type) is - Withn : constant Node_Id := - Make_With_Clause (Loc, - Name => New_Occurrence_Of (Cunit_Entity (CU), Loc)); - begin - Set_Implicit_With (Withn); - Set_Library_Unit (Withn, Cunit (CU)); - Set_Withed_Body (Withn, Cunit (CU)); - Prepend (Withn, Context_Items (Cunit (Inst_CU))); - end Add_Implicit_With; - - begin - -- This is only relevant when compiling for CodePeer. In what follows, - -- C is the current unit containing the instance body, and G is the - -- generic unit in that instance. - - if not CodePeer_Mode then - return; - end if; - - -- Nothing to do if G is local. - - if Inst_CU = Gen_CU then - return; - end if; - - -- If G is itself declared within an instance, indicate that the - -- generic body of that instance is also needed by C. This must be - -- done recursively. - - Scop := Scope (Defining_Entity (Gen_Decl)); - - while Is_Generic_Instance (Scop) - and then Ekind (Scop) = E_Package - loop - Mark_Context - (Inst_Decl, - Unit_Declaration_Node - (Generic_Parent - (Specification (Unit_Declaration_Node (Scop))))); - Scop := Scope (Scop); - end loop; - - -- Add references to other generic units in the context of G, because - -- they may be instantiated within G, and their bodies needed by C. - - Clause := First (Context_Items (Cunit (Gen_CU))); - - while Present (Clause) loop - if Nkind (Clause) = N_With_Clause - and then - Nkind (Unit (Library_Unit (Clause))) - = N_Generic_Package_Declaration - then - Add_Implicit_With (Get_Source_Unit (Library_Unit (Clause))); - end if; - - Next (Clause); - end loop; - - -- Now indicate that the body of G is needed by C - - Clause := First (Context_Items (Cunit (Inst_CU))); - while Present (Clause) loop - if Nkind (Clause) = N_With_Clause - and then Library_Unit (Clause) = Cunit (Gen_CU) - then - Set_Withed_Body (Clause, Cunit (Gen_CU)); - return; - end if; - - Next (Clause); - end loop; - - -- If the with-clause for G is not in the context of C, it may appear in - -- some ancestor of C. - - Inst := Cunit_Entity (Inst_CU); - while Is_Child_Unit (Inst) loop - Inst := Scope (Inst); - - Clause := - First (Context_Items (Parent (Unit_Declaration_Node (Inst)))); - while Present (Clause) loop - if Nkind (Clause) = N_With_Clause - and then Library_Unit (Clause) = Cunit (Gen_CU) - then - Set_Withed_Body (Clause, Cunit (Gen_CU)); - return; - end if; - - Next (Clause); - end loop; - end loop; - - -- If not found, G comes from an instance elsewhere in the context. Make - -- the dependence explicit in the context of C. - - Add_Implicit_With (Gen_CU); - end Mark_Context; - --------------------- -- Is_In_Main_Unit -- --------------------- -- 2.7.4