From 53f29d4f64e462e90aff1a949ab7f06f8e342c49 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 3 Aug 2011 10:08:31 +0200 Subject: [PATCH] [multiple changes] 2011-08-03 Robert Dewar * sem_ch3.adb, sem_res.adb, exp_ch13.adb, exp_disp.adb, exp_aggr.adb: Minor reformatting. 2011-08-03 Thomas Quinot * exp_ch5.adb (Expand_N_Assignment_Statement): Do not force inlining of tagged assignment when discriminant checks are suppressed. This is useless and extremely costly in terms of static stack usage. 2011-08-03 Bob Duff * sem_prag.adb (Get_Base_Subprogram): Do not follow Alias for instances of generics, because this leads to the wrong entity in the wrong scope, causing (e.g.) pragma Export_Procedure to get an error if the entity is an instance. (Process_Interface_Name): Follow Alias for instances of generics, to correct for the above change. 2011-08-03 Ed Schonberg * exp_ch4.adb (Expand_N_Selected_Component): If the discriminant value is an integer literal it is always safe to replace the reference. In addition, if the reference appears in the generated code for an object declaration it is necessary to copy because otherwise the reference might be to the uninitilized value of the discriminant of the object itself. 2011-08-03 Pascal Obry * adaint.c (__gnat_is_executable_file_attr): Fix Win32 circuitry when no ACL used, in this case we want to check for ending .exe, not .exe anywhere in the path. 2011-08-03 Sergey Rybin * tree_io.ads (ASIS_Version_Number): Update because of the changes in the tree structure (semantic decoration of references to record discriminants). From-SVN: r177237 --- gcc/ada/ChangeLog | 41 +++++++++++++++++++++++++++++++++++++++++ gcc/ada/adaint.c | 11 +++++++++-- gcc/ada/exp_aggr.adb | 2 +- gcc/ada/exp_ch13.adb | 3 ++- gcc/ada/exp_ch4.adb | 39 ++++++++++++++++++++++++++++++++++++++- gcc/ada/exp_ch5.adb | 23 +++++++++-------------- gcc/ada/exp_disp.adb | 13 +++++++------ gcc/ada/sem_ch3.adb | 20 ++++++++++---------- gcc/ada/sem_prag.adb | 18 +++++++++++++----- gcc/ada/sem_res.adb | 33 ++++++++++++++++++--------------- gcc/ada/tree_io.ads | 4 ++-- 11 files changed, 150 insertions(+), 57 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2ce9de1811d..251718fc136 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,44 @@ +2011-08-03 Robert Dewar + + * sem_ch3.adb, sem_res.adb, exp_ch13.adb, exp_disp.adb, + exp_aggr.adb: Minor reformatting. + +2011-08-03 Thomas Quinot + + * exp_ch5.adb (Expand_N_Assignment_Statement): Do not force inlining of + tagged assignment when discriminant checks are suppressed. This is + useless and extremely costly in terms of static stack usage. + +2011-08-03 Bob Duff + + * sem_prag.adb (Get_Base_Subprogram): Do not follow Alias for instances + of generics, because this leads to the wrong entity in the wrong scope, + causing (e.g.) pragma Export_Procedure to get an error if the entity is + an instance. + (Process_Interface_Name): Follow Alias for instances of generics, to + correct for the above change. + +2011-08-03 Ed Schonberg + + * exp_ch4.adb (Expand_N_Selected_Component): If the discriminant value + is an integer literal it is always safe to replace the reference. In + addition, if the reference appears in the generated code for an object + declaration it is necessary to copy because otherwise the reference + might be to the uninitilized value of the discriminant of the object + itself. + +2011-08-03 Pascal Obry + + * adaint.c (__gnat_is_executable_file_attr): Fix Win32 circuitry when no + ACL used, in this case we want to check for ending .exe, not .exe + anywhere in the path. + +2011-08-03 Sergey Rybin + + * tree_io.ads (ASIS_Version_Number): Update because of the changes in + the tree structure (semantic decoration of references to record + discriminants). + 2011-08-03 Gary Dismukes * sem_aggr.adb (Analyze_Array_Aggregate): When checking the discrete diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index bfaa31a941a..6845ff08ec1 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2145,8 +2145,15 @@ __gnat_is_executable_file_attr (char* name, struct file_attributes* attr) __gnat_check_OWNER_ACL (wname, FILE_EXECUTE, GenericMapping); } else - attr->executable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES - && _tcsstr (wname, _T(".exe")) - wname == (int) (_tcslen (wname) - 4); + { + TCHAR *l, *last = _tcsstr(wname, _T(".exe")); + + /* look for last .exe */ + while (l = _tcsstr(last+1, _T(".exe"))) last = l; + + attr->executable = GetFileAttributes (wname) != INVALID_FILE_ATTRIBUTES + && last - wname == (int) (_tcslen (wname) - 4); + } #else __gnat_stat_to_attr (-1, name, attr); #endif diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7ff4b7a49b1..f04a662a7fc 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5700,7 +5700,7 @@ package body Exp_Aggr is elsif Has_Mutable_Components (Typ) and then (Nkind (Parent (N)) /= N_Object_Declaration - or else not Constant_Present (Parent (N))) + or else not Constant_Present (Parent (N))) then Convert_To_Assignments (N, Typ); diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index dbf664c5bad..a0250ec1797 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -311,7 +311,8 @@ package body Exp_Ch13 is In_Other_Scope := False; In_Outer_Scope := E_Scope /= Current_Scope; - -- Otherwise it is a local package or a different compilation unit. + -- Otherwise it is a local package or a different compilation unit + else In_Other_Scope := True; In_Outer_Scope := False; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 0298487256e..203795015c3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -7594,6 +7594,18 @@ package body Exp_Ch4 is -- unless the context of an assignment can provide size information. -- Don't we have a general routine that does this??? + function Is_Subtype_Declaration return Boolean; + -- The replacement of a discriminant reference by its value is required + -- if this is part of the initialization of an temporary generated by + -- a change of representation. This shows up as the construction of a + -- discriminant constraint for a subtype declared at the same point as + -- the entity in the prefix of the selected component. + -- We recognize this case when the context of the reference is: + -- + -- subtype ST is T(Obj.D); + -- + -- The entity for Obj comes from source, and ST has the same sloc. + ----------------------- -- In_Left_Hand_Side -- ----------------------- @@ -7607,6 +7619,21 @@ package body Exp_Ch4 is and then In_Left_Hand_Side (Parent (Comp))); end In_Left_Hand_Side; + ----------------------------- + -- Is_Subtype_Declaration -- + ----------------------------- + + function Is_Subtype_Declaration return Boolean is + Par : constant Node_Id := Parent (N); + + begin + return + Nkind (Par) = N_Index_Or_Discriminant_Constraint + and then Nkind (Parent (Parent (Par))) = N_Subtype_Declaration + and then Comes_From_Source (Entity (Prefix (N))) + and then Sloc (Par) = Sloc (Entity (Prefix (N))); + end Is_Subtype_Declaration; + -- Start of processing for Expand_N_Selected_Component begin @@ -7730,9 +7757,19 @@ package body Exp_Ch4 is -- AND THEN was copied, causing problems for coverage -- analysis tools). + -- However, if the reference is part of the initialization + -- code generated for an object declaration, we must use + -- the discriminant value from the subtype constraint, + -- because the selected component may be a reference to the + -- object being initialized, whose discriminant is not yet + -- set. This only happens in complex cases involving changes + -- or representation. + if Disc = Entity (Selector_Name (N)) and then (Is_Entity_Name (Dval) - or else Is_Static_Expression (Dval)) + or else Nkind (Dval) = N_Integer_Literal + or else Is_Subtype_Declaration + or else Is_Static_Expression (Dval)) then -- Here we have the matching discriminant. Check for -- the case of a discriminant of a component that is diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 7ff1a3dcce2..dad94273afb 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -1934,24 +1934,19 @@ package body Exp_Ch5 is -- If the type is tagged, we may as well use the predefined -- primitive assignment. This avoids inlining a lot of code - -- and in the class-wide case, the assignment is replaced by - -- dispatch call to _assign. Note that this cannot be done when - -- discriminant checks are locally suppressed (as in extension - -- aggregate expansions) because otherwise the discriminant - -- check will be performed within the _assign call. It is also - -- suppressed for assignments created by the expander that - -- correspond to initializations, where we do want to copy the - -- tag (No_Ctrl_Actions flag set True) by the expander and we - -- do not need to mess with tags ever (Expand_Ctrl_Actions flag - -- is set True in this case). Finally, it is suppressed if the - -- restriction No_Dispatching_Calls is in force because in that - -- case predefined primitives are not generated. + -- and in the class-wide case, the assignment is replaced by a + -- dispatching call to _assign. It is suppressed in the case of + -- assignments created by the expander that correspond to + -- initializations, where we do want to copy the tag + -- (Expand_Ctrl_Actions flag is set True in this case). + -- It is also suppressed if restriction No_Dispatching_Calls is + -- in force because in that case predefined primitives are not + -- generated. or else (Is_Tagged_Type (Typ) and then not Is_Value_Type (Etype (Lhs)) and then Chars (Current_Scope) /= Name_uAssign and then Expand_Ctrl_Actions - and then not Discriminant_Checks_Suppressed (Empty) and then not Restriction_Active (No_Dispatching_Calls)) then diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 69159632d50..47161e93e05 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -3808,12 +3808,12 @@ package body Exp_Disp is -- calls through interface types; the latter secondary table is -- generated when Build_Thunks is False, and provides support for -- Generic Dispatching Constructors that dispatch calls through - -- interface types. When constructing this latter table the value - -- of Suffix_Index is -1 to indicate that there is no need to export - -- such table when building statically allocated dispatch tables; a - -- positive value of Suffix_Index must match the Suffix_Index value - -- assigned to this secondary dispatch table by Make_Tags when its - -- unique external name was generated. + -- interface types. When constructing this latter table the value of + -- Suffix_Index is -1 to indicate that there is no need to export such + -- table when building statically allocated dispatch tables; a positive + -- value of Suffix_Index must match the Suffix_Index value assigned to + -- this secondary dispatch table by Make_Tags when its unique external + -- name was generated. ------------------------------ -- Check_Premature_Freezing -- @@ -3825,6 +3825,7 @@ package body Exp_Disp is Typ : Entity_Id) is Comp : Entity_Id; + begin if Present (N) and then Is_Private_Type (Typ) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6441cfa7396..5de3b0ece70 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3402,16 +3402,16 @@ package body Sem_Ch3 is Remove_Side_Effects (E); + -- If this is a constant declaration of an unconstrained type and + -- the initialization is an aggregate, we can use the subtype of the + -- aggregate for the declared entity because it is immutable. + elsif not Is_Constrained (T) and then Has_Discriminants (T) and then Constant_Present (N) and then not Has_Unchecked_Union (T) and then Nkind (E) = N_Aggregate then - -- If this is a constant declaration of an unconstrained type and - -- the initialization is an aggregate, we can use the subtype of the - -- aggregate for the declared entity because it is immutable. - Act_T := Etype (E); end if; @@ -3419,9 +3419,9 @@ package body Sem_Ch3 is Check_Wide_Character_Restriction (T, Object_Definition (N)); - -- Indicate this is not set in source. Certainly true for constants, - -- and true for variables so far (will be reset for a variable if and - -- when we encounter a modification in the source). + -- Indicate this is not set in source. Certainly true for constants, and + -- true for variables so far (will be reset for a variable if and when + -- we encounter a modification in the source). Set_Never_Set_In_Source (Id, True); @@ -3435,9 +3435,9 @@ package body Sem_Ch3 is Set_Ekind (Id, E_Variable); -- A variable is set as shared passive if it appears in a shared - -- passive package, and is at the outer level. This is not done - -- for entities generated during expansion, because those are - -- always manipulated locally. + -- passive package, and is at the outer level. This is not done for + -- entities generated during expansion, because those are always + -- manipulated locally. if Is_Shared_Passive (Current_Scope) and then Is_Library_Level_Entity (Id) diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 20b63b8ccfa..4cab6b4f429 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4723,8 +4723,17 @@ package body Sem_Prag is Strval => End_String); end if; - Set_Encoded_Interface_Name - (Get_Base_Subprogram (Subprogram_Def), Link_Nam); + -- Set the interface name. If the entity is a generic instance, use + -- its alias, which is the callable entity. + + if Is_Generic_Instance (Subprogram_Def) then + Set_Encoded_Interface_Name + (Alias (Get_Base_Subprogram (Subprogram_Def)), Link_Nam); + + else + Set_Encoded_Interface_Name + (Get_Base_Subprogram (Subprogram_Def), Link_Nam); + end if; -- We allow duplicated export names in CIL, as they are always -- enclosed in a namespace that differentiates them, and overloaded @@ -13890,9 +13899,8 @@ package body Sem_Prag is Result := Def_Id; while Is_Subprogram (Result) and then - (Is_Generic_Instance (Result) - or else Nkind (Parent (Declaration_Node (Result))) = - N_Subprogram_Renaming_Declaration) + Nkind (Parent (Declaration_Node (Result))) = + N_Subprogram_Renaming_Declaration and then Present (Alias (Result)) loop Result := Alias (Result); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 7d518037242..b99a94ad06c 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -9881,21 +9881,24 @@ package body Sem_Res is declare Index_List : constant List_Id := New_List; Index_Type : constant Entity_Id := Etype (First_Index (Typ)); - High_Bound : constant Node_Id := - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Val, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Expressions => - New_List ( - Make_Op_Add (Loc, - Left_Opnd => - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Pos, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Expressions => New_List (New_Copy_Tree (Low_Bound))), - Right_Opnd => - Make_Integer_Literal (Loc, - String_Length (Strval (N)) - 1)))); + + High_Bound : constant Node_Id := + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Val, + Prefix => + New_Occurrence_Of (Index_Type, Loc), + Expressions => New_List ( + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Pos, + Prefix => + New_Occurrence_Of (Index_Type, Loc), + Expressions => + New_List (New_Copy_Tree (Low_Bound))), + Right_Opnd => + Make_Integer_Literal (Loc, + String_Length (Strval (N)) - 1)))); Array_Subtype : Entity_Id; Index_Subtype : Entity_Id; diff --git a/gcc/ada/tree_io.ads b/gcc/ada/tree_io.ads index 0cb17fed26f..f2f6ad36735 100644 --- a/gcc/ada/tree_io.ads +++ b/gcc/ada/tree_io.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -47,7 +47,7 @@ package Tree_IO is Tree_Format_Error : exception; -- Raised if a format error is detected in the input file - ASIS_Version_Number : constant := 23; + ASIS_Version_Number : constant := 24; -- ASIS Version. This is used to check for consistency between the compiler -- used to generate trees and an ASIS application that is reading the -- trees. It must be incremented whenever a change is made to the tree -- 2.30.2