diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 41 | ||||
| -rw-r--r-- | gcc/ada/adaint.c | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_ch13.adb | 3 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 39 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 23 | ||||
| -rw-r--r-- | gcc/ada/exp_disp.adb | 13 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 18 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 33 | ||||
| -rw-r--r-- | 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 <dewar@adacore.com> + + * sem_ch3.adb, sem_res.adb, exp_ch13.adb, exp_disp.adb, + exp_aggr.adb: Minor reformatting. + +2011-08-03 Thomas Quinot <quinot@adacore.com> + + * 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 <duff@adacore.com> + + * 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 <schonberg@adacore.com> + + * 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 <obry@adacore.com> + + * 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 <rybin@adacore.com> + + * 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 <dismukes@adacore.com> * 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 |