diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 003533801eb..3a936730bea 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2014-02-24 Sergey Rybin + + * gnat_ugn.texi: Misc updates. + +2014-02-24 Hristian Kirtchev + + * exp_prag.adb (Expand_Old): Set the type of the generated temporary. + +2014-02-24 Gary Dismukes + + * layout.adb (Layout_Variant_Record): Instantiate + Generic_Check_Choices and call Check_Choices before calling + Build_Discr_Checking_Funcs, since we need Others_Discrete_Choices + set to prevent generating incorrect discriminant-checking + functions for 'others' variants (functions that unconditionally + return True rather than accounting for the values covered by the + 'others' choice). + * sem_eval.ads (Subtypes_Statically_Compatible): Add formal + Formal_Derived_Matching. + (Subtypes_Statically_Match): Add formal Formal_Derived_Matching. + * sem_eval.adb (Subtypes_Statically_Compatible): Pass new + Formal_Derived_Matching formal to Subtypes_Statically_Match. + (Subtypes_Statically_Match): Suppress the Object_Size matching + test in the case where Formal_Derived_Matching is True. + * sem_ch12.adb (Validate_Derived_Type_Instance): Pass + True for Formal_Derived_Matching_Formal on the call to + Subtypes_Statically_Compatible. + 2014-02-23 Eric Botcazou * gcc-interface/Make-lang.in (ADA_TOOLS_FLAGS_TO_PASS): Robustify. diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 54aec71de66..1925012b845 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -436,6 +436,7 @@ package body Exp_Prag is then Pref := Prefix (N); Temp := Make_Temporary (Loc, 'T', Pref); + Set_Etype (Temp, Etype (Pref)); -- Generate a temporary to capture the value of the prefix: -- Temp : ; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index f8974492aeb..10285e775ad 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -14643,6 +14643,31 @@ Display Copyright and version, then exit disregarding all other options. @cindex @option{--help} @command{gnatpp} Display usage, then exit disregarding all other options. +@item -P @var{file} +@cindex @option{-P} @command{gnatpp} +Indicates the name of the project file that describes the set of sources +to be processed. The exact set of argument sources depends on other options +specified, see below. + +@item -U +@cindex @option{-U} @command{gnatpp} +If a project file is specified and no argument source is explicitly +specified (either directly or by means of @option{-files} option), process +all the units of the closure of the argument project. Otherwise this option +has no effect. + +@item -U @var{main_unit} +If a project file is specified and no argument source is explicitly +specified (either directly or by means of @option{-files} option), process +the closure of units rooted at @var{main_unit}. Otherwise this option +has no effect. + +@item -X@var{name}=@var{value} +@cindex @option{-X} @command{gnatpp} +Indicates that external variable @var{name} in the argument project +has the @var{value} value. Has no effect if no project is specified as +tool argument. + @item --pp-off=@var{xxx} @cindex @option{--pp-off} @command{gnatpp} Use @code{--xxx} as the command to turn off pretty printing, instead @@ -14692,6 +14717,13 @@ Warning mode; a required layout in the result source. @end table +@noindent +If a project file is specified and no argument source is explicitly +specified (either directly or by means of @option{-files} option), and no +@option{-U} is specified, then the set of processed sources is +all the immediate units of the argument project. + + @node Formatting Rules @section Formatting Rules @@ -15318,6 +15350,23 @@ Options: -h --help -- generate usage information and quit, ignoring all other options +-P @file{file} -- indicates the name of the project file that describes + the set of sources to be processed. The exact set of argument + sources depends on other options specified, see below. + +-U -- if a project file is specified and no argument source is explicitly + specified, process all the units of the closure of the argument project. + Otherwise this option has no effect. + +-U @var{main_unit} -- if a project file is specified and no argument source + is explicitly specified (either directly or by means of @option{-files} + option), process the closure of units rooted at @var{main_unit}. + Otherwise this option has no effect. + +-X@var{name}=@var{value} -- indicates that external variable @var{name} in + the argument project has the @var{value} value. Has no effect if no + project is specified as tool argument. + -mdir -- generate one .xml file for each Ada source file, in directory @file{dir}. (Default is to generate the XML to standard output.) @@ -15340,6 +15389,11 @@ Options: @end smallexample @noindent +If a project file is specified and no argument source is explicitly +specified, and no @option{-U} is specified, then the set of processed +sources is all the immediate units of the argument project. + + You can generate the ``tree files'' ahead of time using the -gnatct switch: @smallexample @@ -16697,7 +16751,14 @@ tool argument. Use the specified subdirectory of the project objects file (or of the project file directory if the project does not specify an object directory) for tool output files. Has no effect if no project is specified as -tool argument. +tool argument r if @option{--no_objects_dir} is specified. + +@item --no_objects_dir +@cindex @option{--no_objects_dir} @command{gnatmetric} +Place all the result files into the current directory instead of +project objects directory. This corresponds to the @command{gnatcheck} +behavior when it is called with the project file from the +GNAT driver. Has no effect if no project is specified. @item ^-files @var{filename}^/FILES=@var{filename}^ @cindex @option{^-files^/FILES^} (@code{gnatmetric}) @@ -16729,13 +16790,11 @@ a trace of sources being processed. Quiet mode. @end table -@ignore @noindent If a project file is specified and no argument source is explicitly specified (either directly or by means of @option{-files} option), and no @option{-U} is specified, then the set of processed sources is all the immediate units of the argument project. -@end ignore @ignore diff --git a/gcc/ada/layout.adb b/gcc/ada/layout.adb index ada36de8c75..829d75c2eb9 100644 --- a/gcc/ada/layout.adb +++ b/gcc/ada/layout.adb @@ -37,6 +37,7 @@ with Opt; use Opt; with Repinfo; use Repinfo; with Sem; use Sem; with Sem_Aux; use Sem_Aux; +with Sem_Case; use Sem_Case; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Util; use Sem_Util; @@ -2224,9 +2225,54 @@ package body Layout is end if; end Layout_Component_List; + Others_Present : Boolean; + pragma Warnings (Off, Others_Present); + -- Indicates others present, not used in this case + + procedure Non_Static_Choice_Error (Choice : Node_Id); + -- Error routine invoked by the generic instantiation below when + -- the variant part has a nonstatic choice. + + package Variant_Choices_Processing is new + Generic_Check_Choices + (Process_Empty_Choice => No_OP, + Process_Non_Static_Choice => Non_Static_Choice_Error, + Process_Associated_Node => No_OP); + use Variant_Choices_Processing; + + ----------------------------- + -- Non_Static_Choice_Error -- + ----------------------------- + + procedure Non_Static_Choice_Error (Choice : Node_Id) is + begin + Flag_Non_Static_Expr + ("choice given in case expression is not static!", Choice); + end Non_Static_Choice_Error; + -- Start of processing for Layout_Variant_Record begin + -- Call Check_Choices here to ensure that Others_Discrete_Choices + -- gets set on any 'others' choice before the discriminant-checking + -- functions are generated. Otherwise the function for the 'others' + -- alternative will unconditionally return True, causing discriminant + -- checks to fail. However, Check_Choices is now normally delayed + -- until the type's freeze entity is processed, due to requirements + -- coming from subtype predicates, so doing it at this point is + -- probably not right in general, but it's not clear how else to deal + -- with this situation. Perhaps we should only generate declarations + -- for the checking functions here, and somehow delay generation of + -- their bodies, but that would be a nontrivial change. ??? + + declare + VP : constant Node_Id := + Variant_Part (Component_List (Type_Definition (Decl))); + begin + Check_Choices + (VP, Variants (VP), Etype (Name (VP)), Others_Present); + end; + -- We need the discriminant checking functions, since we generate -- calls to these functions for the RM_Size expression, so make -- sure that these functions have been constructed in time. diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 54df193ab8b..59fc323b349 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -11124,7 +11124,9 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; - if not Subtypes_Statically_Compatible (Act_T, Ancestor) then + if not Subtypes_Statically_Compatible + (Act_T, Ancestor, Formal_Derived_Matching => True) + then Error_Msg_N ("constraint on actual is incompatible with formal", Actual); Abandon_Instantiation (Actual); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 14b2fa97a3b..e8c85f9a50d 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -4786,8 +4786,9 @@ package body Sem_Eval is ------------------------------------ function Subtypes_Statically_Compatible - (T1 : Entity_Id; - T2 : Entity_Id) return Boolean + (T1 : Entity_Id; + T2 : Entity_Id; + Formal_Derived_Matching : Boolean := False) return Boolean is begin -- Scalar types @@ -4863,7 +4864,7 @@ package body Sem_Eval is else return (Is_Composite_Type (T1) and then not Is_Constrained (T2)) - or else Subtypes_Statically_Match (T1, T2); + or else Subtypes_Statically_Match (T1, T2, Formal_Derived_Matching); end if; end Subtypes_Statically_Compatible; @@ -4877,19 +4878,28 @@ package body Sem_Eval is -- values match (RM 4.9.1(1)). -- In addition, in GNAT, the object size (Esize) values of the types must - -- match if they are set. The use of 'Object_Size can cause this to be - -- false even if the types would otherwise match in the RM sense. + -- match if they are set (unless checking an actual for a formal derived + -- type). The use of 'Object_Size can cause this to be false even if the + -- types would otherwise match in the RM sense. - function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean is + function Subtypes_Statically_Match + (T1 : Entity_Id; + T2 : Entity_Id; + Formal_Derived_Matching : Boolean := False) return Boolean + is begin -- A type always statically matches itself if T1 = T2 then return True; - -- No match if sizes different (from use of 'Object_Size) + -- No match if sizes different (from use of 'Object_Size). This test + -- is excluded if Formal_Derived_Matching is True, as the base types + -- can be different in that case and typically have different sizes + -- (and Esizes can be set when Frontend_Layout_On_Target is True). - elsif Known_Static_Esize (T1) and then Known_Static_Esize (T2) + elsif not Formal_Derived_Matching + and then Known_Static_Esize (T1) and then Known_Static_Esize (T2) and then Esize (T1) /= Esize (T2) then return False; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 6d5cdc8319f..8bd8761f0da 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -214,17 +214,25 @@ package Sem_Eval is -- static, or because one or the other bound raises CE). function Subtypes_Statically_Compatible - (T1 : Entity_Id; - T2 : Entity_Id) return Boolean; + (T1 : Entity_Id; + T2 : Entity_Id; + Formal_Derived_Matching : Boolean := False) return Boolean; -- Returns true if the subtypes are unconstrained or the constraint on -- on T1 is statically compatible with T2 (as defined by 4.9.1(4)). - -- Otherwise returns false. + -- Otherwise returns false. Formal_Derived_Matching indicates whether + -- the type T1 is a generic actual being checked against ancestor T2 + -- in a formal derived type association. - function Subtypes_Statically_Match (T1, T2 : Entity_Id) return Boolean; + function Subtypes_Statically_Match + (T1 : Entity_Id; + T2 : Entity_Id; + Formal_Derived_Matching : Boolean := False) return Boolean; -- Determine whether two types T1, T2, which have the same base type, -- are statically matching subtypes (RM 4.9.1(1-2)). Also includes the -- extra GNAT rule that object sizes must match (this can be false for - -- types that match in the RM sense because of use of 'Object_Size). + -- types that match in the RM sense because of use of 'Object_Size), + -- except when testing a generic actual T1 against an ancestor T2 in a + -- formal derived type association (indicated by Formal_Derived_Matching). function Compile_Time_Known_Value (Op : Node_Id) return Boolean; -- Returns true if Op is an expression not raising Constraint_Error whose