+2017-04-27 Yannick Moy <moy@adacore.com>
+
+ * exp_unst.ads: Fix typos in comments.
+
+2017-04-27 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_eval.adb (Choice_Matches): Handle properly a real literal
+ whose type has a defined static predicate.
+
+2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * 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 <derodat@adacore.com>
* gcc-interface/utils.c (gnat_type_for_size): Set
-------------------------------
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;
-- 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;
-- 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
-- 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;
-- 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);
-- <Stmt>;
-- 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));
-- 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 =>
-- --
-- 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- --
-- 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
-- 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
-- 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.
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)
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);
projects / gcc.git / commitdiff