Commit 8b4230c8 by Arnaud Charlet

[multiple changes]

2014-01-27  Tristan Gingold  <gingold@adacore.com>

	* exp_ch7.adb, exp_ch9.adb: Adjust comments.

2014-01-27  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_N_Op_Expon): Remove unsigned type test
	for 2**X optimization.

2014-01-27  Ed Schonberg  <schonberg@adacore.com>

	* a-suenst.adb: strings.utf_encoding.strings (Decode): Check
	explicitly whether value is in range of Character, because the
	library is typically compiled with range checks disabled, and
	we cannot rely on the implicit check on the argument of 'Val.

2014-01-27  Vincent Celier  <celier@adacore.com>

	* a-ciorma.adb, a-cihama.adb (Assign): Copy the Source to the Target,
	not the Target to itself.

2014-01-27  Robert Dewar  <dewar@adacore.com>

	* vms_conv.ads, ali.adb, sem_ch6.ads, opt.ads, vms_cmds.ads: Minor
	changes to avoid incorrect use of unordered enum types.

2014-01-27  Thomas Quinot  <quinot@adacore.com>

	* sem_ch4.adb: Minor reformatting.

From-SVN: r207144
parent 29077c18
2014-01-27 Tristan Gingold <gingold@adacore.com>
* exp_ch7.adb, exp_ch9.adb: Adjust comments.
2014-01-27 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb (Expand_N_Op_Expon): Remove unsigned type test
for 2**X optimization.
2014-01-27 Ed Schonberg <schonberg@adacore.com>
* a-suenst.adb: strings.utf_encoding.strings (Decode): Check
explicitly whether value is in range of Character, because the
library is typically compiled with range checks disabled, and
we cannot rely on the implicit check on the argument of 'Val.
2014-01-27 Vincent Celier <celier@adacore.com>
* a-ciorma.adb, a-cihama.adb (Assign): Copy the Source to the Target,
not the Target to itself.
2014-01-27 Robert Dewar <dewar@adacore.com>
* vms_conv.ads, ali.adb, sem_ch6.ads, opt.ads, vms_cmds.ads: Minor
changes to avoid incorrect use of unordered enum types.
2014-01-27 Thomas Quinot <quinot@adacore.com>
* sem_ch4.adb: Minor reformatting.
2014-01-27 Robert Dewar <dewar@adacore.com> 2014-01-27 Robert Dewar <dewar@adacore.com>
* scn.adb (Check_End_Of_Line): Removed. * scn.adb (Check_End_Of_Line): Removed.
......
...@@ -169,7 +169,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is ...@@ -169,7 +169,7 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
Target.Reserve_Capacity (Source.Length); Target.Reserve_Capacity (Source.Length);
end if; end if;
Insert_Items (Target.HT); Insert_Items (Source.HT);
end Assign; end Assign;
-------------- --------------
......
...@@ -313,7 +313,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is ...@@ -313,7 +313,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
end if; end if;
Target.Clear; Target.Clear;
Insert_Items (Target.Tree); Insert_Items (Source.Tree);
end Assign; end Assign;
------------- -------------
......
...@@ -154,16 +154,19 @@ package body Ada.Strings.UTF_Encoding.Strings is ...@@ -154,16 +154,19 @@ package body Ada.Strings.UTF_Encoding.Strings is
end if; end if;
Len := Len + 1; Len := Len + 1;
-- The value may still be out of range of Standard.Character. We make
-- the check explicit because the library is typically compiled with
-- range checks disabled.
if R > Character'Pos (Character'Last) then
Raise_Encoding_Error (Iptr - 1);
end if;
Result (Len) := Character'Val (R); Result (Len) := Character'Val (R);
end loop; end loop;
return Result (1 .. Len); return Result (1 .. Len);
exception
-- 'Val may have been out of range
when others =>
Raise_Encoding_Error (Iptr - 1);
end Decode; end Decode;
-- Decode UTF-16 input to String -- Decode UTF-16 input to String
......
...@@ -1290,7 +1290,7 @@ package body ALI is ...@@ -1290,7 +1290,7 @@ package body ALI is
begin begin
R := Restriction_Id'First; R := Restriction_Id'First;
while R < Not_A_Restriction_Id loop while R /= Not_A_Restriction_Id loop
if Restriction_Id'Image (R) = RN then if Restriction_Id'Image (R) = RN then
goto R_Found; goto R_Found;
end if; end if;
......
...@@ -7469,12 +7469,16 @@ package body Exp_Ch4 is ...@@ -7469,12 +7469,16 @@ package body Exp_Ch4 is
-- a non-binary modulus in the multiplication case, since we get a wrong -- a non-binary modulus in the multiplication case, since we get a wrong
-- result if the shift causes an overflow before the modular reduction. -- result if the shift causes an overflow before the modular reduction.
-- Note: we used to check that Exptyp was an unsigned type. But that is
-- an unnecessary check, since if Exp is negative, we have a run-time
-- error that is either caught (so we get the right result) or we have
-- suppressed the check, in which case the code is erroneous anyway.
if Nkind (Base) = N_Integer_Literal if Nkind (Base) = N_Integer_Literal
and then CRT_Safe_Compile_Time_Known_Value (Base) and then CRT_Safe_Compile_Time_Known_Value (Base)
and then Expr_Value (Base) = Uint_2 and then Expr_Value (Base) = Uint_2
and then Is_Integer_Type (Root_Type (Exptyp)) and then Is_Integer_Type (Root_Type (Exptyp))
and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer) and then Esize (Root_Type (Exptyp)) <= Esize (Standard_Integer)
and then Is_Unsigned_Type (Exptyp)
and then not Ovflo and then not Ovflo
then then
-- First the multiply and divide cases -- First the multiply and divide cases
......
...@@ -532,11 +532,8 @@ package body Exp_Ch7 is ...@@ -532,11 +532,8 @@ package body Exp_Ch7 is
pragma Assert (Present (Param)); pragma Assert (Present (Param));
-- Historical note: In earlier versions of GNAT, there was code -- Historical note: In earlier versions of GNAT, there was code
-- at this point to generate stuff to service entry queues. But -- at this point to generate stuff to service entry queues. It is
-- that was wrong thinking. This was useless and resulted in -- now abstracted in Build_Protected_Subprogram_Call_Cleanup.
-- incoherencies between code generated with and without -gnatp.
-- All that is needed at this stage is a normal cleanup call
Build_Protected_Subprogram_Call_Cleanup Build_Protected_Subprogram_Call_Cleanup
(Specification (N), Conc_Typ, Loc, Stmts); (Specification (N), Conc_Typ, Loc, Stmts);
......
...@@ -4278,6 +4278,10 @@ package body Exp_Ch9 is ...@@ -4278,6 +4278,10 @@ package body Exp_Ch9 is
Append (Unprot_Call, Stmts); Append (Unprot_Call, Stmts);
end if; end if;
-- Historical note: Previously, call the the cleanup was inserted
-- here. This is now done by Build_Protected_Subprogram_Call_Cleanup,
-- which is also shared by the 'not Exc_Safe' path.
Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts); Build_Protected_Subprogram_Call_Cleanup (Op_Spec, Pid, Loc, Stmts);
if Nkind (Op_Spec) = N_Function_Specification then if Nkind (Op_Spec) = N_Function_Specification then
...@@ -4298,6 +4302,10 @@ package body Exp_Ch9 is ...@@ -4298,6 +4302,10 @@ package body Exp_Ch9 is
Handled_Statement_Sequence => Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts));
-- Mark this subprogram as a protected subprogram body so that the
-- cleanup will be inserted. This is done only in the 'not Exc_Safe'
-- path as otherwise the cleanup has already been inserted.
if not Exc_Safe then if not Exc_Safe then
Set_Is_Protected_Subprogram_Body (Sub_Body); Set_Is_Protected_Subprogram_Body (Sub_Body);
end if; end if;
......
...@@ -1064,6 +1064,7 @@ package Opt is ...@@ -1064,6 +1064,7 @@ package Opt is
-- object directory, if project files are used. -- object directory, if project files are used.
type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code); type Operating_Mode_Type is (Check_Syntax, Check_Semantics, Generate_Code);
pragma Ordered (Operating_Mode_Type);
Operating_Mode : Operating_Mode_Type := Generate_Code; Operating_Mode : Operating_Mode_Type := Generate_Code;
-- GNAT -- GNAT
-- Indicates the operating mode of the compiler. The default is generate -- Indicates the operating mode of the compiler. The default is generate
...@@ -1072,7 +1073,8 @@ package Opt is ...@@ -1072,7 +1073,8 @@ package Opt is
-- only mode. Operating_Mode can also be modified as a result of detecting -- only mode. Operating_Mode can also be modified as a result of detecting
-- errors during the compilation process. In particular if any serious -- errors during the compilation process. In particular if any serious
-- error is detected then this flag is reset from Generate_Code to -- error is detected then this flag is reset from Generate_Code to
-- Check_Semantics after generating an error message. -- Check_Semantics after generating an error message. This is an ordered
-- type with the semantics that each value does more than the previous one.
Optimize_Alignment : Character := 'O'; Optimize_Alignment : Character := 'O';
-- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can -- Setting of Optimize_Alignment, set to T/S/O for time/space/off. Can
......
...@@ -4594,15 +4594,15 @@ package body Sem_Ch4 is ...@@ -4594,15 +4594,15 @@ package body Sem_Ch4 is
Check_Misspelled_Selector (Type_To_Use, Sel); Check_Misspelled_Selector (Type_To_Use, Sel);
-- If this is a derived formal type, the parent may have different
-- visibility at this point. Try for an inherited component before
-- reporting an error.
elsif Is_Generic_Type (Prefix_Type) elsif Is_Generic_Type (Prefix_Type)
and then Ekind (Prefix_Type) = E_Record_Type_With_Private and then Ekind (Prefix_Type) = E_Record_Type_With_Private
and then Prefix_Type /= Etype (Prefix_Type) and then Prefix_Type /= Etype (Prefix_Type)
and then Is_Record_Type (Etype (Prefix_Type)) and then Is_Record_Type (Etype (Prefix_Type))
then then
-- If this is a derived formal type, the parent may have
-- different visibility at this point. Try for an inherited
-- component before reporting an error.
Set_Etype (Prefix (N), Etype (Prefix_Type)); Set_Etype (Prefix (N), Etype (Prefix_Type));
Analyze_Selected_Component (N); Analyze_Selected_Component (N);
return; return;
...@@ -4615,7 +4615,6 @@ package body Sem_Ch4 is ...@@ -4615,7 +4615,6 @@ package body Sem_Ch4 is
and then Is_Generic_Actual_Type (Prefix_Type) and then Is_Generic_Actual_Type (Prefix_Type)
and then Present (Full_View (Prefix_Type)) and then Present (Full_View (Prefix_Type))
then then
Find_Component_In_Instance Find_Component_In_Instance
(Generic_Parent_Type (Parent (Prefix_Type))); (Generic_Parent_Type (Parent (Prefix_Type)));
return; return;
...@@ -5034,13 +5033,13 @@ package body Sem_Ch4 is ...@@ -5034,13 +5033,13 @@ package body Sem_Ch4 is
then then
Add_One_Interp (N, Op_Id, Etype (Op_Id)); Add_One_Interp (N, Op_Id, Etype (Op_Id));
-- If the left operand is overloaded, indicate that the -- If the left operand is overloaded, indicate that the current
-- current type is a viable candidate. This is redundant -- type is a viable candidate. This is redundant in most cases,
-- in most cases, but for equality and comparison operators -- but for equality and comparison operators where the context
-- where the context does not impose a type on the operands, -- does not impose a type on the operands, setting the proper
-- setting the proper type is necessary to avoid subsequent -- type is necessary to avoid subsequent ambiguities during
-- ambiguities during resolution, when both user-defined and -- resolution, when both user-defined and predefined operators
-- predefined operators may be candidates. -- may be candidates.
if Is_Overloaded (Left_Opnd (N)) then if Is_Overloaded (Left_Opnd (N)) then
Set_Etype (Left_Opnd (N), Etype (F1)); Set_Etype (Left_Opnd (N), Etype (F1));
...@@ -5108,7 +5107,7 @@ package body Sem_Ch4 is ...@@ -5108,7 +5107,7 @@ package body Sem_Ch4 is
-- (multiplication or division) that should hide the corresponding -- (multiplication or division) that should hide the corresponding
-- predefined operator. Used to implement Ada 2005 AI-264, to make -- predefined operator. Used to implement Ada 2005 AI-264, to make
-- such operators more visible and therefore useful. -- such operators more visible and therefore useful.
--
-- If the name of the operation is an expanded name with prefix -- If the name of the operation is an expanded name with prefix
-- Standard, the predefined universal fixed operator is available, -- Standard, the predefined universal fixed operator is available,
-- as specified by AI-420 (RM 4.5.5 (19.1/2)). -- as specified by AI-420 (RM 4.5.5 (19.1/2)).
...@@ -5325,11 +5324,11 @@ package body Sem_Ch4 is ...@@ -5325,11 +5324,11 @@ package body Sem_Ch4 is
Comp : Entity_Id; Comp : Entity_Id;
begin begin
-- All the components of the prefix of selector Sel are matched -- All the components of the prefix of selector Sel are matched against
-- against Sel and a count is maintained of possible misspellings. -- Sel and a count is maintained of possible misspellings. When at
-- When at the end of the analysis there are one or two (not more!) -- the end of the analysis there are one or two (not more!) possible
-- possible misspellings, these misspellings will be suggested as -- misspellings, these misspellings will be suggested as possible
-- possible correction. -- correction.
if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then if not (Is_Private_Type (Prefix) or else Is_Record_Type (Prefix)) then
...@@ -5661,21 +5660,17 @@ package body Sem_Ch4 is ...@@ -5661,21 +5660,17 @@ package body Sem_Ch4 is
-- universal, the context will impose the correct type. -- universal, the context will impose the correct type.
if Present (Scop) if Present (Scop)
and then not Defined_In_Scope (T1, Scop) and then not Defined_In_Scope (T1, Scop)
and then T1 /= Universal_Integer and then T1 /= Universal_Integer
and then T1 /= Universal_Real and then T1 /= Universal_Real
and then T1 /= Any_String and then T1 /= Any_String
and then T1 /= Any_Composite and then T1 /= Any_Composite
then then
return; return;
end if; end if;
if Valid_Comparison_Arg (T1) if Valid_Comparison_Arg (T1) and then Has_Compatible_Type (R, T1) then
and then Has_Compatible_Type (R, T1) if Found and then Base_Type (T1) /= Base_Type (T_F) then
then
if Found
and then Base_Type (T1) /= Base_Type (T_F)
then
It := Disambiguate (L, I_F, Index, Any_Type); It := Disambiguate (L, I_F, Index, Any_Type);
if It = No_Interp then if It = No_Interp then
...@@ -5705,9 +5700,7 @@ package body Sem_Ch4 is ...@@ -5705,9 +5700,7 @@ package body Sem_Ch4 is
-- If left operand is aggregate, the right operand has to -- If left operand is aggregate, the right operand has to
-- provide a usable type for it. -- provide a usable type for it.
if Nkind (L) = N_Aggregate if Nkind (L) = N_Aggregate and then Nkind (R) /= N_Aggregate then
and then Nkind (R) /= N_Aggregate
then
Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N); Find_Comparison_Types (L => R, R => L, Op_Id => Op_Id, N => N);
return; return;
end if; end if;
...@@ -5754,8 +5747,7 @@ package body Sem_Ch4 is ...@@ -5754,8 +5747,7 @@ package body Sem_Ch4 is
It : Interp; It : Interp;
begin begin
if T1 = Universal_Integer if T1 = Universal_Integer or else T1 = Universal_Real
or else T1 = Universal_Real
-- If the left operand of an equality operator is null, the visibility -- If the left operand of an equality operator is null, the visibility
-- of the operator must be determined from the interpretation of the -- of the operator must be determined from the interpretation of the
...@@ -5765,8 +5757,7 @@ package body Sem_Ch4 is ...@@ -5765,8 +5757,7 @@ package body Sem_Ch4 is
or else T1 = Any_Access or else T1 = Any_Access
then then
if not Is_Overloaded (R) then if not Is_Overloaded (R) then
Add_One_Interp Add_One_Interp (N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
(N, Op_Id, Standard_Boolean, Base_Type (Etype (R)));
else else
Get_First_Interp (R, Index, It); Get_First_Interp (R, Index, It);
while Present (It.Typ) loop while Present (It.Typ) loop
...@@ -5846,6 +5837,7 @@ package body Sem_Ch4 is ...@@ -5846,6 +5837,7 @@ package body Sem_Ch4 is
-- universal, the context will impose the correct type. An anonymous -- universal, the context will impose the correct type. An anonymous
-- type for a 'Access reference is also universal in this sense, as -- type for a 'Access reference is also universal in this sense, as
-- the actual type is obtained from context. -- the actual type is obtained from context.
-- In Ada 2005, the equality operator for anonymous access types -- In Ada 2005, the equality operator for anonymous access types
-- is declared in Standard, and preference rules apply to it. -- is declared in Standard, and preference rules apply to it.
...@@ -5916,9 +5908,9 @@ package body Sem_Ch4 is ...@@ -5916,9 +5908,9 @@ package body Sem_Ch4 is
-- If the right operand has a type compatible with T1, check for an -- If the right operand has a type compatible with T1, check for an
-- acceptable interpretation, unless T1 is limited (no predefined -- acceptable interpretation, unless T1 is limited (no predefined
-- equality available), or this is use of a "/=" for a tagged type. -- equality available), or this is use of a "/=" for a tagged type.
-- In the latter case, possible interpretations of equality need to -- In the latter case, possible interpretations of equality need
-- be considered, we don't want the default inequality declared in -- to be considered, we don't want the default inequality declared
-- Standard to be chosen, and the "/=" will be rewritten as a -- in Standard to be chosen, and the "/=" will be rewritten as a
-- negation of "=" (see the end of Analyze_Equality_Op). This ensures -- negation of "=" (see the end of Analyze_Equality_Op). This ensures
-- that that rewriting happens during analysis rather than being -- that that rewriting happens during analysis rather than being
-- delayed until expansion (this is needed for ASIS, which only sees -- delayed until expansion (this is needed for ASIS, which only sees
...@@ -6113,12 +6105,12 @@ package body Sem_Ch4 is ...@@ -6113,12 +6105,12 @@ package body Sem_Ch4 is
(Base_Type (Etype (First_Formal (Hom))) = Cls_Type (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
or else or else
(Is_Access_Type (Etype (First_Formal (Hom))) (Is_Access_Type (Etype (First_Formal (Hom)))
and then and then
Ekind (Etype (First_Formal (Hom))) = Ekind (Etype (First_Formal (Hom))) =
E_Anonymous_Access_Type E_Anonymous_Access_Type
and then and then
Base_Type Base_Type
(Designated_Type (Etype (First_Formal (Hom)))) = (Designated_Type (Etype (First_Formal (Hom)))) =
Cls_Type)) Cls_Type))
then then
Add_One_Interp (Op, Hom, Etype (Hom)); Add_One_Interp (Op, Hom, Etype (Hom));
...@@ -6353,7 +6345,7 @@ package body Sem_Ch4 is ...@@ -6353,7 +6345,7 @@ package body Sem_Ch4 is
else else
Error_Msg_NE -- CODEFIX Error_Msg_NE -- CODEFIX
("add with_clause and use_clause for&!", ("add with_clause and use_clause for&!",
N, Defining_Entity (Unit (U))); N, Defining_Entity (Unit (U)));
end if; end if;
end; end;
return; return;
...@@ -6576,7 +6568,7 @@ package body Sem_Ch4 is ...@@ -6576,7 +6568,7 @@ package body Sem_Ch4 is
("No legal interpretation for operator&", N); ("No legal interpretation for operator&", N);
Error_Msg_NE Error_Msg_NE
("\use clause on& would make operation legal", ("\use clause on& would make operation legal",
N, Scope (Op_Id)); N, Scope (Op_Id));
exit; exit;
end if; end if;
end if; end if;
...@@ -6625,19 +6617,18 @@ package body Sem_Ch4 is ...@@ -6625,19 +6617,18 @@ package body Sem_Ch4 is
if Present (E) if Present (E)
and then (Operating_Mode = Check_Semantics or else not Expander_Active) and then (Operating_Mode = Check_Semantics or else not Expander_Active)
then then
-- We create a dummy reference to E to ensure that the reference -- We create a dummy reference to E to ensure that the reference is
-- is not considered as part of an assignment (an implicit -- not considered as part of an assignment (an implicit dereference
-- dereference can never assign to its prefix). The Comes_From_Source -- can never assign to its prefix). The Comes_From_Source attribute
-- attribute needs to be propagated for accurate warnings. -- needs to be propagated for accurate warnings.
Ref := New_Reference_To (E, Sloc (P)); Ref := New_Reference_To (E, Sloc (P));
Set_Comes_From_Source (Ref, Comes_From_Source (P)); Set_Comes_From_Source (Ref, Comes_From_Source (P));
Generate_Reference (E, Ref); Generate_Reference (E, Ref);
end if; end if;
-- An implicit dereference is a legal occurrence of an -- An implicit dereference is a legal occurrence of an incomplete type
-- incomplete type imported through a limited_with clause, -- imported through a limited_with clause, if the full view is visible.
-- if the full view is visible.
if From_Limited_With (Typ) if From_Limited_With (Typ)
and then not From_Limited_With (Scope (Typ)) and then not From_Limited_With (Scope (Typ))
...@@ -6676,8 +6667,8 @@ package body Sem_Ch4 is ...@@ -6676,8 +6667,8 @@ package body Sem_Ch4 is
procedure Remove_Address_Interpretations (Op : Operand_Position); procedure Remove_Address_Interpretations (Op : Operand_Position);
-- Ambiguities may arise when the operands are literal and the address -- Ambiguities may arise when the operands are literal and the address
-- operations in s-auxdec are visible. In that case, remove the -- operations in s-auxdec are visible. In that case, remove the
-- interpretation of a literal as Address, to retain the semantics of -- interpretation of a literal as Address, to retain the semantics
-- Address as a private type. -- of Address as a private type.
------------------------------------ ------------------------------------
-- Remove_Address_Interpretations -- -- Remove_Address_Interpretations --
...@@ -6779,9 +6770,9 @@ package body Sem_Ch4 is ...@@ -6779,9 +6770,9 @@ package body Sem_Ch4 is
if Nkind (N) in N_Binary_Op then if Nkind (N) in N_Binary_Op then
declare declare
U1 : constant Boolean := U1 : constant Boolean :=
Present (Universal_Interpretation (Right_Opnd (N))); Present (Universal_Interpretation (Right_Opnd (N)));
U2 : constant Boolean := U2 : constant Boolean :=
Present (Universal_Interpretation (Left_Opnd (N))); Present (Universal_Interpretation (Left_Opnd (N)));
begin begin
if U1 then if U1 then
...@@ -7008,15 +6999,16 @@ package body Sem_Ch4 is ...@@ -7008,15 +6999,16 @@ package body Sem_Ch4 is
end if; end if;
else else
Indexing := Make_Function_Call (Loc, Indexing :=
Name => Make_Identifier (Loc, Chars (Func_Name)), Make_Function_Call (Loc,
Parameter_Associations => Assoc); Name => Make_Identifier (Loc, Chars (Func_Name)),
Parameter_Associations => Assoc);
Rewrite (N, Indexing); Rewrite (N, Indexing);
declare declare
I : Interp_Index; I : Interp_Index;
It : Interp; It : Interp;
Success : Boolean; Success : Boolean;
begin begin
...@@ -7103,6 +7095,7 @@ package body Sem_Ch4 is ...@@ -7103,6 +7095,7 @@ package body Sem_Ch4 is
end if; end if;
return True; return True;
else else
return False; return False;
end if; end if;
...@@ -7212,8 +7205,8 @@ package body Sem_Ch4 is ...@@ -7212,8 +7205,8 @@ package body Sem_Ch4 is
-- Identifier on which possible interpretations will be collected -- Identifier on which possible interpretations will be collected
Report_Error : Boolean := False; Report_Error : Boolean := False;
-- If no candidate interpretation matches the context, redo the -- If no candidate interpretation matches the context, redo analysis
-- analysis with error enabled to provide additional information. -- with Report_Error True to provide additional information.
Actual : Node_Id; Actual : Node_Id;
Candidate : Entity_Id := Empty; Candidate : Entity_Id := Empty;
...@@ -7372,9 +7365,9 @@ package body Sem_Ch4 is ...@@ -7372,9 +7365,9 @@ package body Sem_Ch4 is
First_Actual := First (Parameter_Associations (Call_Node)); First_Actual := First (Parameter_Associations (Call_Node));
-- For cross-reference purposes, treat the new node as being in -- For cross-reference purposes, treat the new node as being in the
-- the source if the original one is. Set entity and type, even -- source if the original one is. Set entity and type, even though
-- though they may be overwritten during resolution if overloaded. -- they may be overwritten during resolution if overloaded.
Set_Comes_From_Source (Subprog, Comes_From_Source (N)); Set_Comes_From_Source (Subprog, Comes_From_Source (N));
Set_Comes_From_Source (Call_Node, Comes_From_Source (N)); Set_Comes_From_Source (Call_Node, Comes_From_Source (N));
...@@ -7386,9 +7379,9 @@ package body Sem_Ch4 is ...@@ -7386,9 +7379,9 @@ package body Sem_Ch4 is
Set_Etype (Selector_Name (N), Etype (Entity (Subprog))); Set_Etype (Selector_Name (N), Etype (Entity (Subprog)));
end if; end if;
-- If need be, rewrite first actual as an explicit dereference -- If need be, rewrite first actual as an explicit dereference. If
-- If the call is overloaded, the rewriting can only be done -- the call is overloaded, the rewriting can only be done once the
-- once the primitive operation is identified. -- primitive operation is identified.
if Is_Overloaded (Subprog) then if Is_Overloaded (Subprog) then
...@@ -7503,8 +7496,8 @@ package body Sem_Ch4 is ...@@ -7503,8 +7496,8 @@ package body Sem_Ch4 is
if Access_Formal and then not Access_Actual then if Access_Formal and then not Access_Actual then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N Error_Msg_N
("\possible interpretation" ("\possible interpretation "
& " (inherited, with implicit 'Access) #", N); & "(inherited, with implicit 'Access) #", N);
else else
Error_Msg_N Error_Msg_N
("\possible interpretation (with implicit 'Access) #", N); ("\possible interpretation (with implicit 'Access) #", N);
...@@ -7513,8 +7506,8 @@ package body Sem_Ch4 is ...@@ -7513,8 +7506,8 @@ package body Sem_Ch4 is
elsif not Access_Formal and then Access_Actual then elsif not Access_Formal and then Access_Actual then
if Nkind (Parent (Op)) = N_Full_Type_Declaration then if Nkind (Parent (Op)) = N_Full_Type_Declaration then
Error_Msg_N Error_Msg_N
("\possible interpretation" ("\possible interpretation "
& " ( inherited, with implicit dereference) #", N); & "( inherited, with implicit dereference) #", N);
else else
Error_Msg_N Error_Msg_N
("\possible interpretation (with implicit dereference) #", N); ("\possible interpretation (with implicit dereference) #", N);
...@@ -7582,9 +7575,8 @@ package body Sem_Ch4 is ...@@ -7582,9 +7575,8 @@ package body Sem_Ch4 is
else else
Call_Node := Call_Node :=
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Copy (Subprog), Name => New_Copy (Subprog),
Parameter_Associations => Actuals); Parameter_Associations => Actuals);
end if; end if;
-- Before analysis, a function call appears as an indexed component -- Before analysis, a function call appears as an indexed component
...@@ -7606,7 +7598,7 @@ package body Sem_Ch4 is ...@@ -7606,7 +7598,7 @@ package body Sem_Ch4 is
Call_Node := Call_Node :=
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Copy (Subprog), Name => New_Copy (Subprog),
Parameter_Associations => Actuals); Parameter_Associations => Actuals);
-- Parameterless call: Obj.F is rewritten as F (Obj) -- Parameterless call: Obj.F is rewritten as F (Obj)
...@@ -7616,7 +7608,7 @@ package body Sem_Ch4 is ...@@ -7616,7 +7608,7 @@ package body Sem_Ch4 is
Call_Node := Call_Node :=
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Copy (Subprog), Name => New_Copy (Subprog),
Parameter_Associations => New_List (Dummy)); Parameter_Associations => New_List (Dummy));
end if; end if;
end Transform_Object_Operation; end Transform_Object_Operation;
...@@ -7671,8 +7663,8 @@ package body Sem_Ch4 is ...@@ -7671,8 +7663,8 @@ package body Sem_Ch4 is
-- Find a non-hidden operation whose first parameter is of the -- Find a non-hidden operation whose first parameter is of the
-- class-wide type, a subtype thereof, or an anonymous access -- class-wide type, a subtype thereof, or an anonymous access
-- to same. If in an instance, the operation can be considered -- to same. If in an instance, the operation can be considered
-- even if hidden (it may be hidden because the instantiation is -- even if hidden (it may be hidden because the instantiation
-- expanded after the containing package has been analyzed). -- is expanded after the containing package has been analyzed).
while Present (Hom) loop while Present (Hom) loop
if Ekind_In (Hom, E_Procedure, E_Function) if Ekind_In (Hom, E_Procedure, E_Function)
...@@ -7683,12 +7675,12 @@ package body Sem_Ch4 is ...@@ -7683,12 +7675,12 @@ package body Sem_Ch4 is
(Base_Type (Etype (First_Formal (Hom))) = Cls_Type (Base_Type (Etype (First_Formal (Hom))) = Cls_Type
or else or else
(Is_Access_Type (Etype (First_Formal (Hom))) (Is_Access_Type (Etype (First_Formal (Hom)))
and then and then
Ekind (Etype (First_Formal (Hom))) = Ekind (Etype (First_Formal (Hom))) =
E_Anonymous_Access_Type E_Anonymous_Access_Type
and then and then
Base_Type Base_Type
(Designated_Type (Etype (First_Formal (Hom)))) = (Designated_Type (Etype (First_Formal (Hom)))) =
Cls_Type)) Cls_Type))
then then
-- If the context is a procedure call, ignore functions -- If the context is a procedure call, ignore functions
...@@ -7931,12 +7923,12 @@ package body Sem_Ch4 is ...@@ -7931,12 +7923,12 @@ package body Sem_Ch4 is
Matching_Op : Entity_Id := Empty; Matching_Op : Entity_Id := Empty;
Prim_Op_Ref : Node_Id := Empty; Prim_Op_Ref : Node_Id := Empty;
Corr_Type : Entity_Id := Empty; Corr_Type : Entity_Id := Empty;
-- If the prefix is a synchronized type, the controlling type of -- If the prefix is a synchronized type, the controlling type of
-- the primitive operation is the corresponding record type, else -- the primitive operation is the corresponding record type, else
-- this is the object type itself. -- this is the object type itself.
Success : Boolean := False; Success : Boolean := False;
function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id; function Collect_Generic_Type_Ops (T : Entity_Id) return Elist_Id;
-- For tagged types the candidate interpretations are found in -- For tagged types the candidate interpretations are found in
...@@ -7946,6 +7938,7 @@ package body Sem_Ch4 is ...@@ -7946,6 +7938,7 @@ package body Sem_Ch4 is
-- part) because the type itself carries no primitive operations, -- part) because the type itself carries no primitive operations,
-- except for formal derived types that inherit the operations of -- except for formal derived types that inherit the operations of
-- the parent and progenitors. -- the parent and progenitors.
--
-- If the context is a generic subprogram body, the generic formals -- If the context is a generic subprogram body, the generic formals
-- are visible by name, but are not in the entity list of the -- are visible by name, but are not in the entity list of the
-- subprogram because that list starts with the subprogram formals. -- subprogram because that list starts with the subprogram formals.
...@@ -8007,8 +8000,8 @@ package body Sem_Ch4 is ...@@ -8007,8 +8000,8 @@ package body Sem_Ch4 is
-- Scan the list of generic formals to find subprograms -- Scan the list of generic formals to find subprograms
-- that may have a first controlling formal of the type. -- that may have a first controlling formal of the type.
if Nkind (Unit_Declaration_Node (Scope (T))) if Nkind (Unit_Declaration_Node (Scope (T))) =
= N_Generic_Subprogram_Declaration N_Generic_Subprogram_Declaration
then then
declare declare
Decl : Node_Id; Decl : Node_Id;
...@@ -8143,10 +8136,11 @@ package body Sem_Ch4 is ...@@ -8143,10 +8136,11 @@ package body Sem_Ch4 is
and then Valid_First_Argument_Of (Prim_Op) and then Valid_First_Argument_Of (Prim_Op)
and then and then
(Nkind (Call_Node) = N_Function_Call) (Nkind (Call_Node) = N_Function_Call)
= (Ekind (Prim_Op) = E_Function) =
(Ekind (Prim_Op) = E_Function)
then then
-- Ada 2005 (AI-251): If this primitive operation corresponds -- Ada 2005 (AI-251): If this primitive operation corresponds
-- with an immediate ancestor interface there is no need to add -- to an immediate ancestor interface there is no need to add
-- it to the list of interpretations; the corresponding aliased -- it to the list of interpretations; the corresponding aliased
-- primitive is also in this list of primitive operations and -- primitive is also in this list of primitive operations and
-- will be used instead. -- will be used instead.
...@@ -8289,8 +8283,8 @@ package body Sem_Ch4 is ...@@ -8289,8 +8283,8 @@ package body Sem_Ch4 is
if All_Errors_Mode then if All_Errors_Mode then
Report_Error := True; Report_Error := True;
if Try_Primitive_Operation if Try_Primitive_Operation
(Call_Node => New_Call_Node, (Call_Node => New_Call_Node,
Node_To_Replace => Node_To_Replace) Node_To_Replace => Node_To_Replace)
or else or else
Try_Class_Wide_Operation Try_Class_Wide_Operation
......
...@@ -28,8 +28,7 @@ package Sem_Ch6 is ...@@ -28,8 +28,7 @@ package Sem_Ch6 is
type Conformance_Type is type Conformance_Type is
(Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant); (Type_Conformant, Mode_Conformant, Subtype_Conformant, Fully_Conformant);
-- pragma Ordered (Conformance_Type); pragma Ordered (Conformance_Type);
-- Why is above line commented out ???
-- Conformance type used in conformance checks between specs and bodies, -- Conformance type used in conformance checks between specs and bodies,
-- and for overriding. The literals match the RM definitions of the -- and for overriding. The literals match the RM definitions of the
-- corresponding terms. This is an ordered type, since each conformance -- corresponding terms. This is an ordered type, since each conformance
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- -- Copyright (C) 2010-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -50,4 +50,7 @@ package VMS_Cmds is ...@@ -50,4 +50,7 @@ package VMS_Cmds is
Test, Test,
Xref, Xref,
Undefined); Undefined);
subtype Real_Command_Type is Command_Type range Bind .. Xref;
-- All real command types (excludes only Undefined).
end VMS_Cmds; end VMS_Cmds;
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2003-2010, Free Software Foundation, Inc. -- -- Copyright (C) 2003-2013, Free Software Foundation, Inc. --
-- -- -- --
-- GNAT is free software; you can redistribute it and/or modify it under -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -104,8 +104,6 @@ package VMS_Conv is ...@@ -104,8 +104,6 @@ package VMS_Conv is
Pp => Pretty); Pp => Pretty);
-- Mapping of alternate commands to commands -- Mapping of alternate commands to commands
subtype Real_Command_Type is Command_Type range Bind .. Xref;
type Command_Entry is record type Command_Entry is record
Cname : String_Ptr; Cname : String_Ptr;
-- Command name for GNAT xxx command -- Command name for GNAT xxx command
......
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