From bb9e2aa27576a5dc46bc679949309de4c1600132 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 27 Apr 2017 11:52:18 +0200 Subject: [PATCH] [multiple changes] 2017-04-27 Yannick Moy * exp_unst.ads: Fix typos in comments. 2017-04-27 Ed Schonberg * sem_eval.adb (Choice_Matches): Handle properly a real literal whose type has a defined static predicate. 2017-04-27 Hristian Kirtchev * exp_ch4.adb (Insert_Dereference_Action): Do not adjust the address of a controlled object when the associated access type is subject to pragma No_Heap_Finalization. Code reformatting. From-SVN: r247304 --- gcc/ada/ChangeLog | 16 ++++++++++++++++ gcc/ada/exp_ch4.adb | 37 ++++++++++++++++++++++--------------- gcc/ada/exp_unst.ads | 14 +++++++------- gcc/ada/sem_eval.adb | 19 +++++++++++++++---- 4 files changed, 60 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 98c2fa9a4db..d6f3ec9017d 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,19 @@ +2017-04-27 Yannick Moy + + * exp_unst.ads: Fix typos in comments. + +2017-04-27 Ed Schonberg + + * sem_eval.adb (Choice_Matches): Handle properly a real literal + whose type has a defined static predicate. + +2017-04-27 Hristian Kirtchev + + * exp_ch4.adb (Insert_Dereference_Action): + Do not adjust the address of a controlled object when the + associated access type is subject to pragma No_Heap_Finalization. + Code reformatting. + 2017-04-27 Pierre-Marie de Rodat * gcc-interface/utils.c (gnat_type_for_size): Set diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index cf3f2694fa3..e247c8b6f8a 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12032,7 +12032,6 @@ package body Exp_Ch4 is ------------------------------- procedure Insert_Dereference_Action (N : Node_Id) is - function Is_Checked_Storage_Pool (P : Entity_Id) return Boolean; -- Return true if type of P is derived from Checked_Pool; @@ -12062,11 +12061,12 @@ package body Exp_Ch4 is -- Local variables - Typ : constant Entity_Id := Etype (N); - Desig : constant Entity_Id := Available_View (Designated_Type (Typ)); - Loc : constant Source_Ptr := Sloc (N); - Pool : constant Entity_Id := Associated_Storage_Pool (Typ); - Pnod : constant Node_Id := Parent (N); + Context : constant Node_Id := Parent (N); + Ptr_Typ : constant Entity_Id := Etype (N); + Desig_Typ : constant Entity_Id := + Available_View (Designated_Type (Ptr_Typ)); + Loc : constant Source_Ptr := Sloc (N); + Pool : constant Entity_Id := Associated_Storage_Pool (Ptr_Typ); Addr : Entity_Id; Alig : Entity_Id; @@ -12078,18 +12078,18 @@ package body Exp_Ch4 is -- Start of processing for Insert_Dereference_Action begin - pragma Assert (Nkind (Pnod) = N_Explicit_Dereference); + pragma Assert (Nkind (Context) = N_Explicit_Dereference); -- Do not re-expand a dereference which has already been processed by -- this routine. - if Has_Dereference_Action (Pnod) then + if Has_Dereference_Action (Context) then return; -- Do not perform this type of expansion for internally-generated -- dereferences. - elsif not Comes_From_Source (Original_Node (Pnod)) then + elsif not Comes_From_Source (Original_Node (Context)) then return; -- A dereference action is only applicable to objects which have been @@ -12131,15 +12131,15 @@ package body Exp_Ch4 is -- Special case of an unconstrained array: need to add descriptor size - if Is_Array_Type (Desig) - and then not Is_Constrained (First_Subtype (Desig)) + if Is_Array_Type (Desig_Typ) + and then not Is_Constrained (First_Subtype (Desig_Typ)) then Size_Bits := Make_Op_Add (Loc, Left_Opnd => Make_Attribute_Reference (Loc, Prefix => - New_Occurrence_Of (First_Subtype (Desig), Loc), + New_Occurrence_Of (First_Subtype (Desig_Typ), Loc), Attribute_Name => Name_Descriptor_Size), Right_Opnd => Size_Bits); end if; @@ -12181,7 +12181,14 @@ package body Exp_Ch4 is -- knowledge of hidden pointers, we have to bring the two pointers back -- in view in order to restore the original state of the object. - if Needs_Finalization (Desig) then + -- The address manipulation is not performed for access types that are + -- subject to pragma No_Heap_Finalization because the two pointers do + -- not exist in the first place. + + if No_Heap_Finalization (Ptr_Typ) then + null; + + elsif Needs_Finalization (Desig_Typ) then -- Adjust the address and size of the dereferenced object. Generate: -- Adjust_Controlled_Dereference (Addr, Size, Alig); @@ -12203,7 +12210,7 @@ package body Exp_Ch4 is -- ; -- end if; - if Is_Class_Wide_Type (Desig) then + if Is_Class_Wide_Type (Desig_Typ) then Deref := Make_Explicit_Dereference (Loc, Prefix => Duplicate_Subexpr_Move_Checks (N)); @@ -12242,7 +12249,7 @@ package body Exp_Ch4 is -- Mark the explicit dereference as processed to avoid potential -- infinite expansion. - Set_Has_Dereference_Action (Pnod); + Set_Has_Dereference_Action (Context); exception when RE_Not_Available => diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index c013e25da51..1b7de11ed6a 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2014-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2014-2017, 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- -- @@ -294,13 +294,13 @@ package Exp_Unst is -- What we do is to always generate a local constant for any dynamic -- bound in a dynamic subtype xx with name xx_FIRST or xx_LAST. The one - -- case where we can skip this is where the bound is e.g. in the third - -- example above, subtype dynam is expanded as + -- case where we can skip this is where the bound is already a constant. + -- E.g. in the third example above, subtype dynam is expanded as - -- dynam_LAST : constant Integer := y + 3; + -- dynam_LAST : constant Integer := y + 3; -- subtype dynam is integer range x .. dynam_LAST; - -- Now if type dynam is uplevel referenced (as it is this case), then + -- Now if type dynam is uplevel referenced (as it is in this case), then -- the bounds x and dynam_LAST are marked as uplevel references -- so that appropriate entries are made in the activation record. Any -- explicit reference to such a bound in the front end generated code @@ -310,7 +310,7 @@ package Exp_Unst is -- these bounds can be replaced by an appropriate reference to the entry -- in the activation record for xx_FIRST or xx_LAST. Thus the back end -- can eliminate the problematical uplevel reference without the need to - -- do the heavy tree modification to do that at the code expansion level + -- do the heavy tree modification to do that at the code expansion level. -- Looking at case 3 again, here is the normal -gnatG expanded code @@ -347,7 +347,7 @@ package Exp_Unst is -- we ignore that detail to clarify the examples. -- Here we see that some of the bounds references are expanded by the - -- front end, so that we get explicit references to y or dynamLast. These + -- front end, so that we get explicit references to y or dynam_Last. These -- cases are handled by the normal uplevel reference mechanism described -- above for case 2. This is the case for the constraint check for the -- initialization of xx, and the range check in function inner. diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 073dfc6c34c..e024c6d3068 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -626,7 +626,8 @@ package body Sem_Eval is return Non_Static; -- When the choice denotes a subtype with a static predictate, check the - -- expression against the predicate values. + -- expression against the predicate values. Different procedures apply + -- to discrete and non-discrete types. elsif (Nkind (Choice) = N_Subtype_Indication or else (Is_Entity_Name (Choice) @@ -634,10 +635,20 @@ package body Sem_Eval is and then Has_Predicates (Etype (Choice)) and then Has_Static_Predicate (Etype (Choice)) then - return - Choices_Match (Expr, Static_Discrete_Predicate (Etype (Choice))); + if Is_Discrete_Type (Etype (Choice)) then + return Choices_Match + (Expr, Static_Discrete_Predicate (Etype (Choice))); + + elsif + Real_Or_String_Static_Predicate_Matches (Expr, Etype (Choice)) + then + return Match; + + else + return No_Match; + end if; - -- Discrete type case + -- Discrete type case only elsif Is_Discrete_Type (Etyp) then Val := Expr_Value (Expr); -- 2.30.2