From bff469f75fb4941ff4ff923a7b921e179c8f1390 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 26 May 2015 15:37:29 +0200 Subject: [PATCH] [multiple changes] 2015-05-26 Ed Schonberg * sinfo.ads: Minor reformatting. * sem_aux.ads: Clarify use of First_Discriminant. * sem_ch4.adb (Analyze_Explicit_Dereference): The use of a limited view is replaced with the non-limited view in an instance body, where the enclosing unit must have a regular with_clause on the relevant unit. * sem_ch12.adb (Install_Body): Freeze instantation after its body. Remove useless freeze nodes for incomplete actuals to prevent multiple generation of internal operations. (Instantiate_Package_Body): Set sloc of body appropriately when there are incomplete actuals and the instance body is placed in the body of the enclosing unit. * errout.ads: Consistent punctuation, better alignment and trivial typos in comments. * err_vars.ads: Fix typo. 2015-05-26 Eric Botcazou * sem_ch8.adb (Analyze_Object_Renaming): Lift restriction on components of Volatile_Full_Access objects. 2015-05-26 Ed Schonberg * sem_ch6.adb (Is_Non_Overriding_Operation, Get_Generic_Parent_Type): Handle properly the case of a derived scalar type by using the first subtype rather than its generated anonymous base type. 2015-05-26 Eric Botcazou * einfo.adb (Write_Field17_Name): Move E_Incomplete_Subtype case to... (Write_Field19_Name): ...here. From-SVN: r223696 --- gcc/ada/ChangeLog | 36 ++++++++++++++++++++++++++ gcc/ada/einfo.adb | 10 ++++---- gcc/ada/err_vars.ads | 4 +-- gcc/ada/errout.ads | 16 ++++++------ gcc/ada/sem_aux.ads | 3 +++ gcc/ada/sem_ch12.adb | 61 +++++++++++++++++--------------------------- gcc/ada/sem_ch4.adb | 7 +++-- gcc/ada/sem_ch6.adb | 14 +++++++++- gcc/ada/sem_ch8.adb | 19 -------------- gcc/ada/sinfo.ads | 5 ++-- 10 files changed, 98 insertions(+), 77 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 24fc930bbcd..f30ae12eb28 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +2015-05-26 Ed Schonberg + + * sinfo.ads: Minor reformatting. + * sem_aux.ads: Clarify use of First_Discriminant. + * sem_ch4.adb (Analyze_Explicit_Dereference): The use of a limited + view is replaced with the non-limited view in an instance body, + where the enclosing unit must have a regular with_clause on the + relevant unit. + * sem_ch12.adb (Install_Body): Freeze instantation after its + body. Remove useless freeze nodes for incomplete actuals to + prevent multiple generation of internal operations. + (Instantiate_Package_Body): Set sloc of body appropriately when + there are incomplete actuals and the instance body is placed in + the body of the enclosing unit. + * errout.ads: Consistent punctuation, better alignment and trivial + typos in comments. + * err_vars.ads: Fix typo. + +2015-05-26 Eric Botcazou + + * sem_ch8.adb (Analyze_Object_Renaming): Lift restriction on + components of Volatile_Full_Access objects. + +2015-05-26 Ed Schonberg + + * sem_ch6.adb (Is_Non_Overriding_Operation, + Get_Generic_Parent_Type): Handle properly the case of a derived + scalar type by using the first subtype rather than its generated + anonymous base type. + +2015-05-26 Eric Botcazou + + * einfo.adb (Write_Field17_Name): Move E_Incomplete_Subtype + case to... + (Write_Field19_Name): ...here. + 2015-05-26 Ed Schonberg * sem_ch13.adb: sem_ch13.adb (Add_Predicates): Undo analysis diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index bf25bfb1855..eb57b6996d8 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -9484,11 +9484,6 @@ package body Einfo is when Modular_Integer_Kind => Write_Str ("Modulus"); - when E_Incomplete_Subtype => - if From_Limited_With (Id) then - Write_Str ("Non_Limited_View"); - end if; - when E_Component => Write_Str ("Prival"); @@ -9584,6 +9579,11 @@ package body Einfo is E_Incomplete_Type => Write_Str ("Non_Limited_View"); + when E_Incomplete_Subtype => + if From_Limited_With (Id) then + Write_Str ("Non_Limited_View"); + end if; + when E_Array_Type => Write_Str ("Default_Component_Value"); diff --git a/gcc/ada/err_vars.ads b/gcc/ada/err_vars.ads index 48df37e6362..c9beb0ccc30 100644 --- a/gcc/ada/err_vars.ads +++ b/gcc/ada/err_vars.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, 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- -- @@ -57,7 +57,7 @@ package Err_Vars is Error_Msg_Qual_Level : Int := 0; -- Number of levels of qualification required for type name (see the -- description of the } insertion character. Note that this value does - -- note get reset by any Error_Msg call, so the caller is responsible + -- not get reset by any Error_Msg call, so the caller is responsible -- for resetting it. Warn_On_Instance : Boolean := False; diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index f23bed31ff5..8a3f9f25f7a 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ -- This package contains the routines to output error messages. They are --- basically system independent, however in some environments, e.g. when the +-- basically system independent, however, in some environments, e.g. when the -- parser is embedded into an editor, it may be appropriate to replace the -- implementation of this package. @@ -157,8 +157,8 @@ package Errout is -- obtained from the Unit_Name_Type value in Error_Msg_Unit_1 and -- Error_Msg_Unit_2, as provided by Get_Unit_Name_String in package -- Uname. Note that this name includes the postfix (spec) or (body) - -- strings. If this postfix is not required, use the normal % - -- insertion for the unit name. + -- strings. If this postfix is not required, use the normal % insertion + -- for the unit name. -- Insertion character { (Left brace: insert file name from names table) -- The character { is treated similarly to %, except that the input @@ -168,7 +168,7 @@ package Errout is -- insertion is the exact string stored in the names table without -- adjusting the casing. - -- Insertion character * (Asterisk, insert reserved word name) + -- Insertion character * (Asterisk: insert reserved word name) -- The insertion character * is treated exactly like % except that the -- resulting name is cased according to the default conventions for -- reserved words (see package Scans). @@ -221,7 +221,7 @@ package Errout is -- where appropriate the location of its declaration. Special cases -- like "some integer type" are handled appropriately. Only one } is -- allowed in a message, since there is not enough room for two (the - -- insertion can be quite long, including a file name) In addition, if + -- insertion can be quite long, including a file name). In addition, if -- the special global variable Error_Msg_Qual_Level is non-zero, then -- the reference will include up to the given number of levels of -- qualification, using the scope chain. @@ -240,7 +240,7 @@ package Errout is -- A second ^ may occur in the message, in which case it is replaced -- by the decimal conversion of the Uint value in Error_Msg_Uint_2. - -- Insertion character > (Greater Than, run time name) + -- Insertion character > (Greater Than: run time name) -- The character > is replaced by a string of the form (name) if -- Targparm scanned out a Run_Time_Name (see package Targparm for -- details). The name is enclosed in parentheses and output in mixed @@ -372,7 +372,7 @@ package Errout is -- messages are treated as a unit. The \ character must be the first -- character of the message text. - -- Insertion character \\ (Two backslashes, continuation with new line) + -- Insertion character \\ (Two backslashes: continuation with new line) -- This differs from \ only in -gnatjnn mode (Error_Message_Line_Length -- set non-zero). This sequence forces a new line to start even when -- continuations are being gathered into a single message. @@ -480,7 +480,7 @@ package Errout is Error_Msg_Qual_Level : Int renames Err_Vars.Error_Msg_Qual_Level; -- Number of levels of qualification required for type name (see the -- description of the } insertion character). Note that this value does - -- note get reset by any Error_Msg call, so the caller is responsible + -- not get reset by any Error_Msg call, so the caller is responsible -- for resetting it. Error_Msg_Warn : Boolean renames Err_Vars.Error_Msg_Warn; diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index e5e814514f7..5268b011a3a 100644 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -119,6 +119,9 @@ package Sem_Aux is -- First_Entity. The exception arises for tagged types, where the tag -- itself is prepended to the front of the entity chain, so the -- First_Discriminant function steps past the tag if it is present. + -- The caller is responsible for checking that the type has discriminants, + -- so for example it is improper to call this function on a private + -- type with unknown discriminants. function First_Stored_Discriminant (Typ : Entity_Id) return Entity_Id; -- Typ is a type with discriminants. Gives the first discriminant stored diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 266b746a7a7..ecc3a8e0b0c 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -8876,8 +8876,8 @@ package body Sem_Ch12 is -- in the instance body requires the presence of a regular with_clause -- in the enclosing unit, and will fail if this with_clause is missing. -- We place the instance body at the beginning of the enclosing body, - -- which is the unit being compiled, and ensure that freeze nodes for - -- the full views of the incomplete types appear before the instance. + -- which is the unit being compiled. The freeze node for the instance + -- is then placed after the instance body. if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Id)) and then Expander_Active @@ -8892,43 +8892,15 @@ package body Sem_Ch12 is Ensure_Freeze_Node (Act_Id); F_Node := Freeze_Node (Act_Id); if Present (Body_Id) then - Set_Is_Frozen (Act_Id); + Set_Is_Frozen (Act_Id, False); Prepend (Act_Body, Declarations (Parent (Body_Id))); - end if; - - -- Add freeze nodes of formerly incomplete types ahead of - -- the instance body. - - declare - Elmt : Elmt_Id; - F_T : Node_Id; - Typ : Entity_Id; - - begin - Elmt := First_Elmt (Incomplete_Actuals (Act_Id)); - while Present (Elmt) loop - Typ := Node (Elmt); - - if From_Limited_With (Typ) then - Typ := Non_Limited_View (Typ); - end if; - - Ensure_Freeze_Node (Typ); - F_T := Freeze_Node (Typ); - - -- If freeze node is already in the tree, remove it - -- and place ahead of instance body. - - if Is_List_Member (F_T) then - Remove (F_T); - end if; + if Is_List_Member (F_Node) then + Remove (F_Node); + end if; - Prepend (F_T, Declarations (Parent (Body_Id))); - Next_Elmt (Elmt); - end loop; - end; + Insert_After (Act_Body, F_Node); + end if; end; - return; end if; @@ -10794,8 +10766,23 @@ package body Sem_Ch12 is end if; -- Establish global variable for sloc adjustment and for error recovery + -- In the case of an instance body for an instantiation with actuals + -- from a limited view, the instance body is placed at the beginning + -- of the enclosing package body: use the body entity as the source + -- location for nodes of the instance body. - Instantiation_Node := Inst_Node; + if not Is_Empty_Elmt_List (Incomplete_Actuals (Act_Decl_Id)) then + declare + Scop : constant Entity_Id := Scope (Act_Decl_Id); + Body_Id : constant Node_Id := + Corresponding_Body (Unit_Declaration_Node (Scop)); + + begin + Instantiation_Node := Body_Id; + end; + else + Instantiation_Node := Inst_Node; + end if; if Present (Gen_Body_Id) then Save_Env (Gen_Unit, Act_Decl_Id); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 3063b6427fa..1c0dbd9b723 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1969,7 +1969,9 @@ package body Sem_Ch4 is -- An explicit dereference is a legal occurrence of an -- incomplete type imported through a limited_with clause, - -- if the full view is visible. + -- if the full view is visible, or if we are within an + -- instance body, where the enclosing body has a regular + -- with_clause on the unit. if From_Limited_With (DT) and then not From_Limited_With (Scope (DT)) @@ -1977,7 +1979,8 @@ package body Sem_Ch4 is (Is_Immediately_Visible (Scope (DT)) or else (Is_Child_Unit (Scope (DT)) - and then Is_Visible_Lib_Unit (Scope (DT)))) + and then Is_Visible_Lib_Unit (Scope (DT))) + or else In_Instance_Body) then Set_Etype (N, Available_View (DT)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index a225883e668..fdfe9f6a504 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8288,7 +8288,19 @@ package body Sem_Ch6 is -- is needed for cases where a full derived type has been -- rewritten.) - Defn := Type_Definition (Original_Node (Parent (F_Typ))); + -- If the parent type is a scalar type, the derivation creates + -- an anonymous base type for it, and the source type is its + -- first subtype. + + if Is_Scalar_Type (F_Typ) + and then not Comes_From_Source (F_Typ) + then + Defn := + Type_Definition + (Original_Node (Parent (First_Subtype (F_Typ)))); + else + Defn := Type_Definition (Original_Node (Parent (F_Typ))); + end if; if Nkind (Defn) = N_Derived_Type_Definition then Indic := Subtype_Indication (Defn); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index df1eff32b9f..ee76eda0fce 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -927,25 +927,6 @@ package body Sem_Ch8 is ("renaming of conversion only allowed for tagged types", Nam); end if; - -- Reject renaming of component of Volatile_Full_Access object - - if Nkind_In (Nam, N_Selected_Component, N_Indexed_Component) then - declare - P : constant Node_Id := Prefix (Nam); - begin - if Is_Entity_Name (P) then - if Is_Volatile_Full_Access (Entity (P)) - or else - Is_Volatile_Full_Access (Etype (P)) - then - Error_Msg_N - ("cannot rename component of Volatile_Full_Access " - & "object", Nam); - end if; - end if; - end; - end if; - Resolve (Nam, T); -- If the renamed object is a function call of a limited type, diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index eefca477da0..203313d11e6 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -786,9 +786,8 @@ package Sinfo is -- Acts_As_Spec (Flag4-Sem) -- A flag set in the N_Subprogram_Body node for a subprogram body which - -- is acting as its own spec, except in the case of a library level - -- subprogram, in which case the flag is set on the parent compilation - -- unit node instead. + -- is acting as its own spec. In the case of a library-level subprogram + -- the flag is set as well on the parent compilation unit node. -- Actual_Designated_Subtype (Node4-Sem) -- Present in N_Free_Statement and N_Explicit_Dereference nodes. If gigi -- 2.30.2