+2009-06-20 Ed Schonberg <schonberg@adacore.com>
+
+ * exp_ch3.adb (Build_Record_Init_Proc): When copying initial
+ expressions (possibly from a parent type) indicate that the scope of
+ the new itypes is the initialization procedure being built.
+
+2009-06-20 Robert Dewar <dewar@adacore.com>
+
+ * a-nudira.adb (Fits_In_32_Bits): New name (inverted sense) for
+ Needs_64, and now computed without anomolies for some dynamic types.
+
+2009-06-20 Thomas Quinot <quinot@adacore.com>
+
+ * sem_prag.adb: Minor reformatting
+
+ * exp_disp.ads: Minor reformatting
+
2009-06-20 Ed Schonberg <schonberg@adacore.com>
* sem_ch3.adb (Is_OK_For_Limited_Init): An unchecked conversion of a
type Pointer is access all State;
- Need_64 : constant Boolean := Rst'Pos (Rst'Last) > 2**31 - 1
- or else
- Rst'Pos (Rst'First) < 2**31;
- -- Set if we need more than 32 bits in the result. In practice we will
- -- only use the meaningful 48 bits of any 64 bit number generated, since
- -- if more than 48 bits are required, we split the computation into two
- -- separate parts, since the algorithm does not behave above 48 bits.
+ Fits_In_32_Bits : constant Boolean :=
+ Rst'Size < 31
+ or else (Rst'Size = 31
+ and then Rst'Pos (Rst'First) < 0);
+ -- This is set True if we do not need more than 32 bits in the result. If
+ -- we need 64-bits, we will only use the meaningful 48 bits of any 64-bit
+ -- number generated, since if more than 48 bits are required, we split the
+ -- computation into two separate parts, since the algorithm does not behave
+ -- above 48 bits.
+
+ -- The way this expression works is that obviously if the size is 31 bits,
+ -- it fits in 32 bits. In the 32-bit case, it fits in 32-bit signed if the
+ -- range has negative values. It is too conservative in the case that the
+ -- programmer has set a size greater than the default, e.g. a size of 33
+ -- for an integer type with a size of 1..10. But an over-conservative
+ -- result is OK. The important thing is that the value is only True if
+ -- we know the result will fit in 32-bits signed. If the value is False
+ -- when it could be True, the behavior will be correct, just a bit less
+ -- efficient than it could have been in some unusual cases.
--
- -- Note: the right hand side used to be Int'Last, but that won't work
- -- since it means that if Rst is a dynamic subtype, the comparison is
- -- evaluated at run time in type Int, which is too small. In practice
- -- the use of dynamic bounds is rare, and this constant will always
- -- be evaluated at compile time in an instance.
- --
- -- This still is not quite right for dynamic subtypes of 64-bit modular
- -- types where the upper bound can exceed the upper bound of universal
- -- integer. Not clear how to do this with a nice static expression ???
- -- Might have to introduce a special Type'First_In_32_Bits attribute!
+ -- One might assume that we could get a more accurate result by testing
+ -- the lower and upper bounds of the type Rst against the bounds of 32-bit
+ -- Integer. However, there is no easy way to do that. Why? Because in the
+ -- relatively rare case where this expresion has to be evaluated at run
+ -- time rather than compile time (when the bounds are dynamic), we need a
+ -- type to use for the computation. But the possible range of upper bound
+ -- values for Rst (remembering the possibility of 64-bit modular types) is
+ -- from -2**63 to 2**64-1, and no run-time type has a big enough range.
-----------------------
-- Local Subprograms --
if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then
return Rst'First;
- elsif Need_64 then
+ elsif not Fits_In_32_Bits then
return Rst'Val (Interfaces.Integer_64 (TF));
else
-- Take a copy of Exp to ensure that later copies of this component
-- declaration in derived types see the original tree, not a node
- -- rewritten during expansion of the init_proc.
+ -- rewritten during expansion of the init_proc. If the copy contains
+ -- itypes, the scope of the new itypes is the init.proc being built.
- Exp := New_Copy_Tree (Exp);
+ Exp := New_Copy_Tree (Exp, New_Scope => Proc_Id);
Res := New_List (
Make_Assignment_Statement (Loc,
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
- Prefix => New_Copy_Tree (Lhs),
+ Prefix => New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Selector_Name =>
New_Reference_To (First_Tag_Component (Typ), Loc)),
then
Append_List_To (Res,
Make_Adjust_Call (
- Ref => New_Copy_Tree (Lhs),
+ Ref => New_Copy_Tree (Lhs, New_Scope => Proc_Id),
Typ => Etype (Id),
Flist_Ref =>
- Find_Final_List (Etype (Id), New_Copy_Tree (Lhs)),
+ Find_Final_List
+ (Etype (Id), New_Copy_Tree (Lhs, New_Scope => Proc_Id)),
With_Attach => Make_Integer_Literal (Loc, 1)));
end if;
-- Snames.adb.
-- Categorize the new PPO name as predefined by adding an entry in
- -- Is_Predefined_Dispatching_Operation in Exp_Util.adb.
+ -- Is_Predefined_Dispatching_Operation in Exp_Disp.
-- Generate the specification of the new PPO in Make_Predefined_
-- Primitive_Spec in Exp_Ch3.adb. The Is_Internal flag of the defining
end if;
if Warn_On_Export_Import and then Is_Exported (Def_Id) then
- Error_Msg_N
- ("?duplicate Export_Object pragma", N);
+ Error_Msg_N ("?duplicate Export_Object pragma", N);
else
Set_Exported (Def_Id, Arg_Internal);
end if;
("?duplicate Import_Object pragma", N);
-- Check for explicit initialization present. Note that an
- -- initialization that generated by the code generator, e.g.
- -- for an access type, does not count here.
+ -- initialization generated by the code generator, e.g. for an
+ -- access type, does not count here.
elsif Present (Expression (Parent (Def_Id)))
and then
Formal := First_Formal (Ent);
if No (Formal) then
- Error_Pragma
- ("at least one parameter required for pragma%");
+ Error_Pragma ("at least one parameter required for pragma%");
elsif Ekind (Formal) /= E_Out_Parameter then
- Error_Pragma
- ("first parameter must have mode out for pragma%");
+ Error_Pragma ("first parameter must have mode out for pragma%");
else
Set_Is_Valued_Procedure (Ent);
git://gcc.gnu.org / gcc.git / commitdiff