From 8d81fb4ea24ba78622991141b9ad2f36bea1ec84 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 21 Jan 2014 09:01:05 +0100 Subject: [PATCH] [multiple changes] 2014-01-21 Javier Miranda * exp_ch3.adb (Build_Init_Procedure): For derivations of interfaces, do not move the the initialization of the _parent field since such assignment is not generated. 2014-01-21 Ed Schonberg * sem_res.adb (Rewrite_Renamed_Operator): Do not replace entity with the operator it renames if we are within an expression of a pre/postcondition, because the expression will be reanalyzed at a later point, and the analysis of the renaming may affect the visibility of the operator when in an instance. 2014-01-21 Robert Dewar * sinfo.ads, sinfo.adb: Change Do_Discriminant_Check to use new Flag1. Add this flag to type conversion nodes and assignment nodes. * treepr.adb: Deal properly with Flag 1,2,3. * treeprs.adt: Minor comment update. 2014-01-21 Robert Dewar * sem_eval.adb (Compile_Time_Known_Value): Add Ignore_CRT parameter. * sem_eval.ads (Compile_Time_Known_Value): Add Ignore_CRT parameter, completely rewrite spec. 2014-01-21 Ed Schonberg * sem_ch10.adb (Install_Withed_Unit): If the unit is a subprogram instance that is inlined, it may have been rewritten as a wrapper package. In that case the unit that must be made visible is the related instance of the package. 2014-01-21 Arnaud Charlet * exp_ch9.adb (Expand_N_Selective_Accept.Add_Accept): Refine previous change in codepeer mode. From-SVN: r206874 --- gcc/ada/ChangeLog | 40 ++++++++++++++++++++++++ gcc/ada/exp_ch3.adb | 12 ++++++-- gcc/ada/exp_ch9.adb | 24 +++++++++------ gcc/ada/sem_ch10.adb | 9 ++++++ gcc/ada/sem_eval.adb | 10 +++--- gcc/ada/sem_eval.ads | 73 +++++++++++++++++++++++++++++++++++--------- gcc/ada/sem_res.adb | 8 +++++ gcc/ada/sinfo.adb | 12 +++++--- gcc/ada/sinfo.ads | 31 ++++++++++--------- gcc/ada/treepr.adb | 28 +++++------------ gcc/ada/treeprs.adt | 5 ++- 11 files changed, 180 insertions(+), 72 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3feaf3850c9..48891bfc4a4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,43 @@ +2014-01-21 Javier Miranda + + * exp_ch3.adb (Build_Init_Procedure): For + derivations of interfaces, do not move the the initialization + of the _parent field since such assignment is not generated. + +2014-01-21 Ed Schonberg + + * sem_res.adb (Rewrite_Renamed_Operator): Do not replace entity + with the operator it renames if we are within an expression of + a pre/postcondition, because the expression will be reanalyzed + at a later point, and the analysis of the renaming may affect + the visibility of the operator when in an instance. + +2014-01-21 Robert Dewar + + * sinfo.ads, sinfo.adb: Change Do_Discriminant_Check to use new Flag1. + Add this flag to type conversion nodes and assignment nodes. + * treepr.adb: Deal properly with Flag 1,2,3. + * treeprs.adt: Minor comment update. + +2014-01-21 Robert Dewar + + * sem_eval.adb (Compile_Time_Known_Value): Add Ignore_CRT + parameter. + * sem_eval.ads (Compile_Time_Known_Value): Add Ignore_CRT + parameter, completely rewrite spec. + +2014-01-21 Ed Schonberg + + * sem_ch10.adb (Install_Withed_Unit): If the unit is a subprogram + instance that is inlined, it may have been rewritten as a wrapper + package. In that case the unit that must be made visible is the + related instance of the package. + +2014-01-21 Arnaud Charlet + + * exp_ch9.adb (Expand_N_Selective_Accept.Add_Accept): Refine + previous change in codepeer mode. + 2014-01-21 Arnaud Charlet * exp_ch9.adb (Expand_N_Selective_Accept.Add_Accept): Always add diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 087c79149c5..da0ac4c01bb 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2386,10 +2386,16 @@ package body Exp_Ch3 is Component_List (Record_Extension_Node)); begin - -- The parent field must be initialized first because - -- the offset of the new discriminants may depend on it + -- The parent field must be initialized first because the + -- offset of the new discriminants may depend on it. This is + -- not needed if the parent is an interface type because in + -- such case the initialization of the _parent field was not + -- generated. + + if not Is_Interface (Etype (Rec_Ent)) then + Prepend_To (Body_Stmts, Remove_Head (Stmts)); + end if; - Prepend_To (Body_Stmts, Remove_Head (Stmts)); Append_List_To (Body_Stmts, Stmts); end; end if; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 4fce378b5ea..a03778ef30d 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -10339,17 +10339,21 @@ package body Exp_Ch9 is if Present (Handled_Statement_Sequence (Accept_Statement (Alt))) then Null_Body := New_Reference_To (Standard_False, Eloc); - -- Always add call to Abort_Undefer, since this is what the - -- runtime expects (abort deferred in Selective_Wait). + -- Always add call to Abort_Undefer when generating code, since + -- this is what the runtime expects (abort deferred in + -- Selective_Wait). In CodePeer mode this only confuses the + -- analysis with unknown calls, so don't do it. - Call := - Make_Procedure_Call_Statement (Eloc, - Name => New_Reference_To (RTE (RE_Abort_Undefer), Eloc)); - Insert_Before - (First (Statements (Handled_Statement_Sequence - (Accept_Statement (Alt)))), - Call); - Analyze (Call); + if not CodePeer_Mode then + Call := + Make_Procedure_Call_Statement (Eloc, + Name => New_Reference_To (RTE (RE_Abort_Undefer), Eloc)); + Insert_Before + (First (Statements (Handled_Statement_Sequence + (Accept_Statement (Alt)))), + Call); + Analyze (Call); + end if; PB_Ent := Make_Defining_Identifier (Eloc, diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index bc4deef0494..52e5c21615a 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -5156,6 +5156,14 @@ package body Sem_Ch10 is Set_Is_Visible_Lib_Unit (Uname); + -- If the unit is a wrapper package for a compilation unit that is + -- a subprogrm instance, indicate that the instance itself is a + -- visible unit. This is necessary if the instance is inlined. + + if Is_Wrapper_Package (Uname) then + Set_Is_Visible_Lib_Unit (Related_Instance (Uname)); + end if; + -- If the child unit appears in the context of its parent, it is -- immediately visible. @@ -6447,6 +6455,7 @@ package body Sem_Ch10 is -- If the unit is a wrapper package, the subprogram instance is -- what must be removed from visibility. + -- Should we use Related_Instance instead??? if Is_Wrapper_Package (Unit_Name) then Set_Is_Immediately_Visible (Current_Entity (Unit_Name), False); diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 5ee8ecc0cc6..d69c3414cef 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -1287,7 +1287,10 @@ package body Sem_Eval is -- Compile_Time_Known_Value -- ------------------------------ - function Compile_Time_Known_Value (Op : Node_Id) return Boolean is + function Compile_Time_Known_Value + (Op : Node_Id; + Ignore_CRT : Boolean := False) return Boolean + is K : constant Node_Kind := Nkind (Op); CV_Ent : CV_Entry renames CV_Cache (Nat (Op) mod CV_Cache_Size); @@ -1311,9 +1314,9 @@ package body Sem_Eval is -- time. This avoids anomalies where whether something is allowed with a -- given configurable run-time library depends on how good the compiler -- is at optimizing and knowing that things are constant when they are - -- nonstatic. + -- nonstatic. This check is suppressed if Ignore_CRT is True - if Configurable_Run_Time_Mode + if (Configurable_Run_Time_Mode and not Ignore_CRT) and then K /= N_Null and then not Is_Static_Expression (Op) then @@ -1326,7 +1329,6 @@ package body Sem_Eval is and then Etype (Entity (Op)) = Standard_Boolean then null; - else return False; end if; diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index 66a9e3ecc65..c3a5e30461e 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -85,14 +85,14 @@ package Sem_Eval is -- does not raise constraint error. In fact for certain legality checks not -- only do we need to ascertain that the expression is static, but we must -- also ensure that it does not raise constraint error. - -- + -- Neither of Is_Static_Expression and Is_OK_Static_Expression should be -- used for compile time evaluation purposes. In fact certain expression - -- whose value is known at compile time are not static in the RM 4.9 sense. - -- A typical example is: - -- + -- whose value may be known at compile time are not static in the RM 4.9 + -- sense. A typical example is: + -- C : constant Integer := Record_Type'Size; - -- + -- The expression 'C' is not static in the technical RM sense, but for many -- simple record types, the size is in fact known at compile time. When we -- are trying to perform compile time constant folding (for instance for @@ -100,8 +100,8 @@ package Sem_Eval is -- are not the right functions to test if folding is possible. Instead, we -- use Compile_Time_Known_Value. All static expressions that do not raise -- constraint error (i.e. those for which Is_OK_Static_Expression is true) - -- are known at compile time, but as shown by the above example, there are - -- cases of non-static expressions which are known at compile time. + -- are known at compile time, but as shown by the above example, there may + -- be cases of non-static expressions which are known at compile time. ----------------- -- Subprograms -- @@ -224,15 +224,60 @@ package Sem_Eval is -- Determine whether two types T1, T2, which have the same base type, -- are statically matching subtypes (RM 4.9.1(1-2)). - function Compile_Time_Known_Value (Op : Node_Id) return Boolean; + function Compile_Time_Known_Value + (Op : Node_Id; + Ignore_CRT : Boolean := False) return Boolean; -- Returns true if Op is an expression not raising Constraint_Error whose - -- value is known at compile time. This is true if Op is a static + -- value is known at compile time and for which a call to Expr_Value can + -- be used to determine this value. This is always true if Op is a static -- expression, but can also be true for expressions which are technically - -- non-static but which are in fact known at compile time, such as the - -- static lower bound of a non-static range or the value of a constant - -- object whose initial value is static. Note that this routine is defended - -- against unanalyzed expressions. Such expressions will not cause a - -- blowup, they may cause pessimistic (i.e. False) results to be returned. + -- non-static but which are in fact known at compile time. Some possible + -- examples of such expressions might be the static lower bound of a + -- non-static range or the value of a constant object whose initial + -- value is itself compile time known in the sense of this routine. Note + -- that this routine is defended against unanalyzed expressions. Such + -- expressions will not cause a blowup, they may cause pessimistic (i.e. + -- False) results to be returned. In general we take a pessimistic view. + -- False does not mean the value could not be known at compile time, but + -- True means that absolutely definition it is known at compile time and + -- it is safe to call Expr_Value on the expression Op. + -- + -- Note that we don't define precisely the set of expressions that return + -- True. Callers should not make any assumptions regarding the value that + -- is returned for non-static expressions. Functional behavior should never + -- be affected by whether a given non-static expression returns True or + -- False when this function is called. In other words this is purely for + -- efficiency optimization purposes. The code generated can often be more + -- efficient with compile time known values, e.g. range analysis for the + -- purpose of removing checks is more effective if we know precise bounds. + -- + -- The Ignore_CRT parameter has to do with the special case of configurable + -- runtime mode. Consider the following example: + -- + -- X := B ** C; + -- + -- Now if C is compile time known, and has the value 4, then inline code + -- can be generated at compile time, instead of calling a run-time routine. + -- That's fine in the normal case, but when we have a configurable run-time + -- the run-time routine may not be available. This means that the program + -- will be rejected if C is not known at compile time. We don't want the + -- legality of a program to depend on how clever the implementation of this + -- function is. If the run-time in use lacks the exponentiation routine, + -- then what we say is that exponentiation is permitted if the exponent is + -- officially static and has a value in the range 0 .. 4. + -- + -- However, in the normal case, we want efficient code in the case where + -- a non-static exponent is known at compile time. To take care of this, + -- the normal default behavior is that in configurable run-time mode most + -- expressions are considered known at compile time ONLY in the case where + -- they are officially static. An exception is boolean objects which may + -- be considered known at compile time even in configurable run-time mode. + -- + -- That loses optimization opportunities, and it would be better to look + -- case by case at each use of Compile_Time_Known_Value to see if this + -- configurable run-time mode special processing is needed. The Ignore_CRT + -- parameter can be set to True to ignore this special handling in cases + -- where it is known to be safe to do so. function Compile_Time_Known_Value_Or_Aggr (Op : Node_Id) return Boolean; -- Similar to Compile_Time_Known_Value, but also returns True if the value diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3919dc5cce5..3dca78ec14f 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -10301,6 +10301,14 @@ package body Sem_Res is Op_Node : Node_Id; begin + -- Do not perform this transformation within a pre/postcondition, + -- because the expression will be re-analyzed, and the transformation + -- might affect the visibility of the operator, e.g. in an instance. + + if In_Assertion_Expr > 0 then + return; + end if; + -- Rewrite the operator node using the real operator, not its renaming. -- Exclude user-defined intrinsic operations of the same name, which are -- treated separately and rewritten as calls. diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index ba583398e08..8556f3e776b 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -930,8 +930,10 @@ package body Sinfo is (N : Node_Id) return Boolean is begin pragma Assert (False - or else NT (N).Nkind = N_Selected_Component); - return Flag13 (N); + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Selected_Component + or else NT (N).Nkind = N_Type_Conversion); + return Flag1 (N); end Do_Discriminant_Check; function Do_Division_Check @@ -4078,8 +4080,10 @@ package body Sinfo is (N : Node_Id; Val : Boolean := True) is begin pragma Assert (False - or else NT (N).Nkind = N_Selected_Component); - Set_Flag13 (N, Val); + or else NT (N).Nkind = N_Assignment_Statement + or else NT (N).Nkind = N_Selected_Component + or else NT (N).Nkind = N_Type_Conversion); + Set_Flag1 (N, Val); end Set_Do_Discriminant_Check; procedure Set_Do_Division_Check diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 4496672dece..f0af4a2cbea 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -638,9 +638,7 @@ package Sinfo is -- 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 (see further description in spec of Lib package). - -- ??? Above note about Lib is dubious since lib.ads does not mention - -- Acts_As_Spec at all. + -- unit node instead. -- Actual_Designated_Subtype (Node4-Sem) -- Present in N_Free_Statement and N_Explicit_Dereference nodes. If gigi @@ -902,14 +900,16 @@ package Sinfo is -- that an accessibility check is required for the parameter. It is -- not yet decided who takes care of this check (TBD ???). - -- Do_Discriminant_Check (Flag13-Sem) + -- Do_Discriminant_Check (Flag1-Sem) -- This flag is set on N_Selected_Component nodes to indicate that a -- discriminant check is required using the discriminant check routine -- associated with the selector. The actual check is generated by the -- expander when processing selected components. In the case of -- Unchecked_Union, the flag is also set, but no discriminant check -- routine is associated with the selector, and the expander does not - -- generate a check. + -- generate a check. This flag is also present in assignment statements + -- (and set if the assignment requires a discriminant check), and in type + -- conversion nodes (and set if the conversion requires a check). -- Do_Division_Check (Flag13-Sem) -- This flag is set on a division operator (/ mod rem) to indicate @@ -1682,11 +1682,10 @@ package Sinfo is -- is undefined and should not be read). -- No_Ctrl_Actions (Flag7-Sem) - -- Present in N_Assignment_Statement to indicate that no finalize nor - -- adjust should take place on this assignment even though the rhs is + -- Present in N_Assignment_Statement to indicate that no Finalize nor + -- Adjust should take place on this assignment even though the RHS is -- controlled. This is used in init procs and aggregate expansions where - -- the generated assignments are more initialisations than real - -- assignments. + -- the generated assignments are initializations, not real assignments. -- No_Elaboration_Check (Flag14-Sem) -- Present in N_Function_Call and N_Procedure_Call_Statement. Indicates @@ -3439,7 +3438,7 @@ package Sinfo is -- Prefix (Node3) -- Selector_Name (Node2) -- Associated_Node (Node4-Sem) - -- Do_Discriminant_Check (Flag13-Sem) + -- Do_Discriminant_Check (Flag1-Sem) -- Is_In_Discriminant_Check (Flag11-Sem) -- Is_Prefixed_Call (Flag17-Sem) -- Atomic_Sync_Required (Flag14-Sem) @@ -4197,12 +4196,13 @@ package Sinfo is -- Sloc points to first token of subtype mark -- Subtype_Mark (Node4) -- Expression (Node3) - -- Do_Tag_Check (Flag13-Sem) + -- Do_Discriminant_Check (Flag1-Sem) -- Do_Length_Check (Flag4-Sem) - -- Do_Overflow_Check (Flag17-Sem) -- Float_Truncate (Flag11-Sem) - -- Rounded_Result (Flag18-Sem) + -- Do_Tag_Check (Flag13-Sem) -- Conversion_OK (Flag14-Sem) + -- Do_Overflow_Check (Flag17-Sem) + -- Rounded_Result (Flag18-Sem) -- plus fields for expression -- Note: if a range check is required, then the Do_Range_Check flag @@ -4360,6 +4360,7 @@ package Sinfo is -- Sloc points to := -- Name (Node2) -- Expression (Node3) + -- Do_Discriminant_Check (Flag1-Sem) -- Do_Tag_Check (Flag13-Sem) -- Do_Length_Check (Flag4-Sem) -- Forwards_OK (Flag5-Sem) @@ -8680,7 +8681,7 @@ package Sinfo is (N : Node_Id) return Boolean; -- Flag13 function Do_Discriminant_Check - (N : Node_Id) return Boolean; -- Flag13 + (N : Node_Id) return Boolean; -- Flag1 function Do_Division_Check (N : Node_Id) return Boolean; -- Flag13 @@ -9682,7 +9683,7 @@ package Sinfo is (N : Node_Id; Val : Boolean := True); -- Flag13 procedure Set_Do_Discriminant_Check - (N : Node_Id; Val : Boolean := True); -- Flag13 + (N : Node_Id; Val : Boolean := True); -- Flag1 procedure Set_Do_Division_Check (N : Node_Id; Val : Boolean := True); -- Flag13 diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 4de6b8529f1..f14813013b1 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -1184,10 +1184,9 @@ package body Treepr is when F_Field5 => Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty); - -- Flag3 is obsolete, so this probably gets removed ??? - - when F_Flag3 => Field_To_Be_Printed := Has_Aspects (N); - + when F_Flag1 => Field_To_Be_Printed := Flag1 (N); + when F_Flag2 => Field_To_Be_Printed := Flag2 (N); + when F_Flag3 => Field_To_Be_Printed := Flag3 (N); when F_Flag4 => Field_To_Be_Printed := Flag4 (N); when F_Flag5 => Field_To_Be_Printed := Flag5 (N); when F_Flag6 => Field_To_Be_Printed := Flag6 (N); @@ -1203,11 +1202,6 @@ package body Treepr is when F_Flag16 => Field_To_Be_Printed := Flag16 (N); when F_Flag17 => Field_To_Be_Printed := Flag17 (N); when F_Flag18 => Field_To_Be_Printed := Flag18 (N); - - -- Flag1,2 are no longer used - - when F_Flag1 => raise Program_Error; - when F_Flag2 => raise Program_Error; end case; -- Print field if it is to be printed @@ -1233,14 +1227,15 @@ package body Treepr is -- Special case End_Span = Uint5 when F_Field5 => - if Nkind (N) = N_Case_Statement - or else Nkind (N) = N_If_Statement - then + if Nkind_In (N, N_Case_Statement, N_If_Statement) then Print_End_Span (N); else Print_Field (Field5 (N), Fmt); end if; + when F_Flag1 => Print_Flag (Flag1 (N)); + when F_Flag2 => Print_Flag (Flag2 (N)); + when F_Flag3 => Print_Flag (Flag3 (N)); when F_Flag4 => Print_Flag (Flag4 (N)); when F_Flag5 => Print_Flag (Flag5 (N)); when F_Flag6 => Print_Flag (Flag6 (N)); @@ -1256,15 +1251,6 @@ package body Treepr is when F_Flag16 => Print_Flag (Flag16 (N)); when F_Flag17 => Print_Flag (Flag17 (N)); when F_Flag18 => Print_Flag (Flag18 (N)); - - -- Flag1,2 are no longer used - - when F_Flag1 => raise Program_Error; - when F_Flag2 => raise Program_Error; - - -- Not clear why we need the following ??? - - when F_Flag3 => Print_Flag (Has_Aspects (N)); end case; Print_Eol; diff --git a/gcc/ada/treeprs.adt b/gcc/ada/treeprs.adt index 8543fba70cf..b65d6c26b58 100644 --- a/gcc/ada/treeprs.adt +++ b/gcc/ada/treeprs.adt @@ -6,7 +6,7 @@ -- -- -- T e m p l a t e -- -- -- --- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2013, 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- -- @@ -50,6 +50,9 @@ package Treeprs is -- could never occur in a field name, so they also mark the end of the -- previous name. + -- Note the following definitions do not include Flag0. This will have to + -- be addressed if we ever need to use Flag0 (it's not currently used). + subtype Fchar is Character range '#' .. '9'; F_Field1 : constant Fchar := '#'; -- Character'Val (16#23#)