[Ada] Fix gigi abort (patch)
Geert Bosch
bosch@gnat.com
Wed Oct 10 15:50:00 GMT 2001
Checked in for Ed.
-Geert
2001-10-10 Ed Schonberg <schonber@gnat.com>
* einfo.adb (Write_Field19_Name): Body_Entity is also defined for
a generic package.
* einfo.ads: Body_Entity is also defined for generic package.
Documentation change only
* exp_aggr.adb (Build_Array_Aggr_Code): When expanding an
others_choice for a discriminated component initialization,
convert discriminant references into the corresponding discriminals.
* exp_ch3.adb (Get_Simple_Init_Val): Add qualification to aggregate
only if original type is private and expression has to be wrapped
in a conversion.
* checks.adb:
(Apply_Constraint_Check): Do not perform length check
if expression is an aggregate with only an others_choice.
(Length_N_Cond): two references to the same in_parameter
(typically the discriminal in an init_proc) denote the same value.
Two useful optimization uncovered by bugfixes above.
*** einfo.adb 2001/09/20 01:22:37 1.630
--- einfo.adb 2001/10/03 03:10:47 1.631
*************** package body Einfo is
*** 6569,6575 ****
when E_Discriminant =>
Write_Str ("Corresponding_Discriminant");
! when E_Package =>
Write_Str ("Body_Entity");
when E_Package_Body |
--- 6569,6576 ----
when E_Discriminant =>
Write_Str ("Corresponding_Discriminant");
! when E_Package |
! E_Generic_Package =>
Write_Str ("Body_Entity");
when E_Package_Body |
*** einfo.ads 2001/09/20 01:22:34 1.640
--- einfo.ads 2001/10/03 04:24:59 1.641
*************** package Einfo is
*** 397,404 ****
-- Present in block entities. Points to the Block_Statement itself.
-- Body_Entity (Node19)
! -- Present in package entities, points to the corresponding package
! -- body entity if one is present.
-- C_Pass_By_Copy (Flag125) [implementation base type only]
-- Present in record types. Set if a pragma Convention for the record
--- 397,404 ----
-- Present in block entities. Points to the Block_Statement itself.
-- Body_Entity (Node19)
! -- Present in package and generic package entities, points to the
! -- corresponding package body entity if one is present.
-- C_Pass_By_Copy (Flag125) [implementation base type only]
-- Present in record types. Set if a pragma Convention for the record
*** exp_aggr.adb 2001/07/24 16:59:09 1.170
--- exp_aggr.adb 2001/10/03 17:49:34 1.171
*************** package body Exp_Aggr is
*** 1136,1141 ****
--- 1136,1159 ----
High := Add (-1, To => Table (J + 1).Choice_Lo);
end if;
+ -- If this is an expansion within an init_proc, make
+ -- sure that discriminant references are replaced by
+ -- the corresponding discriminal.
+
+ if Inside_Init_Proc then
+ if Is_Entity_Name (Low)
+ and then Ekind (Entity (Low)) = E_Discriminant
+ then
+ Set_Entity (Low, Discriminal (Entity (Low)));
+ end if;
+
+ if Is_Entity_Name (High)
+ and then Ekind (Entity (High)) = E_Discriminant
+ then
+ Set_Entity (High, Discriminal (Entity (High)));
+ end if;
+ end if;
+
if First
or else not Empty_Range (Low, High)
then
*** exp_ch3.adb 2001/09/23 23:13:27 1.481
--- exp_ch3.adb 2001/10/03 17:49:35 1.482
*************** package body Exp_Ch3 is
*** 4210,4229 ****
then
pragma Assert (Init_Or_Norm_Scalars);
- -- Build aggregate with an explicit qualification, because it
- -- may otherwise be ambiguous in context.
-
return
! Make_Qualified_Expression (Loc,
! Subtype_Mark => New_Occurrence_Of (T, Loc),
! Expression =>
! Make_Aggregate (Loc,
! Component_Associations => New_List (
! Make_Component_Association (Loc,
! Choices => New_List (
! Make_Others_Choice (Loc)),
! Expression =>
! Get_Simple_Init_Val (Component_Type (T), Loc)))));
-- Access type is initialized to null
--- 4210,4223 ----
then
pragma Assert (Init_Or_Norm_Scalars);
return
! Make_Aggregate (Loc,
! Component_Associations => New_List (
! Make_Component_Association (Loc,
! Choices => New_List (
! Make_Others_Choice (Loc)),
! Expression =>
! Get_Simple_Init_Val (Component_Type (T), Loc))));
-- Access type is initialized to null
*************** package body Exp_Ch3 is
*** 4267,4274 ****
-- A special case, if the underlying value is null, then qualify
-- it with the underlying type, so that the null is properly typed
! if Nkind (Val) = N_Null then
Val :=
Make_Qualified_Expression (Loc,
Subtype_Mark =>
--- 4261,4272 ----
-- A special case, if the underlying value is null, then qualify
-- it with the underlying type, so that the null is properly typed
+ -- Similarly, if it is an aggregate it must be qualified, because
+ -- an unchecked conversion does not provide a context for it.
! if Nkind (Val) = N_Null
! or else Nkind (Val) = N_Aggregate
! then
Val :=
Make_Qualified_Expression (Loc,
Subtype_Mark =>
*** checks.adb 2001/09/23 23:11:35 1.205
--- checks.adb 2001/10/03 17:49:37 1.206
*************** package body Checks is
*** 692,697 ****
--- 692,709 ----
elsif Is_Array_Type (Typ) then
+ -- A useful optimization: an aggregate with only an Others clause
+ -- always has the right bounds.
+
+ if Nkind (N) = N_Aggregate
+ and then No (Expressions (N))
+ and then Nkind
+ (First (Choices (First (Component_Associations (N)))))
+ = N_Others_Choice
+ then
+ return;
+ end if;
+
if Is_Constrained (Typ) then
Apply_Length_Check (N, Typ);
*************** package body Checks is
*** 2805,2812 ****
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
-- True for equal literals and for nodes that denote the same constant
! -- entity, even if its value is not a static constant. This removes
! -- some obviously superfluous checks.
function Length_E_Cond
(Exptyp : Entity_Id;
--- 2817,2825 ----
function Same_Bounds (L : Node_Id; R : Node_Id) return Boolean;
-- True for equal literals and for nodes that denote the same constant
! -- entity, even if its value is not a static constant. This includes the
! -- case of a discriminal reference within an init_proc. Removes some
! -- obviously superfluous checks.
function Length_E_Cond
(Exptyp : Entity_Id;
*************** package body Checks is
*** 3038,3044 ****
and then Ekind (Entity (R)) = E_Constant
and then Nkind (L) = N_Type_Conversion
and then Is_Entity_Name (Expression (L))
! and then Entity (R) = Entity (Expression (L)));
end Same_Bounds;
-- Start of processing for Selected_Length_Checks
--- 3051,3064 ----
and then Ekind (Entity (R)) = E_Constant
and then Nkind (L) = N_Type_Conversion
and then Is_Entity_Name (Expression (L))
! and then Entity (R) = Entity (Expression (L)))
!
! or else
! (Is_Entity_Name (L)
! and then Is_Entity_Name (R)
! and then Entity (L) = Entity (R)
! and then Ekind (Entity (L)) = E_In_Parameter
! and then Inside_Init_Proc);
end Same_Bounds;
-- Start of processing for Selected_Length_Checks
More information about the Gcc-patches
mailing list