Commit 4b6f99f5 by Robert Dewar Committed by Arnaud Charlet

exp_strm.adb (Build_Elementary_Input_Call): Clarify comments in previous checkin.

2015-01-06  Robert Dewar  <dewar@adacore.com>

	* exp_strm.adb (Build_Elementary_Input_Call): Clarify comments
	in previous checkin.
	* freeze.adb (Freeze_Fixed_Point_Type): Add warning for shaving
	of bounds.
	* sem_prag.adb, sem_ch10.adb, sem_ch6.adb: Minor reformatting.

From-SVN: r219229
parent 21f30884
2015-01-06 Robert Dewar <dewar@adacore.com>
* exp_strm.adb (Build_Elementary_Input_Call): Clarify comments
in previous checkin.
* freeze.adb (Freeze_Fixed_Point_Type): Add warning for shaving
of bounds.
* sem_prag.adb, sem_ch10.adb, sem_ch6.adb: Minor reformatting.
2015-01-06 Vincent Celier <celier@adacore.com> 2015-01-06 Vincent Celier <celier@adacore.com>
* a-strsup.adb (Times (Natural;String;Positive)): Raise * a-strsup.adb (Times (Natural;String;Positive)): Raise
......
...@@ -650,7 +650,8 @@ package body Exp_Strm is ...@@ -650,7 +650,8 @@ package body Exp_Strm is
-- Now convert to the base type if we do not have a biased type. Note -- Now convert to the base type if we do not have a biased type. Note
-- that we did not do this in some older versions, and the result was -- that we did not do this in some older versions, and the result was
-- losing some required range checking for the 'Read case. -- losing a required range check in the case where 'Input is being
-- called from 'Read.
if not Has_Biased_Representation (P_Type) then if not Has_Biased_Representation (P_Type) then
return Unchecked_Convert_To (Base_Type (P_Type), Res); return Unchecked_Convert_To (Base_Type (P_Type), Res);
...@@ -683,7 +684,6 @@ package body Exp_Strm is ...@@ -683,7 +684,6 @@ package body Exp_Strm is
Libent : Entity_Id; Libent : Entity_Id;
begin begin
-- Compute the size of the stream element. This is either the size of -- Compute the size of the stream element. This is either the size of
-- the first subtype or if given the size of the Stream_Size attribute. -- the first subtype or if given the size of the Stream_Size attribute.
......
...@@ -6711,7 +6711,12 @@ package body Freeze is ...@@ -6711,7 +6711,12 @@ package body Freeze is
Hival : Ureal; Hival : Ureal;
Atype : Entity_Id; Atype : Entity_Id;
Orig_Lo : Ureal;
Orig_Hi : Ureal;
-- Save original bounds (for shaving tests)
Actual_Size : Nat; Actual_Size : Nat;
-- Actual size chosen
function Fsize (Lov, Hiv : Ureal) return Nat; function Fsize (Lov, Hiv : Ureal) return Nat;
-- Returns size of type with given bounds. Also leaves these -- Returns size of type with given bounds. Also leaves these
...@@ -6762,6 +6767,9 @@ package body Freeze is ...@@ -6762,6 +6767,9 @@ package body Freeze is
Loval := Realval (Lo); Loval := Realval (Lo);
Hival := Realval (Hi); Hival := Realval (Hi);
Orig_Lo := Loval;
Orig_Hi := Hival;
-- Ordinary fixed-point case -- Ordinary fixed-point case
if Is_Ordinary_Fixed_Point_Type (Typ) then if Is_Ordinary_Fixed_Point_Type (Typ) then
...@@ -7130,6 +7138,24 @@ package body Freeze is ...@@ -7130,6 +7138,24 @@ package body Freeze is
Set_RM_Size (Typ, Minsiz); Set_RM_Size (Typ, Minsiz);
end if; end if;
end; end;
-- Check for shaving
if Comes_From_Source (Typ) then
if Orig_Lo < Expr_Value_R (Lo) then
Error_Msg_N
("declared low bound of type & is outside type range??", Typ);
Error_Msg_N
("\low bound adjusted up by delta (RM 3.5.9(13))??", Typ);
end if;
if Orig_Hi > Expr_Value_R (Hi) then
Error_Msg_N
("declared high bound of type & is outside type range??", Typ);
Error_Msg_N
("\high bound adjusted down by delta (RM 3.5.9(13))??", Typ);
end if;
end if;
end Freeze_Fixed_Point_Type; end Freeze_Fixed_Point_Type;
------------------ ------------------
......
...@@ -6494,6 +6494,10 @@ package body Sem_Ch10 is ...@@ -6494,6 +6494,10 @@ package body Sem_Ch10 is
Item := First (Context_Items (Comp_Unit)); Item := First (Context_Items (Comp_Unit));
while Present (Item) loop while Present (Item) loop
if Nkind (Item) = N_With_Clause if Nkind (Item) = N_With_Clause
-- The following guard is needed to ensure that the name has
-- been properly analyzed before we go fetching its entity.
and then Is_Entity_Name (Name (Item)) and then Is_Entity_Name (Name (Item))
and then Entity (Name (Item)) = E and then Entity (Name (Item)) = E
and then not Private_Present (Item) and then not Private_Present (Item)
......
...@@ -321,7 +321,8 @@ package body Sem_Ch6 is ...@@ -321,7 +321,8 @@ package body Sem_Ch6 is
-- check whether any of them is completed by the expression function. -- check whether any of them is completed by the expression function.
-- In a generic context a formal subprogram has no completion. -- In a generic context a formal subprogram has no completion.
if Present (Prev) and then Is_Overloadable (Prev) if Present (Prev)
and then Is_Overloadable (Prev)
and then not Is_Formal_Subprogram (Prev) and then not Is_Formal_Subprogram (Prev)
then then
Def_Id := Analyze_Subprogram_Specification (Spec); Def_Id := Analyze_Subprogram_Specification (Spec);
...@@ -380,7 +381,8 @@ package body Sem_Ch6 is ...@@ -380,7 +381,8 @@ package body Sem_Ch6 is
-- scope. The entity itself may be internally created if within a body -- scope. The entity itself may be internally created if within a body
-- to be inlined. -- to be inlined.
elsif Present (Prev) and then Comes_From_Source (Parent (Prev)) elsif Present (Prev)
and then Comes_From_Source (Parent (Prev))
and then not Is_Formal_Subprogram (Prev) and then not Is_Formal_Subprogram (Prev)
then then
Set_Has_Completion (Prev, False); Set_Has_Completion (Prev, False);
...@@ -2043,7 +2045,7 @@ package body Sem_Ch6 is ...@@ -2043,7 +2045,7 @@ package body Sem_Ch6 is
elsif Ekind (Typ) = E_Incomplete_Type elsif Ekind (Typ) = E_Incomplete_Type
or else (Is_Class_Wide_Type (Typ) or else (Is_Class_Wide_Type (Typ)
and then Ekind (Root_Type (Typ)) = E_Incomplete_Type) and then Ekind (Root_Type (Typ)) = E_Incomplete_Type)
then then
-- AI05-0151: Tagged incomplete types are allowed in all formal -- AI05-0151: Tagged incomplete types are allowed in all formal
-- parts. Untagged incomplete types are not allowed in bodies. -- parts. Untagged incomplete types are not allowed in bodies.
...@@ -2556,13 +2558,13 @@ package body Sem_Ch6 is ...@@ -2556,13 +2558,13 @@ package body Sem_Ch6 is
-- a null access (see Expand_Interface_Conversion) -- a null access (see Expand_Interface_Conversion)
and then not (Is_Interface (Designated_Type (Etype (Scop))) and then not (Is_Interface (Designated_Type (Etype (Scop)))
and then not Comes_From_Source (Parent (Scop))) and then not Comes_From_Source (Parent (Scop)))
and then (Has_Task (Designated_Type (Etype (Scop))) and then (Has_Task (Designated_Type (Etype (Scop)))
or else or else
(Is_Class_Wide_Type (Designated_Type (Etype (Scop))) (Is_Class_Wide_Type (Designated_Type (Etype (Scop)))
and then and then
Is_Limited_Record (Designated_Type (Etype (Scop))))) Is_Limited_Record (Designated_Type (Etype (Scop)))))
and then Expander_Active and then Expander_Active
-- Avoid cases with no tasking support -- Avoid cases with no tasking support
...@@ -2633,9 +2635,8 @@ package body Sem_Ch6 is ...@@ -2633,9 +2635,8 @@ package body Sem_Ch6 is
Nkind (N) = N_Pragma Nkind (N) = N_Pragma
and then and then
(Pragma_Name (N) = Name_Inline_Always (Pragma_Name (N) = Name_Inline_Always
or else or else (Front_End_Inlining
(Front_End_Inlining and then Pragma_Name (N) = Name_Inline))
and then Pragma_Name (N) = Name_Inline))
and then and then
Chars Chars
(Expression (First (Pragma_Argument_Associations (N)))) = (Expression (First (Pragma_Argument_Associations (N)))) =
...@@ -2822,8 +2823,9 @@ package body Sem_Ch6 is ...@@ -2822,8 +2823,9 @@ package body Sem_Ch6 is
if To_Corresponding then if To_Corresponding then
if Is_Concurrent_Type (Formal_Typ) if Is_Concurrent_Type (Formal_Typ)
and then Present (Corresponding_Record_Type (Formal_Typ)) and then Present (Corresponding_Record_Type (Formal_Typ))
and then Present (Interfaces ( and then
Corresponding_Record_Type (Formal_Typ))) Present (Interfaces
(Corresponding_Record_Type (Formal_Typ)))
then then
Set_Etype (Formal, Set_Etype (Formal,
Corresponding_Record_Type (Formal_Typ)); Corresponding_Record_Type (Formal_Typ));
...@@ -3018,7 +3020,7 @@ package body Sem_Ch6 is ...@@ -3018,7 +3020,7 @@ package body Sem_Ch6 is
begin begin
if Must_Override (Body_Spec) then if Must_Override (Body_Spec) then
if Nkind (Spec_Id) = N_Defining_Operator_Symbol if Nkind (Spec_Id) = N_Defining_Operator_Symbol
and then Operator_Matches_Spec (Spec_Id, Spec_Id) and then Operator_Matches_Spec (Spec_Id, Spec_Id)
then then
null; null;
...@@ -3044,7 +3046,7 @@ package body Sem_Ch6 is ...@@ -3044,7 +3046,7 @@ package body Sem_Ch6 is
Body_Spec, Spec_Id); Body_Spec, Spec_Id);
elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol elsif Nkind (Spec_Id) = N_Defining_Operator_Symbol
and then Operator_Matches_Spec (Spec_Id, Spec_Id) and then Operator_Matches_Spec (Spec_Id, Spec_Id)
then then
Error_Msg_NE Error_Msg_NE
("subprogram& overrides predefined operator ", ("subprogram& overrides predefined operator ",
...@@ -3407,7 +3409,7 @@ package body Sem_Ch6 is ...@@ -3407,7 +3409,7 @@ package body Sem_Ch6 is
and then not Comes_From_Source (N) and then not Comes_From_Source (N)
and then and then
(Nkind (Original_Node (Spec_Decl)) = (Nkind (Original_Node (Spec_Decl)) =
N_Subprogram_Renaming_Declaration N_Subprogram_Renaming_Declaration
or else (Present (Corresponding_Body (Spec_Decl)) or else (Present (Corresponding_Body (Spec_Decl))
and then and then
Nkind (Unit_Declaration_Node Nkind (Unit_Declaration_Node
...@@ -4962,19 +4964,19 @@ package body Sem_Ch6 is ...@@ -4962,19 +4964,19 @@ package body Sem_Ch6 is
-- F_Ptr. We catch this case in the code below. -- F_Ptr. We catch this case in the code below.
and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base) and then (Ekind (Old_Formal_Base) = Ekind (New_Formal_Base)
or else or else
(Is_Generic_Type (Old_Formal_Base) (Is_Generic_Type (Old_Formal_Base)
and then Is_Generic_Type (New_Formal_Base) and then Is_Generic_Type (New_Formal_Base)
and then Is_Internal (New_Formal_Base) and then Is_Internal (New_Formal_Base)
and then Etype (Etype (New_Formal_Base)) = and then Etype (Etype (New_Formal_Base)) =
Old_Formal_Base)) Old_Formal_Base))
and then Directly_Designated_Type (Old_Formal_Base) = and then Directly_Designated_Type (Old_Formal_Base) =
Directly_Designated_Type (New_Formal_Base) Directly_Designated_Type (New_Formal_Base)
and then ((Is_Itype (Old_Formal_Base) and then ((Is_Itype (Old_Formal_Base)
and then Can_Never_Be_Null (Old_Formal_Base)) and then Can_Never_Be_Null (Old_Formal_Base))
or else or else
(Is_Itype (New_Formal_Base) (Is_Itype (New_Formal_Base)
and then Can_Never_Be_Null (New_Formal_Base))); and then Can_Never_Be_Null (New_Formal_Base)));
-- Types must always match. In the visible part of an instance, -- Types must always match. In the visible part of an instance,
-- usual overloading rules for dispatching operations apply, and -- usual overloading rules for dispatching operations apply, and
......
...@@ -1382,8 +1382,7 @@ package body Sem_Prag is ...@@ -1382,8 +1382,7 @@ package body Sem_Prag is
-- (Output =>+ null) -- (Output =>+ null)
-- Remove the null input and replace it with a copy of the -- Remove null input and replace it with a copy of the output:
-- output:
-- (Output => Output) -- (Output => Output)
...@@ -1459,8 +1458,8 @@ package body Sem_Prag is ...@@ -1459,8 +1458,8 @@ package body Sem_Prag is
Propagate_Output (Output, Inputs); Propagate_Output (Output, Inputs);
-- A list with multiple outputs is slowly trimmed until only -- A list with multiple outputs is slowly trimmed until only
-- one element remains. When this happens, replace the -- one element remains. When this happens, replace aggregate
-- aggregate with the element itself. -- with the element itself.
if Multiple then if Multiple then
Remove (Output); Remove (Output);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment