From: Arnaud Charlet Date: Wed, 21 Dec 2011 13:51:03 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=4172a8e33873fc9c93121fccfa97d5d22aff1537;p=gcc.git [multiple changes] 2011-12-21 Vincent Celier * prj-nmsc.adb (Report_No_Sources): Remove argument Lang. Report no sources even for languages that are not allowed. (Add_Source): Get the source even when the language is not allowed. 2011-12-21 Robert Dewar * sem_ch6.adb (Process_Formals): Add defensive code. 2011-12-21 Ed Schonberg * sem_ch7.adb, sem_ch13.adb (Analyze_Package_Specification): Build the invariant procedure of a type declaration that is a completion and has aspect specifications. (Build_Invariant_Procedure): If the procedure is built for a type declaration that is a completion, analyze body expliitly because all private declarations have been already analyzed. 2011-12-21 Claire Dross * a-cfdlli.adb, a-cfhase.adb, a-cforma.adb, a-cforse.adb, a-cofove.adb: Minor reformating on formal containers 2011-12-21 Vincent Celier * makeutl.adb (Mains.Complete_Mains.Do_Complete): Remove any main that is not in the list of restricted languages. (Insert_Project_Sources.Do_Insert): Only add sources of languages in the list of restricted languages. 2011-12-21 Ed Schonberg * sem_res.adb (Valid_Conversion): A type conversion is valid when the target type is an anonymous access type and the operand is a rewriting of an allocator. The conversion is typically inserted when the designated type is an interface. 2011-12-21 Ed Schonberg * exp_ch9.adb (Establish_Task_Master): If the enclosing block has no declarations, create new declarative list for it. 2011-12-21 Matthew Heaney * a-rbtgbk.adb (Generic_Conditional_Insert): Fixed incorrect comment. From-SVN: r182586 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index be29ee2e8a1..64de1d4b417 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2011-12-21 Vincent Celier + + * prj-nmsc.adb (Report_No_Sources): Remove argument Lang. Report + no sources even for languages that are not allowed. + (Add_Source): Get the source even when the language is not allowed. + +2011-12-21 Robert Dewar + + * sem_ch6.adb (Process_Formals): Add defensive code. + +2011-12-21 Ed Schonberg + + * sem_ch7.adb, sem_ch13.adb (Analyze_Package_Specification): Build the + invariant procedure of a type declaration that is a completion and has + aspect specifications. + (Build_Invariant_Procedure): If the procedure is built for a + type declaration that is a completion, analyze body expliitly + because all private declarations have been already analyzed. + +2011-12-21 Claire Dross + + * a-cfdlli.adb, a-cfhase.adb, a-cforma.adb, a-cforse.adb, + a-cofove.adb: Minor reformating on formal containers + +2011-12-21 Vincent Celier + + * makeutl.adb (Mains.Complete_Mains.Do_Complete): Remove + any main that is not in the list of restricted languages. + (Insert_Project_Sources.Do_Insert): Only add sources of languages + in the list of restricted languages. + +2011-12-21 Ed Schonberg + + * sem_res.adb (Valid_Conversion): A type conversion is valid when + the target type is an anonymous access type and the operand is a + rewriting of an allocator. The conversion is typically inserted + when the designated type is an interface. + +2011-12-21 Ed Schonberg + + * exp_ch9.adb (Establish_Task_Master): If the enclosing block + has no declarations, create new declarative list for it. + +2011-12-21 Matthew Heaney + + * a-rbtgbk.adb (Generic_Conditional_Insert): Fixed incorrect comment. + 2011-12-21 Yannick Moy * sem_ch13.adb (Analyze_Attribute_Definition_Clause): Do not diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb index 80e6fc0e437..404c66359db 100644 --- a/gcc/ada/a-cfdlli.adb +++ b/gcc/ada/a-cfdlli.adb @@ -1403,15 +1403,7 @@ package body Ada.Containers.Formal_Doubly_Linked_Lists is pragma Assert (Vet (Container, Position), "bad cursor in Replace_Element"); - declare - N : Node_Array renames Container.Nodes; - begin - N (Position.Node).Element := New_Item; - end; - - -- Above is peculiar, why not simply - -- Container.Nodes (Position.Node).Element := New_Item ??? - + Container.Nodes (Position.Node).Element := New_Item; end Replace_Element; ---------------------- diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb index 164433eb3b7..fe6706bcd43 100644 --- a/gcc/ada/a-cfhase.adb +++ b/gcc/ada/a-cfhase.adb @@ -1471,7 +1471,6 @@ package body Ada.Containers.Formal_Hashed_Sets is -- Start of processing for Union begin - if Target'Address = Source'Address then return; end if; @@ -1646,7 +1645,6 @@ package body Ada.Containers.Formal_Hashed_Sets is X : Count_Type; begin - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); if X = 0 then @@ -1768,7 +1766,6 @@ package body Ada.Containers.Formal_Hashed_Sets is N : Nodes_Type renames Container.Nodes; begin - if Position.Node = 0 then raise Constraint_Error with "Position cursor equals No_Element"; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb index d102a3d7375..ce361a1a2b0 100644 --- a/gcc/ada/a-cforma.adb +++ b/gcc/ada/a-cforma.adb @@ -1025,7 +1025,6 @@ package body Ada.Containers.Formal_Ordered_Maps is Element : Element_Type)) is begin - if not Has_Element (Container, Position) then raise Constraint_Error with "Position cursor of Query_Element has no element"; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb index 794b47baf9c..9872f2ce30e 100644 --- a/gcc/ada/a-cforse.adb +++ b/gcc/ada/a-cforse.adb @@ -452,11 +452,7 @@ package body Ada.Containers.Formal_Ordered_Sets is pragma Assert (Vet (Container, Position.Node), "bad cursor in Element"); - declare - N : Tree_Types.Nodes_Type renames Container.Nodes; - begin - return N (Position.Node).Element; - end; + return Container.Nodes (Position.Node).Element; end Element; ------------------------- diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb index 3533c2a4096..8900e054cb8 100644 --- a/gcc/ada/a-cofove.adb +++ b/gcc/ada/a-cofove.adb @@ -540,7 +540,6 @@ package body Ada.Containers.Formal_Vectors is Last : constant Index_Type := Last_Index (Container); begin - K := Count_Type (Int (Index) - Int (No_Index)); for Indx in Index .. Last loop if Get_Element (Container, K) = Item then @@ -628,7 +627,6 @@ package body Ada.Containers.Formal_Vectors is procedure Merge (Target, Source : in out Vector) is begin - declare TA : Elements_Array renames Target.Elements; SA : Elements_Array renames Source.Elements; @@ -1326,7 +1324,6 @@ package body Ada.Containers.Formal_Vectors is N : constant Count_Type := Length (Source); begin - if Target'Address = Source'Address then return; end if; @@ -1543,7 +1540,6 @@ package body Ada.Containers.Formal_Vectors is New_Item : Element_Type) is begin - if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; @@ -1568,7 +1564,6 @@ package body Ada.Containers.Formal_Vectors is New_Item : Element_Type) is begin - if not Position.Valid then raise Constraint_Error with "Position cursor has no element"; end if; @@ -1932,7 +1927,6 @@ package body Ada.Containers.Formal_Vectors is L : Natural renames Container.Lock; begin - if Index > Container.Last then raise Constraint_Error with "Index is out of range"; end if; diff --git a/gcc/ada/a-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb index b12ae841076..e270abf1402 100644 --- a/gcc/ada/a-rbtgbk.adb +++ b/gcc/ada/a-rbtgbk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2011, 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- -- @@ -140,8 +140,22 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is N : Nodes_Type renames Tree.Nodes; begin - Y := 0; + -- This is a "conditional" insertion, meaning that the insertion request + -- can "fail" in the sense that no new node is created. If the Key is + -- equivalent to an existing node, then we return the existing node and + -- Inserted is set to False. Otherwise, we allocate a new node (via + -- Insert_Post) and Inserted is set to True. + + -- Note that we are testing for equivalence here, not equality. Key must + -- be strictly less than its next neighbor, and strictly greater than + -- its previous neighbor, in order for the conditional insertion to + -- succeed. + + -- We search the tree to find the nearest neighbor of Key, which is + -- either the smallest node greater than Key (Inserted is True), or the + -- largest node less or equivalent to Key (Inserted is False). + Y := 0; X := Tree.Root; Inserted := True; while X /= 0 loop @@ -150,33 +164,50 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is X := (if Inserted then Ops.Left (N (X)) else Ops.Right (N (X))); end loop; - -- If Inserted is True, then this means either that Tree is - -- empty, or there was a least one node (strictly) greater than - -- Key. Otherwise, it means that Key is equal to or greater than - -- every node. - if Inserted then + + -- Either Tree is empty, or Key is less than Y. If Y is the first + -- node in the tree, then there are no other nodes that we need to + -- search for, and we insert a new node into the tree. + if Y = Tree.First then Insert_Post (Tree, Y, True, Node); return; end if; + -- Y is the next nearest-neighbor of Key. We know that Key is not + -- equivalent to Y (because Key is strictly less than Y), so we move + -- to the previous node, the nearest-neighbor just smaller or + -- equivalent to Key. + Node := Ops.Previous (Tree, Y); else + -- Y is the previous nearest-neighbor of Key. We know that Key is not + -- less than Y, which means either that Key is equivalent to Y, or + -- greater than Y. + Node := Y; end if; - -- Here Node has a value that is less than or equal to Key. We - -- now have to resolve whether Key is equal to or greater than - -- Node, which determines whether the insertion succeeds. + -- Key is equivalent to or greater than Node. We must resolve which is + -- the case, to determine whether the conditional insertion succeeds. if Is_Greater_Key_Node (Key, N (Node)) then + + -- Key is strictly greater than Node, which means that Key is not + -- equivalent to Node. In this case, the insertion succeeds, and we + -- insert a new node into the tree. + Insert_Post (Tree, Y, Inserted, Node); Inserted := True; return; end if; + -- Key is equivalent to Node. This is a conditional insertion, so we do + -- not insert a new node in this case. We return the existing node and + -- report that no insertion has occurred. + Inserted := False; end Generic_Conditional_Insert; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 8305278e8d8..8cd39b9a1f1 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -5086,10 +5086,21 @@ package body Exp_Ch9 is procedure Establish_Task_Master (N : Node_Id) is Call : Node_Id; + begin if Restriction_Active (No_Task_Hierarchy) = False then Call := Build_Runtime_Call (Sloc (N), RE_Enter_Master); - Prepend_To (Declarations (N), Call); + + -- The block may have no declarations, and nevertheless be a task + -- master, if it contains a call that may return an object that + -- contains tasks. + + if No (Declarations (N)) then + Set_Declarations (N, New_List (Call)); + else + Prepend_To (Declarations (N), Call); + end if; + Analyze (Call); end if; end Establish_Task_Master; diff --git a/gcc/ada/makeutl.adb b/gcc/ada/makeutl.adb index f09c0ad9d6b..119bcbd2a1d 100644 --- a/gcc/ada/makeutl.adb +++ b/gcc/ada/makeutl.adb @@ -1539,6 +1539,8 @@ package body Makeutl is procedure Do_Complete (Project : Project_Id; Tree : Project_Tree_Ref) is + J : Integer; + begin if Mains.Number_Of_Mains (Tree) > 0 or else Mains.Count_Of_Mains_With_No_Tree > 0 @@ -1547,7 +1549,8 @@ package body Makeutl is -- files we will be adding extra files at the end, and there's -- no need to process them in turn. - for J in reverse Names.First .. Names.Last loop + J := Names.Last; + loop declare File : Main_Info := Names.Table (J); Main_Id : File_Name_Type := File.File; @@ -1637,35 +1640,47 @@ package body Makeutl is end if; if Source /= No_Source then + if not Is_Allowed_Language + (Source.Language.Name) + then + -- Remove any main that is not in the list of + -- restricted languages. - -- If we have found a multi-unit source file but - -- did not specify an index initially, we'll need - -- to compile all the units from the same source - -- file. + Names.Table (J .. Names.Last - 1) := + Names.Table (J + 1 .. Names.Last); + Names.Set_Last (Names.Last - 1); - if Source.Index /= 0 and then File.Index = 0 then - Add_Multi_Unit_Sources (File.Tree, Source); - end if; + else + -- If we have found a multi-unit source file but + -- did not specify an index initially, we'll + -- need to compile all the units from the same + -- source file. - -- Now update the original Main, otherwise it will - -- be reported as not found. + if Source.Index /= 0 and then File.Index = 0 then + Add_Multi_Unit_Sources (File.Tree, Source); + end if; - Debug_Output - ("found main in project", Source.Project.Name); - Names.Table (J).File := Source.File; - Names.Table (J).Project := Source.Project; + -- Now update the original Main, otherwise it + -- will be reported as not found. - if Names.Table (J).Tree = null then - Names.Table (J).Tree := File.Tree; + Debug_Output + ("found main in project", Source.Project.Name); + Names.Table (J).File := Source.File; + Names.Table (J).Project := Source.Project; - Builder_Data (File.Tree).Number_Of_Mains := - Builder_Data (File.Tree).Number_Of_Mains + 1; - Mains.Count_Of_Mains_With_No_Tree := - Mains.Count_Of_Mains_With_No_Tree - 1; - end if; + if Names.Table (J).Tree = null then + Names.Table (J).Tree := File.Tree; - Names.Table (J).Source := Source; - Names.Table (J).Index := Source.Index; + Builder_Data (File.Tree).Number_Of_Mains := + Builder_Data (File.Tree).Number_Of_Mains + + 1; + Mains.Count_Of_Mains_With_No_Tree := + Mains.Count_Of_Mains_With_No_Tree - 1; + end if; + + Names.Table (J).Source := Source; + Names.Table (J).Index := Source.Index; + end if; elsif File.Location /= No_Location then @@ -1684,6 +1699,9 @@ package body Makeutl is end if; end if; end; + + J := J - 1; + exit when J < Names.First; end loop; end if; @@ -2781,10 +2799,11 @@ package body Makeutl is Source := Prj.Element (Iter); exit when Source = No_Source; - if Is_Compilable (Source) + if Is_Allowed_Language (Source.Language.Name) + and then Is_Compilable (Source) and then (All_Projects - or else Is_Extending (Project, Source.Project)) + or else Is_Extending (Project, Source.Project)) and then not Source.Locally_Removed and then Source.Replaced_By = No_Source and then diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 3e86850ff0f..c3cb4b6e351 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -486,7 +486,6 @@ package body Prj.Nmsc is procedure Report_No_Sources (Project : Project_Id; - Lang : Name_Id; Lang_Name : String; Data : Tree_Processing_Data; Location : Source_Ptr; @@ -643,13 +642,6 @@ package body Prj.Nmsc is Source_To_Replace : Source_Id := No_Source; begin - -- Nothing to do if the language is not one of the restricted ones - - if not Is_Allowed_Language (Lang_Id.Name) then - Id := No_Source; - return; - end if; - -- Check if the same file name or unit is used in the prj tree Add_Src := True; @@ -7809,7 +7801,6 @@ package body Prj.Nmsc is if Source = No_Source then Report_No_Sources (Project.Project, - Language.Name, Get_Name_String (Language.Display_Name), Data, Project.Source_List_File_Location, @@ -8256,15 +8247,13 @@ package body Prj.Nmsc is procedure Report_No_Sources (Project : Project_Id; - Lang : Name_Id; Lang_Name : String; Data : Tree_Processing_Data; Location : Source_Ptr; Continuation : Boolean := False) is begin - if Is_Allowed_Language (Lang) then - case Data.Flags.When_No_Sources is + case Data.Flags.When_No_Sources is when Silent => null; @@ -8283,8 +8272,7 @@ package body Prj.Nmsc is Error_Msg (Data.Flags, Msg, Location, Project); end if; end; - end case; - end if; + end case; end Report_No_Sources; ---------------------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index e6b016dcfba..6ffe9f2e15f 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4738,6 +4738,14 @@ package body Sem_Ch13 is -- (this is an error that will be caught elsewhere); Append_To (Private_Decls, PBody); + + -- If the invariant appears on the full view of a type, the + -- analysis of the private part is complete, and we must + -- analyze the new body explicitly. + + if In_Private_Part (Current_Scope) then + Analyze (PBody); + end if; end if; end if; end Build_Invariant_Procedure; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 1df37372295..4286c0d7149 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9552,6 +9552,12 @@ package body Sem_Ch6 is Num_Out_Params := Num_Out_Params + 1; end if; + -- Skip remaining processing if formal type was in error + + if Etype (Formal) = Any_Type or else Error_Posted (Formal) then + goto Next_Parameter; + end if; + -- Force call by reference if aliased if Is_Aliased (Formal) then @@ -9573,6 +9579,7 @@ package body Sem_Ch6 is Set_Mechanism (Formal, By_Reference); end if; + <> Next (Param_Spec); end loop; diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 2f87cf07885..094837be97c 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1378,6 +1378,16 @@ package body Sem_Ch7 is ("full view of & does not have preelaborable initialization", E); end if; + -- An invariant may appear on a full view of a type + + if Is_Type (E) + and then Has_Private_Declaration (E) + and then Nkind (Parent (E)) = N_Full_Type_Declaration + and then Has_Aspects (Parent (E)) + then + Build_Invariant_Procedure (E, N); + end if; + Next_Entity (E); end loop; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index f1724854068..c25a305daab 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -10719,7 +10719,13 @@ package body Sem_Res is -- check is not enforced when within an instance body, since the -- RM requires such cases to be caught at run time. - if Ekind (Target_Type) /= E_Anonymous_Access_Type then + -- If the operand is a rewriting of an allocator no check is needed + -- because there are no accessibility issues. + + if Nkind (Original_Node (N)) = N_Allocator then + null; + + elsif Ekind (Target_Type) /= E_Anonymous_Access_Type then if Type_Access_Level (Opnd_Type) > Deepest_Type_Access_Level (Target_Type) then