From aa9b151a9e3630f78c1517d016fa26dc3277b506 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 6 Feb 2014 15:15:51 +0100 Subject: [PATCH] [multiple changes] 2014-02-06 Hristian Kirtchev * sem_prag.adb (Analyze_Refined_Pragma): Remove local variable Pack_Spec. Refinement pragmas may now apply to bodies of both visible and private subprograms. 2014-02-06 Robert Dewar * exp_attr.adb (Expand_Loop_Entry_Attribute): Minor change (Attr => N) (Expand_Pred_Succ): New name Expand_Pred_Succ_Attribute (Expand_N_Attribute_Reference, case Max): Expand into if expression if Modify_Tree_For_C mode. (Expand_N_Attribute_Reference, case Min): ditto * sinfo.ads: Modify_Tree_For_C takes care of expanding Min and Max attributes. 2014-02-06 Ed Schonberg * sem_ch3.adb (Analyze_Object_Declaration): Do not generate predicate check if this is an internal declaration with No_Initialization set, as for an expanded aggregate component. 2014-02-06 Doug Rupp * init.c (__gnat_default_resignal_p) [VMS]: Test for and resignal conditions with severity of "SUCCESS" or "INFORMATIONAL". From-SVN: r207559 --- gcc/ada/ChangeLog | 27 ++++++++++ gcc/ada/exp_attr.adb | 117 +++++++++++++++++++++++++++++++++---------- gcc/ada/init.c | 4 ++ gcc/ada/sem_ch3.adb | 5 +- gcc/ada/sem_prag.adb | 26 ++++------ gcc/ada/sinfo.ads | 9 ++++ 6 files changed, 146 insertions(+), 42 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 01f2489ba5cb..d9ca753c25bd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,30 @@ +2014-02-06 Hristian Kirtchev + + * sem_prag.adb (Analyze_Refined_Pragma): Remove + local variable Pack_Spec. Refinement pragmas may now apply to + bodies of both visible and private subprograms. + +2014-02-06 Robert Dewar + + * exp_attr.adb (Expand_Loop_Entry_Attribute): + Minor change (Attr => N) (Expand_Pred_Succ): New name + Expand_Pred_Succ_Attribute (Expand_N_Attribute_Reference, case + Max): Expand into if expression if Modify_Tree_For_C mode. + (Expand_N_Attribute_Reference, case Min): ditto + * sinfo.ads: Modify_Tree_For_C takes care of expanding Min and + Max attributes. + +2014-02-06 Ed Schonberg + + * sem_ch3.adb (Analyze_Object_Declaration): Do not generate + predicate check if this is an internal declaration with + No_Initialization set, as for an expanded aggregate component. + +2014-02-06 Doug Rupp + + * init.c (__gnat_default_resignal_p) [VMS]: Test for and resignal + conditions with severity of "SUCCESS" or "INFORMATIONAL". + 2014-02-06 Yannick Moy * sem_prag.adb (Analyze_Pragma): Analyze pragma diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 624661ca753e..c54fb788903e 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -136,11 +136,11 @@ package body Exp_Attr is -- that takes two floating-point arguments. The function to be called -- is always the same as the attribute name. - procedure Expand_Loop_Entry_Attribute (Attr : Node_Id); + procedure Expand_Loop_Entry_Attribute (N : Node_Id); -- Handle the expansion of attribute 'Loop_Entry. As a result, the related -- loop may be converted into a conditional block. See body for details. - procedure Expand_Pred_Succ (N : Node_Id); + procedure Expand_Pred_Succ_Attribute (N : Node_Id); -- Handles expansion of Pred or Succ attributes for case of non-real -- operand with overflow checking required. @@ -657,7 +657,7 @@ package body Exp_Attr is -- Expand_Loop_Entry_Attribute -- --------------------------------- - procedure Expand_Loop_Entry_Attribute (Attr : Node_Id) is + procedure Expand_Loop_Entry_Attribute (N : Node_Id) is procedure Build_Conditional_Block (Loc : Source_Ptr; Cond : Node_Id; @@ -730,8 +730,8 @@ package body Exp_Attr is -- Local variables - Exprs : constant List_Id := Expressions (Attr); - Pref : constant Node_Id := Prefix (Attr); + Exprs : constant List_Id := Expressions (N); + Pref : constant Node_Id := Prefix (N); Typ : constant Entity_Id := Etype (Pref); Blk : Node_Id; Decls : List_Id; @@ -760,7 +760,7 @@ package body Exp_Attr is -- internally generated loops for quantified expressions. else - Loop_Stmt := Attr; + Loop_Stmt := N; while Present (Loop_Stmt) loop if Nkind (Loop_Stmt) = N_Loop_Statement and then Present (Identifier (Loop_Stmt)) @@ -1002,7 +1002,7 @@ package body Exp_Attr is -- Step 4: Analyze all bits - Rewrite (Attr, New_Reference_To (Temp_Id, Loc)); + Rewrite (N, New_Reference_To (Temp_Id, Loc)); Installed := Current_Scope = Scope (Loop_Id); @@ -1028,7 +1028,7 @@ package body Exp_Attr is Analyze (Temp_Decl); end if; - Analyze (Attr); + Analyze (N); if not Installed then Pop_Scope; @@ -3616,6 +3616,44 @@ package body Exp_Attr is Analyze_And_Resolve (N, Typ); end Mantissa; + --------- + -- Max -- + --------- + + when Attribute_Max => + + -- Max is handled by the back end (except that static cases have + -- already been evaluated during semantic processing, but anyway + -- the back end should not count on this). The one bit of special + -- processing required in the normal case is that this attribute + -- typically generates conditionals in the code, so we must check + -- the relevant restriction. + + Check_Restriction (No_Implicit_Conditionals, N); + + -- In Modify_Tree_For_C mode, we rewrite as an if expression + + if Modify_Tree_For_C then + declare + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Expr : constant Node_Id := First (Expressions (N)); + Left : constant Node_Id := Relocate_Node (Expr); + Right : constant Node_Id := Relocate_Node (Next (Expr)); + + begin + Rewrite (N, + Make_If_Expression (Loc, + Expressions => New_List ( + Make_Op_Ge (Loc, + Left_Opnd => Left, + Right_Opnd => Right), + Duplicate_Subexpr_No_Checks (Left), + Duplicate_Subexpr_No_Checks (Right)))); + Analyze_And_Resolve (N, Typ); + end; + end if; + ---------------------------------- -- Max_Size_In_Storage_Elements -- ---------------------------------- @@ -3703,6 +3741,44 @@ package body Exp_Attr is Set_Renamed_Subprogram (Pref, Alias (Entity (Pref))); end if; + --------- + -- Min -- + --------- + + when Attribute_Min => + + -- Min is handled by the back end (except that static cases have + -- already been evaluated during semantic processing, but anyway + -- the back end should not count on this). The one bit of special + -- processing required in the normal case is that this attribute + -- typically generates conditionals in the code, so we must check + -- the relevant restriction. + + Check_Restriction (No_Implicit_Conditionals, N); + + -- In Modify_Tree_For_C mode, we rewrite as an if expression + + if Modify_Tree_For_C then + declare + Loc : constant Source_Ptr := Sloc (N); + Typ : constant Entity_Id := Etype (N); + Expr : constant Node_Id := First (Expressions (N)); + Left : constant Node_Id := Relocate_Node (Expr); + Right : constant Node_Id := Relocate_Node (Next (Expr)); + + begin + Rewrite (N, + Make_If_Expression (Loc, + Expressions => New_List ( + Make_Op_Le (Loc, + Left_Opnd => Left, + Right_Opnd => Right), + Duplicate_Subexpr_No_Checks (Left), + Duplicate_Subexpr_No_Checks (Right)))); + Analyze_And_Resolve (N, Typ); + end; + end if; + --------- -- Mod -- --------- @@ -4378,7 +4454,7 @@ package body Exp_Attr is or else Do_Range_Check (First (Exprs)) then Set_Do_Range_Check (First (Exprs), False); - Expand_Pred_Succ (N); + Expand_Pred_Succ_Attribute (N); end if; end Pred; @@ -5426,7 +5502,7 @@ package body Exp_Attr is or else Do_Range_Check (First (Exprs)) then Set_Do_Range_Check (First (Exprs), False); - Expand_Pred_Succ (N); + Expand_Pred_Succ_Attribute (N); end if; end Succ; @@ -6438,17 +6514,6 @@ package body Exp_Attr is when Attribute_Component_Size => null; - -- The following attributes are handled by the back end (except that - -- static cases have already been evaluated during semantic processing, - -- but in any case the back end should not count on this). The one bit - -- of special processing required is that these attributes typically - -- generate conditionals in the code, so we need to check the relevant - -- restriction. - - when Attribute_Max | - Attribute_Min => - Check_Restriction (No_Implicit_Conditionals, N); - -- The following attributes are handled by the back end (except that -- static cases have already been evaluated during semantic processing, -- but in any case the back end should not count on this). @@ -6552,9 +6617,9 @@ package body Exp_Attr is return; end Expand_N_Attribute_Reference; - ---------------------- - -- Expand_Pred_Succ -- - ---------------------- + -------------------------------- + -- Expand_Pred_Succ_Attribute -- + -------------------------------- -- For typ'Pred (exp), we generate the check @@ -6570,7 +6635,7 @@ package body Exp_Attr is -- statement or the expression of an object declaration, where the flag -- Suppress_Assignment_Checks is set for the assignment/declaration. - procedure Expand_Pred_Succ (N : Node_Id) is + procedure Expand_Pred_Succ_Attribute (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); P : constant Node_Id := Parent (N); Cnam : Name_Id; @@ -6598,7 +6663,7 @@ package body Exp_Attr is Attribute_Name => Cnam)), Reason => CE_Overflow_Check_Failed)); end if; - end Expand_Pred_Succ; + end Expand_Pred_Succ_Attribute; ----------------------------- -- Expand_Update_Attribute -- diff --git a/gcc/ada/init.c b/gcc/ada/init.c index e943837d07a5..fb94198b1e20 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -809,6 +809,7 @@ void (*__gnat_ctrl_c_handler) (void) = 0; /* Masks for facility identification. */ #define FAC_MASK 0x0fff0000 #define DECADA_M_FACILITY 0x00310000 +#define SEVERITY_MASK 0x7 /* Define macro symbols for the VMS conditions that become Ada exceptions. It would be better to just include */ @@ -1068,6 +1069,9 @@ __gnat_default_resignal_p (int code) if ((code & FAC_MASK) == facility_resignal_table [i]) return 1; + if ((code & SEVERITY_MASK) == 1 || (code & SEVERITY_MASK) == 3) + return 1; + for (i = 0, iexcept = 0; cond_resignal_table [i] && !(iexcept = LIB$MATCH_COND (&code, &cond_resignal_table [i])); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index cf5f4a6eaba9..c763bd60b235 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -3551,10 +3551,13 @@ package body Sem_Ch3 is -- We need a predicate check if the type has predicates, and if either -- there is an initializing expression, or for default initialization - -- when we have at least one case of an explicit default initial value. + -- when we have at least one case of an explicit default initial value + -- and then this is not an internal declaration whose initialization + -- comes later (as for an aggregate expansion). if not Suppress_Assignment_Checks (N) and then Present (Predicate_Function (T)) + and then not No_Initialization (N) and then (Present (E) or else diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4b304dbbb782..1f46ae2222b9 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3616,7 +3616,6 @@ package body Sem_Prag is Legal : out Boolean) is Body_Decl : Node_Id; - Pack_Spec : Node_Id; Spec_Decl : Node_Id; begin @@ -3676,14 +3675,10 @@ package body Sem_Prag is N_Generic_Subprogram_Declaration, N_Subprogram_Declaration)); - Pack_Spec := Parent (Spec_Decl); - - if Nkind (Pack_Spec) /= N_Package_Specification - or else List_Containing (Spec_Decl) /= - Visible_Declarations (Pack_Spec) - then + if Nkind (Parent (Spec_Decl)) /= N_Package_Specification then Error_Pragma - ("pragma % must apply to the body of a visible subprogram"); + ("pragma % must apply to the body of a subprogram declared in a " + & "package specification"); return; end if; @@ -12622,13 +12617,14 @@ package body Sem_Prag is Freeze_Before (N, Entity (Name (Call))); end if; - Rewrite (N, Make_Implicit_If_Statement (N, - Condition => Cond, - Then_Statements => New_List ( - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Relocate_Node (Call))))))); + Rewrite (N, + Make_Implicit_If_Statement (N, + Condition => Cond, + Then_Statements => New_List ( + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Relocate_Node (Call))))))); Analyze (N); -- Ignore pragma Debug in GNATprove mode. Do this rewriting diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index f399dabfaf6f..0405c647697d 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -549,6 +549,9 @@ package Sinfo is -- not make sense from a user point-of-view, and that cross-references that -- do not lead to data dependences for subprograms can be safely ignored. + -- In addition pragma Debug statements are removed from the tree (rewritten + -- to NULL stmt), since they should be taken into account in flow analysis. + ----------------------- -- Check Flag Fields -- ----------------------- @@ -636,6 +639,9 @@ package Sinfo is -- less than the word size (since other values are not well-defined in -- C). This is done using an explicit test if necessary. + -- Min and Max attributes are expanded into equivalent if expressions, + -- dealing properly with side effect issues. + ------------------------------------ -- Description of Semantic Fields -- ------------------------------------ @@ -3589,6 +3595,9 @@ package Sinfo is -- Must_Be_Byte_Aligned (Flag14) -- plus fields for expression + -- Note: in Modify_Tree_For_C mode, Max and Min attributes are expanded + -- into equivalent if expressions, properly taking care of side effects. + --------------------------------- -- 4.1.4 Attribute Designator -- --------------------------------- -- 2.47.3