Skip to content

R
riscv-gcc-1
Commit 45fc7ddb by Hristian Kirtchev Committed by Arnaud Charlet
Options

exp_ch2.adb: Minor reformatting. 

2008-04-08  Hristian Kirtchev  <kirtchev@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Robert Dewar  <dewar@adacore.com>

	* exp_ch2.adb: Minor reformatting.
	(Expand_Entry_Index_Parameter): Set the type of the identifier.
	(Expand_Entry_Reference): Add call to Expand_Protected_Component.
	(Expand_Protected_Component): New routine.
	(Expand_Protected_Private): Removed.
	Add Sure parameter to Note_Possible_Modification calls

	* sem_ch12.ads, sem_ch12.adb (Analyze_Subprogram_Instantiation): The
	generated subprogram declaration must inherit the overriding indicator
	from the instantiation node.
	(Validate_Access_Type_Instance): If the designated type of the actual is
	a limited view, use the available view in all cases, not only if the
	type is an incomplete type.
	(Instantiate_Object):  Actual is illegal if the formal is null-excluding
	and the actual subtype does not exclude null.
	(Process_Default): Handle properly abstract formal subprograms.
	(Check_Formal_Package_Instance): Handle properly defaulted formal
	subprograms in a partially parameterized formal package.
	Add Sure parameter to Note_Possible_Modification calls
	(Validate_Derived_Type_Instance): if the formal is non-limited, the
	actual cannot be limited.
	(Collect_Previous_Instances): Generate instance bodies for subprograms
	as well.

	* sem_ch13.adb (Analyze_Attribute_Definition_Clause, case Small): Don't
	try to set RM_Size.
	Add Sure parameter to Note_Possible_Modification calls
	(Analyze_At_Clause): Preserve Comes_From_Source on Rewrite call
	(Analyze_Attribute_Definition_Clause, case Attribute_Address): Check for
	constant overlaid by variable and issue warning.
	Use new Is_Standard_Character_Type predicate
	(Analyze_Record_Representation_Clause): Check that the specified
	Last_Bit is not less than First_Bit - 1.
	(Analyze_Attribute_Definition_Clause, case Address): Check for
	self-referential address clause

	* sem_ch5.ads, sem_ch5.adb (Diagnose_Non_Variable_Lhs): Rewrite the
	detection mechanism when the lhs is a prival.
	(Analyze_Assignment): Call Check_Unprotected_Access to detect
	assignment of a pointer to protected data, to an object declared
	outside of the protected object.
	(Analyze_Loop_Statement): Check for unreachable code after loop
	Add Sure parameter to Note_Possible_Modication calls
	Protect analysis from previous syntax error such as a scope mismatch
	or a missing begin.
	(Analyze_Assignment_Statement): The assignment is illegal if the
	left-hand is an interface.

	* sem_res.adb (Resolve_Arithmetic_Op): For mod/rem check violation of
	restriction No_Implicit_Conditionals
	Add Sure parameter to Note_Possible_Modication calls
	Use new Is_Standard_Character_Type predicate
	(Make_Call_Into_Operator): Preserve Comes_From_Source when rewriting
	call as operator. Fixes problems (e.g. validity checking) which
	come from the result looking as though it does not come from source).
	(Resolve_Call): Check case of name in named parameter if style checks
	are enabled.
	(Resolve_Call): Exclude calls to Current_Task as entry formal defaults
	from the checking that such calls should not occur from an entry body.
	(Resolve_Call): If the return type of an Inline_Always function
	requires the secondary stack, create a transient scope for the call
	if the body of the function is not available for inlining.
	(Resolve_Actuals): Apply Ada2005 checks to view conversions of arrays
	that are actuals for in-out formals.
	(Try_Object_Operation): If prefix is a tagged protected object,retrieve
	primitive operations from base type.
	(Analyze_Selected_Component): If the context is a call to a protected
	operation the parent may be an indexed component prior to expansion.
	(Resolve_Actuals): If an actual is of a protected subtype, use its
	base type to determine whether a conversion to the corresponding record
	is needed.
	(Resolve_Short_Circuit): Handle pragma Check

	* sem_eval.adb: Minor code reorganization (usea Is_Constant_Object)
	Use new Is_Standard_Character_Type predicate
	(Eval_Relational_Op): Catch more cases of string comparison

From-SVN: r134027
parent b4592168
Showing with 863 additions and 436 deletions
gcc/ada/exp_ch2.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, 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- --
...@@ -80,12 +80,12 @@ package body Exp_Ch2 is ...@@ -80,12 +80,12 @@ package body Exp_Ch2 is
-- Dispatches to specific expansion procedures. -- Dispatches to specific expansion procedures.
procedure Expand_Entry_Index_Parameter (N : Node_Id); procedure Expand_Entry_Index_Parameter (N : Node_Id);
-- A reference to the identifier in the entry index specification of -- A reference to the identifier in the entry index specification of an
-- protected entry body is modified to a reference to a constant definition -- entry body is modified to a reference to a constant definition equal to
-- equal to the index of the entry family member being called. This -- the index of the entry family member being called. This constant is
-- constant is calculated as part of the elaboration of the expanded code -- calculated as part of the elaboration of the expanded code for the body,
-- for the body, and is calculated from the object-wide entry index -- and is calculated from the object-wide entry index returned by Next_
-- returned by Next_Entry_Call. -- Entry_Call.
procedure Expand_Entry_Parameter (N : Node_Id); procedure Expand_Entry_Parameter (N : Node_Id);
-- A reference to an entry parameter is modified to be a reference to the -- A reference to an entry parameter is modified to be a reference to the
...@@ -98,12 +98,10 @@ package body Exp_Ch2 is ...@@ -98,12 +98,10 @@ package body Exp_Ch2 is
-- represent the operation within the protected object. In other cases -- represent the operation within the protected object. In other cases
-- Expand_Formal is a no-op. -- Expand_Formal is a no-op.
procedure Expand_Protected_Private (N : Node_Id); procedure Expand_Protected_Component (N : Node_Id);
-- A reference to a private component of a protected type is expanded to a -- A reference to a private component of a protected type is expanded into
-- component selected from the record used to implement the protected -- a reference to the corresponding prival in the current protected entry
-- object. Such a record is passed to all operations on a protected object -- or subprogram.
-- in a parameter named _object. This object is a constant in the body of a
-- function, and a variable within a procedure or entry body.
procedure Expand_Renaming (N : Node_Id); procedure Expand_Renaming (N : Node_Id);
-- For renamings, just replace the identifier by the corresponding -- For renamings, just replace the identifier by the corresponding
...@@ -332,16 +330,12 @@ package body Exp_Ch2 is ...@@ -332,16 +330,12 @@ package body Exp_Ch2 is
elsif Is_Entry_Formal (E) then elsif Is_Entry_Formal (E) then
Expand_Entry_Parameter (N); Expand_Entry_Parameter (N);
elsif Ekind (E) = E_Component elsif Is_Protected_Component (E) then
and then Is_Protected_Private (E)
then
-- Protect against junk use of tasking in no run time mode
if No_Run_Time_Mode then if No_Run_Time_Mode then
return; return;
end if; end if;
Expand_Protected_Private (N); Expand_Protected_Component (N);
elsif Ekind (E) = E_Entry_Index_Parameter then elsif Ekind (E) = E_Entry_Index_Parameter then
Expand_Entry_Index_Parameter (N); Expand_Entry_Index_Parameter (N);
...@@ -385,11 +379,7 @@ package body Exp_Ch2 is ...@@ -385,11 +379,7 @@ package body Exp_Ch2 is
-- Interpret possible Current_Value for constant case -- Interpret possible Current_Value for constant case
elsif (Ekind (E) = E_Constant elsif Is_Constant_Object (E)
or else
Ekind (E) = E_In_Parameter
or else
Ekind (E) = E_Loop_Parameter)
and then Present (Current_Value (E)) and then Present (Current_Value (E))
then then
Expand_Current_Value (N); Expand_Current_Value (N);
...@@ -401,8 +391,10 @@ package body Exp_Ch2 is ...@@ -401,8 +391,10 @@ package body Exp_Ch2 is
---------------------------------- ----------------------------------
procedure Expand_Entry_Index_Parameter (N : Node_Id) is procedure Expand_Entry_Index_Parameter (N : Node_Id) is
Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
begin begin
Set_Entity (N, Entry_Index_Constant (Entity (N))); Set_Entity (N, Index_Con);
Set_Etype (N, Etype (Index_Con));
end Expand_Entry_Index_Parameter; end Expand_Entry_Index_Parameter;
---------------------------- ----------------------------
...@@ -477,10 +469,14 @@ package body Exp_Ch2 is ...@@ -477,10 +469,14 @@ package body Exp_Ch2 is
-- we also generate an extra parameter to hold the Constrained -- we also generate an extra parameter to hold the Constrained
-- attribute of the actual. No renaming is generated for this flag. -- attribute of the actual. No renaming is generated for this flag.
-- Calling Node_Posssible_Modifications in the expander is dubious,
-- because this generates a cross-reference entry, and should be
-- done during semantic processing so it is called in -gnatc mode???
if Ekind (Entity (N)) /= E_In_Parameter if Ekind (Entity (N)) /= E_In_Parameter
and then In_Assignment_Context (N) and then In_Assignment_Context (N)
then then
Note_Possible_Modification (N); Note_Possible_Modification (N, Sure => True);
end if; end if;
Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc)); Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
...@@ -564,93 +560,54 @@ package body Exp_Ch2 is ...@@ -564,93 +560,54 @@ package body Exp_Ch2 is
end if; end if;
end Expand_N_Real_Literal; end Expand_N_Real_Literal;
------------------------------ --------------------------------
-- Expand_Protected_Private -- -- Expand_Protected_Component --
------------------------------ --------------------------------
procedure Expand_Protected_Private (N : Node_Id) is procedure Expand_Protected_Component (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
E : constant Entity_Id := Entity (N);
Op : constant Node_Id := Protected_Operation (E);
Scop : Entity_Id;
Lo : Node_Id;
Hi : Node_Id;
D_Range : Node_Id;
begin
if Nkind (Op) /= N_Subprogram_Body
or else Nkind (Specification (Op)) /= N_Function_Specification
then
Set_Ekind (Prival (E), E_Variable);
else
Set_Ekind (Prival (E), E_Constant);
end if;
-- If the private component appears in an assignment (either lhs or function Inside_Eliminated_Body return Boolean;
-- rhs) and is a one-dimensional array constrained by a discriminant, -- Determine whether the current entity is inside a subprogram or an
-- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal -- entry which has been marked as eliminated.
-- is directly visible. This solves delicate visibility problems.
if Comes_From_Source (N) ----------------------------
and then Is_Array_Type (Etype (E)) -- Inside_Eliminated_Body --
and then Number_Dimensions (Etype (E)) = 1 ----------------------------
and then not Within_Init_Proc
then
Lo := Type_Low_Bound (Etype (First_Index (Etype (E))));
Hi := Type_High_Bound (Etype (First_Index (Etype (E))));
if Nkind (Parent (N)) = N_Assignment_Statement
and then ((Is_Entity_Name (Lo)
and then Ekind (Entity (Lo)) = E_In_Parameter)
or else (Is_Entity_Name (Hi)
and then
Ekind (Entity (Hi)) = E_In_Parameter))
then
D_Range := New_Node (N_Range, Loc);
if Is_Entity_Name (Lo) function Inside_Eliminated_Body return Boolean is
and then Ekind (Entity (Lo)) = E_In_Parameter S : Entity_Id := Current_Scope;
then
Set_Low_Bound (D_Range,
Make_Identifier (Loc, Chars (Entity (Lo))));
else
Set_Low_Bound (D_Range, Duplicate_Subexpr (Lo));
end if;
if Is_Entity_Name (Hi) begin
and then Ekind (Entity (Hi)) = E_In_Parameter while Present (S) loop
if (Ekind (S) = E_Entry
or else Ekind (S) = E_Entry_Family
or else Ekind (S) = E_Function
or else Ekind (S) = E_Procedure)
and then Is_Eliminated (S)
then then
Set_High_Bound (D_Range, return True;
Make_Identifier (Loc, Chars (Entity (Hi))));
else
Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
end if; end if;
Rewrite (N, S := Scope (S);
Make_Slice (Loc, end loop;
Prefix => New_Occurrence_Of (E, Loc),
Discrete_Range => D_Range));
Analyze_And_Resolve (N, Etype (E));
return;
end if;
end if;
-- The type of the reference is the type of the prival, which may differ
-- from that of the original component if it is an itype.
Set_Entity (N, Prival (E));
Set_Etype (N, Etype (Prival (E)));
Scop := Current_Scope;
-- Find entity for protected operation, which must be on scope stack return False;
end Inside_Eliminated_Body;
while not Is_Protected_Type (Scope (Scop)) loop -- Start of processing for Expand_Protected_Component
Scop := Scope (Scop);
end loop;
Append_Elmt (N, Privals_Chain (Scop)); begin
end Expand_Protected_Private; -- Eliminated bodies are not expanded and thus do not need privals
if not Inside_Eliminated_Body then
declare
Priv : constant Entity_Id := Prival (Entity (N));
begin
Set_Entity (N, Priv);
Set_Etype (N, Etype (Priv));
end;
end if;
end Expand_Protected_Component;
--------------------- ---------------------
-- Expand_Renaming -- -- Expand_Renaming --
......
gcc/ada/sem_ch12.adb
...@@ -488,11 +488,11 @@ package body Sem_Ch12 is ...@@ -488,11 +488,11 @@ package body Sem_Ch12 is
-- and has already been flipped during this phase of instantiation. -- and has already been flipped during this phase of instantiation.
procedure Hide_Current_Scope; procedure Hide_Current_Scope;
-- When compiling a generic child unit, the parent context must be -- When instantiating a generic child unit, the parent context must be
-- present, but the instance and all entities that may be generated -- present, but the instance and all entities that may be generated
-- must be inserted in the current scope. We leave the current scope -- must be inserted in the current scope. We leave the current scope
-- on the stack, but make its entities invisible to avoid visibility -- on the stack, but make its entities invisible to avoid visibility
-- problems. This is reversed at the end of instantiations. This is -- problems. This is reversed at the end of the instantiation. This is
-- not done for the instantiation of the bodies, which only require the -- not done for the instantiation of the bodies, which only require the
-- instances of the generic parents to be in scope. -- instances of the generic parents to be in scope.
...@@ -685,7 +685,7 @@ package body Sem_Ch12 is ...@@ -685,7 +685,7 @@ package body Sem_Ch12 is
-- at the end of the enclosing generic package, which is semantically -- at the end of the enclosing generic package, which is semantically
-- neutral. -- neutral.
procedure Pre_Analyze_Actuals (N : Node_Id); procedure Preanalyze_Actuals (N : Node_Id);
-- Analyze actuals to perform name resolution. Full resolution is done -- Analyze actuals to perform name resolution. Full resolution is done
-- later, when the expected types are known, but names have to be captured -- later, when the expected types are known, but names have to be captured
-- before installing parents of generics, that are not visible for the -- before installing parents of generics, that are not visible for the
...@@ -1027,6 +1027,8 @@ package body Sem_Ch12 is ...@@ -1027,6 +1027,8 @@ package body Sem_Ch12 is
procedure Process_Default (F : Entity_Id) is procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node); Loc : constant Source_Ptr := Sloc (I_Node);
F_Id : constant Entity_Id := Defining_Entity (F);
Decl : Node_Id; Decl : Node_Id;
Default : Node_Id; Default : Node_Id;
Id : Entity_Id; Id : Entity_Id;
...@@ -1036,17 +1038,12 @@ package body Sem_Ch12 is ...@@ -1036,17 +1038,12 @@ package body Sem_Ch12 is
-- new defining identifier for it. -- new defining identifier for it.
Decl := New_Copy_Tree (F); Decl := New_Copy_Tree (F);
Id := Make_Defining_Identifier (Sloc (F_Id), Chars => Chars (F_Id));
if Nkind (F) = N_Formal_Concrete_Subprogram_Declaration then if Nkind (F) in N_Formal_Subprogram_Declaration then
Id :=
Make_Defining_Identifier (Sloc (Defining_Entity (F)),
Chars => Chars (Defining_Entity (F)));
Set_Defining_Unit_Name (Specification (Decl), Id); Set_Defining_Unit_Name (Specification (Decl), Id);
else else
Id :=
Make_Defining_Identifier (Sloc (Defining_Entity (F)),
Chars => Chars (Defining_Identifier (F)));
Set_Defining_Identifier (Decl, Id); Set_Defining_Identifier (Decl, Id);
end if; end if;
...@@ -1652,7 +1649,6 @@ package body Sem_Ch12 is ...@@ -1652,7 +1649,6 @@ package body Sem_Ch12 is
Set_Size_Known_At_Compile_Time Set_Size_Known_At_Compile_Time
(T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def)))); (T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
end Analyze_Formal_Derived_Type; end Analyze_Formal_Derived_Type;
---------------------------------- ----------------------------------
...@@ -1855,7 +1851,7 @@ package body Sem_Ch12 is ...@@ -1855,7 +1851,7 @@ package body Sem_Ch12 is
end if; end if;
if Present (E) then if Present (E) then
Analyze_Per_Use_Expression (E, T); Preanalyze_Spec_Expression (E, T);
if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then if Is_Limited_Type (T) and then not OK_For_Limited_Init (E) then
Error_Msg_N Error_Msg_N
...@@ -2910,7 +2906,7 @@ package body Sem_Ch12 is ...@@ -2910,7 +2906,7 @@ package body Sem_Ch12 is
end if; end if;
Generate_Definition (Act_Decl_Id); Generate_Definition (Act_Decl_Id);
Pre_Analyze_Actuals (N); Preanalyze_Actuals (N);
Init_Env; Init_Env;
Env_Installed := True; Env_Installed := True;
...@@ -3888,9 +3884,7 @@ package body Sem_Ch12 is ...@@ -3888,9 +3884,7 @@ package body Sem_Ch12 is
-- subprogram will be frozen at the point the wrapper package is -- subprogram will be frozen at the point the wrapper package is
-- frozen, so it does not need its own freeze node. In fact, if one -- frozen, so it does not need its own freeze node. In fact, if one
-- is created, it might conflict with the freezing actions from the -- is created, it might conflict with the freezing actions from the
-- wrapper package (see 7206-013). -- wrapper package.
-- Should not really reference non-public TN's in comments ???
Set_Has_Delayed_Freeze (Anon_Id, False); Set_Has_Delayed_Freeze (Anon_Id, False);
...@@ -3946,7 +3940,7 @@ package body Sem_Ch12 is ...@@ -3946,7 +3940,7 @@ package body Sem_Ch12 is
-- Make node global for error reporting -- Make node global for error reporting
Instantiation_Node := N; Instantiation_Node := N;
Pre_Analyze_Actuals (N); Preanalyze_Actuals (N);
Init_Env; Init_Env;
Env_Installed := True; Env_Installed := True;
...@@ -4038,12 +4032,16 @@ package body Sem_Ch12 is ...@@ -4038,12 +4032,16 @@ package body Sem_Ch12 is
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation -- Copy original generic tree, to produce text for instantiation
-- Inherit overriding indicator from instance node.
Act_Tree := Act_Tree :=
Copy_Generic_Node Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True); (Original_Node (Gen_Decl), Empty, Instantiating => True);
Act_Spec := Specification (Act_Tree); Act_Spec := Specification (Act_Tree);
Set_Must_Override (Act_Spec, Must_Override (N));
Set_Must_Not_Override (Act_Spec, Must_Not_Override (N));
Renaming_List := Renaming_List :=
Analyze_Associations Analyze_Associations
(N, (N,
...@@ -4625,11 +4623,22 @@ package body Sem_Ch12 is ...@@ -4625,11 +4623,22 @@ package body Sem_Ch12 is
elsif Is_Overloadable (E1) then elsif Is_Overloadable (E1) then
-- Verify that the names of the entities match. Note that actuals -- Verify that the actual subprograms match. Note that actuals
-- that are attributes are rewritten as subprograms. -- that are attributes are rewritten as subprograms. If the
-- subprogram in the formal package is defaulted, no check is
-- needed. Note that this can only happen in Ada2005 when the
-- formal package can be partially parametrized.
Check_Mismatch if Nkind (Unit_Declaration_Node (E1)) =
(Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2)); N_Subprogram_Renaming_Declaration
and then From_Default (Unit_Declaration_Node (E1))
then
null;
else
Check_Mismatch
(Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
end if;
else else
raise Program_Error; raise Program_Error;
...@@ -8226,7 +8235,7 @@ package body Sem_Ch12 is ...@@ -8226,7 +8235,7 @@ package body Sem_Ch12 is
end if; end if;
end if; end if;
Note_Possible_Modification (Actual); Note_Possible_Modification (Actual, Sure => True);
-- Check for instantiation of atomic/volatile actual for -- Check for instantiation of atomic/volatile actual for
-- non-atomic/volatile formal (RM C.6 (12)). -- non-atomic/volatile formal (RM C.6 (12)).
...@@ -8280,7 +8289,7 @@ package body Sem_Ch12 is ...@@ -8280,7 +8289,7 @@ package body Sem_Ch12 is
Append (Decl_Node, List); Append (Decl_Node, List);
-- No need to repeat (pre-)analysis of some expression nodes -- No need to repeat (pre-)analysis of some expression nodes
-- already handled in Pre_Analyze_Actuals. -- already handled in Preanalyze_Actuals.
if Nkind (Actual) /= N_Allocator then if Nkind (Actual) /= N_Allocator then
Analyze (Actual); Analyze (Actual);
...@@ -8306,7 +8315,7 @@ package body Sem_Ch12 is ...@@ -8306,7 +8315,7 @@ package body Sem_Ch12 is
-- a child unit. -- a child unit.
if Nkind (Actual) = N_Aggregate then if Nkind (Actual) = N_Aggregate then
Pre_Analyze_And_Resolve (Actual, Typ); Preanalyze_And_Resolve (Actual, Typ);
end if; end if;
if Is_Limited_Type (Typ) if Is_Limited_Type (Typ)
...@@ -8397,13 +8406,12 @@ package body Sem_Ch12 is ...@@ -8397,13 +8406,12 @@ package body Sem_Ch12 is
Nkind_In (Actual_Decl, N_Formal_Object_Declaration, Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
N_Object_Declaration) N_Object_Declaration)
and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
and then Has_Null_Exclusion (Actual_Decl) and then not Has_Null_Exclusion (Actual_Decl)
and then not Has_Null_Exclusion (Analyzed_Formal) and then Has_Null_Exclusion (Analyzed_Formal)
then then
Error_Msg_Sloc := Sloc (Actual_Decl); Error_Msg_Sloc := Sloc (Analyzed_Formal);
Error_Msg_N Error_Msg_N
("`NOT NULL` required in formal, to match actual #", ("actual must exclude null to match generic formal#", Actual);
Analyzed_Formal);
end if; end if;
return List; return List;
...@@ -8656,7 +8664,8 @@ package body Sem_Ch12 is ...@@ -8656,7 +8664,8 @@ package body Sem_Ch12 is
--------------------------------- ---------------------------------
procedure Instantiate_Subprogram_Body procedure Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info) (Body_Info : Pending_Body_Info;
Body_Optional : Boolean := False)
is is
Act_Decl : constant Node_Id := Body_Info.Act_Decl; Act_Decl : constant Node_Id := Body_Info.Act_Decl;
Inst_Node : constant Node_Id := Body_Info.Inst_Node; Inst_Node : constant Node_Id := Body_Info.Inst_Node;
...@@ -8709,7 +8718,8 @@ package body Sem_Ch12 is ...@@ -8709,7 +8718,8 @@ package body Sem_Ch12 is
-- For other cases, commpile the body -- For other cases, commpile the body
else else
Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl)); Load_Parent_Of_Generic
(Inst_Node, Specification (Gen_Decl), Body_Optional);
Gen_Body_Id := Corresponding_Body (Gen_Decl); Gen_Body_Id := Corresponding_Body (Gen_Decl);
end if; end if;
end if; end if;
...@@ -8875,7 +8885,10 @@ package body Sem_Ch12 is ...@@ -8875,7 +8885,10 @@ package body Sem_Ch12 is
elsif Serious_Errors_Detected = 0 elsif Serious_Errors_Detected = 0
and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
then then
if Ekind (Anon_Id) = E_Procedure then if Body_Optional then
return;
elsif Ekind (Anon_Id) = E_Procedure then
Act_Body := Act_Body :=
Make_Subprogram_Body (Loc, Make_Subprogram_Body (Loc,
Specification => Specification =>
...@@ -9074,11 +9087,10 @@ package body Sem_Ch12 is ...@@ -9074,11 +9087,10 @@ package body Sem_Ch12 is
Desig_Act := Designated_Type (Base_Type (Act_T)); Desig_Act := Designated_Type (Base_Type (Act_T));
-- The designated type may have been introduced through a limited_ -- The designated type may have been introduced through a limited_
-- with clause, in which case retrieve the non-limited view. -- with clause, in which case retrieve the non-limited view. This
-- applies to incomplete types as well as to class-wide types.
if Ekind (Desig_Act) = E_Incomplete_Type if From_With_Type (Desig_Act) then
and then From_With_Type (Desig_Act)
then
Desig_Act := Available_View (Desig_Act); Desig_Act := Available_View (Desig_Act);
end if; end if;
...@@ -9760,6 +9772,22 @@ package body Sem_Ch12 is ...@@ -9760,6 +9772,22 @@ package body Sem_Ch12 is
end loop; end loop;
end Check_Abstract_Primitives; end Check_Abstract_Primitives;
end if; end if;
-- Verify that limitedness matches. If parent is a limited
-- interface then the generic formal is not unless declared
-- explicitly so. If not declared limited, the actual cannot be
-- limited (see AI05-0087).
if Is_Limited_Type (Act_T)
and then not Is_Limited_Type (A_Gen_T)
and then False
then
Error_Msg_NE
("actual for non-limited & cannot be a limited type", Actual,
Gen_T);
Explain_Limited_Type (Act_T, Actual);
Abandon_Instantiation (Actual);
end if;
end Validate_Derived_Type_Instance; end Validate_Derived_Type_Instance;
-------------------------------------- --------------------------------------
...@@ -10256,7 +10284,8 @@ package body Sem_Ch12 is ...@@ -10256,7 +10284,8 @@ package body Sem_Ch12 is
-- instantiations are available, we must analyze them, to ensure that -- instantiations are available, we must analyze them, to ensure that
-- the public symbols generated are the same when the unit is compiled -- the public symbols generated are the same when the unit is compiled
-- to generate code, and when it is compiled in the context of a unit -- to generate code, and when it is compiled in the context of a unit
-- that needs a particular nested instance. -- that needs a particular nested instance. This process is applied
-- to both package and subprogram instances.
-------------------------------- --------------------------------
-- Collect_Previous_Instances -- -- Collect_Previous_Instances --
...@@ -10284,6 +10313,16 @@ package body Sem_Ch12 is ...@@ -10284,6 +10313,16 @@ package body Sem_Ch12 is
then then
Append_Elmt (Decl, Previous_Instances); Append_Elmt (Decl, Previous_Instances);
-- For a subprogram instantiation, omit instantiations of
-- intrinsic operations (Unchecked_Conversions, etc.) that
-- have no bodies.
elsif Nkind_In (Decl, N_Function_Instantiation,
N_Procedure_Instantiation)
and then not Is_Intrinsic_Subprogram (Entity (Name (Decl)))
then
Append_Elmt (Decl, Previous_Instances);
elsif Nkind (Decl) = N_Package_Declaration then elsif Nkind (Decl) = N_Package_Declaration then
Collect_Previous_Instances Collect_Previous_Instances
(Visible_Declarations (Specification (Decl))); (Visible_Declarations (Specification (Decl)));
...@@ -10416,6 +10455,7 @@ package body Sem_Ch12 is ...@@ -10416,6 +10455,7 @@ package body Sem_Ch12 is
then then
declare declare
Decl : Elmt_Id; Decl : Elmt_Id;
Info : Pending_Body_Info;
Par : Node_Id; Par : Node_Id;
begin begin
...@@ -10446,18 +10486,40 @@ package body Sem_Ch12 is ...@@ -10446,18 +10486,40 @@ package body Sem_Ch12 is
Decl := First_Elmt (Previous_Instances); Decl := First_Elmt (Previous_Instances);
while Present (Decl) loop while Present (Decl) loop
Instantiate_Package_Body Info :=
(Body_Info => (Inst_Node => Node (Decl),
((Inst_Node => Node (Decl), Act_Decl =>
Act_Decl => Instance_Spec (Node (Decl)),
Instance_Spec (Node (Decl)), Expander_Status => Exp_Status,
Expander_Status => Exp_Status, Current_Sem_Unit =>
Current_Sem_Unit => Get_Code_Unit (Sloc (Node (Decl))),
Get_Code_Unit (Sloc (Node (Decl))), Scope_Suppress => Scope_Suppress,
Scope_Suppress => Scope_Suppress, Local_Suppress_Stack_Top =>
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top);
Local_Suppress_Stack_Top)),
Body_Optional => True); -- Package instance
if
Nkind (Node (Decl)) = N_Package_Instantiation
then
Instantiate_Package_Body
(Info, Body_Optional => True);
-- Subprogram instance
else
-- The instance_spec is the wrapper package,
-- and the subprogram declaration is the last
-- declaration in the wrapper.
Info.Act_Decl :=
Last
(Visible_Declarations
(Specification (Info.Act_Decl)));
Instantiate_Subprogram_Body
(Info, Body_Optional => True);
end if;
Next_Elmt (Decl); Next_Elmt (Decl);
end loop; end loop;
...@@ -10474,7 +10536,7 @@ package body Sem_Ch12 is ...@@ -10474,7 +10536,7 @@ package body Sem_Ch12 is
Scope_Suppress => Scope_Suppress, Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top => Local_Suppress_Stack_Top =>
Local_Suppress_Stack_Top)), Local_Suppress_Stack_Top)),
Body_Optional => Body_Optional); Body_Optional => Body_Optional);
end; end;
end if; end if;
...@@ -10634,7 +10696,7 @@ package body Sem_Ch12 is ...@@ -10634,7 +10696,7 @@ package body Sem_Ch12 is
-- Preanalyze_Actuals -- -- Preanalyze_Actuals --
------------------------ ------------------------
procedure Pre_Analyze_Actuals (N : Node_Id) is procedure Preanalyze_Actuals (N : Node_Id) is
Assoc : Node_Id; Assoc : Node_Id;
Act : Node_Id; Act : Node_Id;
Errs : constant Int := Serious_Errors_Detected; Errs : constant Int := Serious_Errors_Detected;
...@@ -10724,7 +10786,7 @@ package body Sem_Ch12 is ...@@ -10724,7 +10786,7 @@ package body Sem_Ch12 is
Next (Assoc); Next (Assoc);
end loop; end loop;
end Pre_Analyze_Actuals; end Preanalyze_Actuals;
------------------- -------------------
-- Remove_Parent -- -- Remove_Parent --
......
gcc/ada/sem_ch12.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, 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- --
...@@ -100,9 +100,11 @@ package Sem_Ch12 is ...@@ -100,9 +100,11 @@ package Sem_Ch12 is
-- between the current procedure and Load_Parent_Of_Generic. -- between the current procedure and Load_Parent_Of_Generic.
procedure Instantiate_Subprogram_Body procedure Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info); (Body_Info : Pending_Body_Info;
Body_Optional : Boolean := False);
-- Called after semantic analysis, to complete the instantiation of -- Called after semantic analysis, to complete the instantiation of
-- function and procedure instances. -- function and procedure instances. The flag Body_Optional has the
-- same purpose as described for Instantiate_Package_Body.
procedure Save_Global_References (N : Node_Id); procedure Save_Global_References (N : Node_Id);
-- Traverse the original generic unit, and capture all references to -- Traverse the original generic unit, and capture all references to
......
gcc/ada/sem_ch13.adb
...@@ -29,7 +29,6 @@ with Einfo; use Einfo; ...@@ -29,7 +29,6 @@ with Einfo; use Einfo;
with Errout; use Errout; with Errout; use Errout;
with Exp_Tss; use Exp_Tss; with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util; with Exp_Util; use Exp_Util;
with Layout; use Layout;
with Lib; use Lib; with Lib; use Lib;
with Lib.Xref; use Lib.Xref; with Lib.Xref; use Lib.Xref;
with Namet; use Namet; with Namet; use Namet;
...@@ -485,7 +484,11 @@ package body Sem_Ch13 is ...@@ -485,7 +484,11 @@ package body Sem_Ch13 is
-- definition clause that is the preferred approach in Ada 95. -- definition clause that is the preferred approach in Ada 95.
procedure Analyze_At_Clause (N : Node_Id) is procedure Analyze_At_Clause (N : Node_Id) is
CS : constant Boolean := Comes_From_Source (N);
begin begin
-- This is an obsolescent feature
Check_Restriction (No_Obsolescent_Features, N); Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then if Warn_On_Obsolescent_Feature then
...@@ -495,11 +498,21 @@ package body Sem_Ch13 is ...@@ -495,11 +498,21 @@ package body Sem_Ch13 is
("\use address attribute definition clause instead?", N); ("\use address attribute definition clause instead?", N);
end if; end if;
-- Rewrite as address clause
Rewrite (N, Rewrite (N,
Make_Attribute_Definition_Clause (Sloc (N), Make_Attribute_Definition_Clause (Sloc (N),
Name => Identifier (N), Name => Identifier (N),
Chars => Name_Address, Chars => Name_Address,
Expression => Expression (N))); Expression => Expression (N)));
-- We preserve Comes_From_Source, since logically the clause still
-- comes from the source program even though it is changed in form.
Set_Comes_From_Source (N, CS);
-- Analyze rewritten clause
Analyze_Attribute_Definition_Clause (N); Analyze_Attribute_Definition_Clause (N);
end Analyze_At_Clause; end Analyze_At_Clause;
...@@ -529,6 +542,10 @@ package body Sem_Ch13 is ...@@ -529,6 +542,10 @@ package body Sem_Ch13 is
-- Common processing for 'Read, 'Write, 'Input and 'Output attribute -- Common processing for 'Read, 'Write, 'Input and 'Output attribute
-- definition clauses. -- definition clauses.
-----------------------------------
-- Analyze_Stream_TSS_Definition --
-----------------------------------
procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
Subp : Entity_Id := Empty; Subp : Entity_Id := Empty;
I : Interp_Index; I : Interp_Index;
...@@ -588,7 +605,6 @@ package body Sem_Ch13 is ...@@ -588,7 +605,6 @@ package body Sem_Ch13 is
return Base_Type (Typ) = Base_Type (Ent) return Base_Type (Typ) = Base_Type (Ent)
and then No (Next_Formal (F)); and then No (Next_Formal (F));
end Has_Good_Profile; end Has_Good_Profile;
-- Start of processing for Analyze_Stream_TSS_Definition -- Start of processing for Analyze_Stream_TSS_Definition
...@@ -739,6 +755,22 @@ package body Sem_Ch13 is ...@@ -739,6 +755,22 @@ package body Sem_Ch13 is
-- Address attribute definition clause -- Address attribute definition clause
when Attribute_Address => Address : begin when Attribute_Address => Address : begin
-- A little error check, catch for X'Address use X'Address;
if Nkind (Nam) = N_Identifier
and then Nkind (Expr) = N_Attribute_Reference
and then Attribute_Name (Expr) = Name_Address
and then Nkind (Prefix (Expr)) = N_Identifier
and then Chars (Nam) = Chars (Prefix (Expr))
then
Error_Msg_NE
("address for & is self-referencing", Prefix (Expr), Ent);
return;
end if;
-- Not that special case, carry on with analysis of expression
Analyze_And_Resolve (Expr, RTE (RE_Address)); Analyze_And_Resolve (Expr, RTE (RE_Address));
if Present (Address_Clause (U_Ent)) then if Present (Address_Clause (U_Ent)) then
...@@ -875,7 +907,7 @@ package body Sem_Ch13 is ...@@ -875,7 +907,7 @@ package body Sem_Ch13 is
-- We mark a possible modification of a variable with an -- We mark a possible modification of a variable with an
-- address clause, since it is likely aliasing is occurring. -- address clause, since it is likely aliasing is occurring.
Note_Possible_Modification (Nam); Note_Possible_Modification (Nam, Sure => False);
-- Here we are checking for explicit overlap of one variable -- Here we are checking for explicit overlap of one variable
-- by another, and if we find this then mark the overlapped -- by another, and if we find this then mark the overlapped
...@@ -920,22 +952,25 @@ package body Sem_Ch13 is ...@@ -920,22 +952,25 @@ package body Sem_Ch13 is
-- If the address clause is of the form: -- If the address clause is of the form:
-- for X'Address use Y'Address -- for Y'Address use X'Address
-- or -- or
-- Const : constant Address := Y'Address; -- Const : constant Address := X'Address;
-- ... -- ...
-- for X'Address use Const; -- for Y'Address use Const;
-- then we make an entry in the table for checking the size and -- then we make an entry in the table for checking the size and
-- alignment of the overlaying variable. We defer this check -- alignment of the overlaying variable. We defer this check
-- till after code generation to take full advantage of the -- till after code generation to take full advantage of the
-- annotation done by the back end. This entry is only made if -- annotation done by the back end. This entry is only made if
-- we have not already posted a warning about size/alignment -- we have not already posted a warning about size/alignment
-- (some warnings of this type are posted in Checks). -- (some warnings of this type are posted in Checks), and if
-- the address clause comes from source.
if Address_Clause_Overlay_Warnings then if Address_Clause_Overlay_Warnings
and then Comes_From_Source (N)
then
declare declare
Ent_X : Entity_Id := Empty; Ent_X : Entity_Id := Empty;
Ent_Y : Entity_Id := Empty; Ent_Y : Entity_Id := Empty;
...@@ -945,7 +980,18 @@ package body Sem_Ch13 is ...@@ -945,7 +980,18 @@ package body Sem_Ch13 is
if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then
Ent_X := Entity (Name (N)); Ent_X := Entity (Name (N));
Address_Clause_Checks.Append ((N, Ent_X, Ent_Y)); Address_Clause_Checks.Append ((N, Ent_X, Ent_Y));
-- If variable overlays a constant view, and we are
-- warning on overlays, then mark the variable as
-- overlaying a constant (we will give warnings later
-- if this variable is assigned).
if Is_Constant_Object (Ent_Y)
and then Ekind (Ent_X) = E_Variable
then
Set_Overlays_Constant (Ent_X);
end if;
end if; end if;
end; end;
end if; end if;
...@@ -1391,10 +1437,6 @@ package body Sem_Ch13 is ...@@ -1391,10 +1437,6 @@ package body Sem_Ch13 is
Set_Has_Small_Clause (U_Ent); Set_Has_Small_Clause (U_Ent);
Set_Has_Small_Clause (Implicit_Base); Set_Has_Small_Clause (Implicit_Base);
Set_Has_Non_Standard_Rep (Implicit_Base); Set_Has_Non_Standard_Rep (Implicit_Base);
-- Recompute RM_Size, but shouldn't this be done in Freeze???
Set_Discrete_RM_Size (U_Ent);
end if; end if;
end Small; end Small;
...@@ -1857,10 +1899,7 @@ package body Sem_Ch13 is ...@@ -1857,10 +1899,7 @@ package body Sem_Ch13 is
-- Don't allow rep clause for standard [wide_[wide_]]character -- Don't allow rep clause for standard [wide_[wide_]]character
elsif Root_Type (Enumtype) = Standard_Character elsif Is_Standard_Character_Type (Enumtype) then
or else Root_Type (Enumtype) = Standard_Wide_Character
or else Root_Type (Enumtype) = Standard_Wide_Wide_Character
then
Error_Msg_N ("enumeration rep clause not allowed for this type", N); Error_Msg_N ("enumeration rep clause not allowed for this type", N);
return; return;
...@@ -2310,6 +2349,14 @@ package body Sem_Ch13 is ...@@ -2310,6 +2349,14 @@ package body Sem_Ch13 is
Error_Msg_N Error_Msg_N
("first bit cannot be negative", First_Bit (CC)); ("first bit cannot be negative", First_Bit (CC));
-- The Last_Bit specified in a component clause must not be
-- less than the First_Bit minus one (RM-13.5.1(10)).
elsif Lbit < Fbit - 1 then
Error_Msg_N
("last bit cannot be less than first bit minus one",
Last_Bit (CC));
-- Values look OK, so find the corresponding record component -- Values look OK, so find the corresponding record component
-- Even though the syntax allows an attribute reference for -- Even though the syntax allows an attribute reference for
-- implementation-defined components, GNAT does not allow the -- implementation-defined components, GNAT does not allow the
......
gcc/ada/sem_ch5.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, 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- --
...@@ -118,31 +118,40 @@ package body Sem_Ch5 is ...@@ -118,31 +118,40 @@ package body Sem_Ch5 is
-- Some special bad cases of entity names -- Some special bad cases of entity names
elsif Is_Entity_Name (N) then elsif Is_Entity_Name (N) then
if Ekind (Entity (N)) = E_In_Parameter then declare
Error_Msg_N Ent : constant Entity_Id := Entity (N);
("assignment to IN mode parameter not allowed", N);
-- Private declarations in a protected object are turned into
-- constants when compiling a protected function.
elsif Present (Scope (Entity (N))) begin
and then Is_Protected_Type (Scope (Entity (N))) if Ekind (Ent) = E_In_Parameter then
and then Error_Msg_N
(Ekind (Current_Scope) = E_Function ("assignment to IN mode parameter not allowed", N);
or else
Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function) -- Renamings of protected private components are turned into
then -- constants when compiling a protected function. In the case
Error_Msg_N -- of single protected types, the private component appears
("protected function cannot modify protected object", N); -- directly.
elsif (Is_Prival (Ent)
and then
(Ekind (Current_Scope) = E_Function
or else Ekind (Enclosing_Dynamic_Scope (
Current_Scope)) = E_Function))
or else
(Ekind (Ent) = E_Component
and then Is_Protected_Type (Scope (Ent)))
then
Error_Msg_N
("protected function cannot modify protected object", N);
elsif Ekind (Entity (N)) = E_Loop_Parameter then elsif Ekind (Ent) = E_Loop_Parameter then
Error_Msg_N Error_Msg_N
("assignment to loop parameter not allowed", N); ("assignment to loop parameter not allowed", N);
else else
Error_Msg_N Error_Msg_N
("left hand side of assignment must be a variable", N); ("left hand side of assignment must be a variable", N);
end if; end if;
end;
-- For indexed components or selected components, test prefix -- For indexed components or selected components, test prefix
...@@ -430,6 +439,15 @@ package body Sem_Ch5 is ...@@ -430,6 +439,15 @@ package body Sem_Ch5 is
("left hand of assignment must not be limited type", Lhs); ("left hand of assignment must not be limited type", Lhs);
Explain_Limited_Type (T1, Lhs); Explain_Limited_Type (T1, Lhs);
return; return;
-- Enforce RM 3.9.3 (8): left-hand side cannot be abstract
elsif Is_Interface (T1)
and then not Is_Class_Wide_Type (T1)
then
Error_Msg_N
("target of assignment operation may not be abstract", Lhs);
return;
end if; end if;
-- Resolution may have updated the subtype, in case the left-hand -- Resolution may have updated the subtype, in case the left-hand
...@@ -469,6 +487,7 @@ package body Sem_Ch5 is ...@@ -469,6 +487,7 @@ package body Sem_Ch5 is
-- This is the point at which we check for an unset reference -- This is the point at which we check for an unset reference
Check_Unset_Reference (Rhs); Check_Unset_Reference (Rhs);
Check_Unprotected_Access (Lhs, Rhs);
-- Remaining steps are skipped if Rhs was syntactically in error -- Remaining steps are skipped if Rhs was syntactically in error
...@@ -588,7 +607,7 @@ package body Sem_Ch5 is ...@@ -588,7 +607,7 @@ package body Sem_Ch5 is
-- We still mark this as a possible modification, that's necessary -- We still mark this as a possible modification, that's necessary
-- to reset Is_True_Constant, and desirable for xref purposes. -- to reset Is_True_Constant, and desirable for xref purposes.
Note_Possible_Modification (Lhs); Note_Possible_Modification (Lhs, Sure => True);
return; return;
-- If we know the right hand side is non-null, then we convert to the -- If we know the right hand side is non-null, then we convert to the
...@@ -635,7 +654,7 @@ package body Sem_Ch5 is ...@@ -635,7 +654,7 @@ package body Sem_Ch5 is
-- Note: modifications of the Lhs may only be recorded after -- Note: modifications of the Lhs may only be recorded after
-- checks have been applied. -- checks have been applied.
Note_Possible_Modification (Lhs); Note_Possible_Modification (Lhs, Sure => True);
-- ??? a real accessibility check is needed when ??? -- ??? a real accessibility check is needed when ???
...@@ -1901,20 +1920,36 @@ package body Sem_Ch5 is ...@@ -1901,20 +1920,36 @@ package body Sem_Ch5 is
Analyze (Id); Analyze (Id);
Ent := Entity (Id); Ent := Entity (Id);
Generate_Reference (Ent, Loop_Statement, ' ');
Generate_Definition (Ent);
-- If we found a label, mark its type. If not, ignore it, since it -- Guard against serious error (typically, a scope mismatch when
-- means we have a conflicting declaration, which would already have -- semantic analysis is requested) by creating loop entity to
-- been diagnosed at declaration time. Set Label_Construct of the -- continue analysis.
-- implicit label declaration, which is not created by the parser
-- for generic units.
if Ekind (Ent) = E_Label then if No (Ent) then
Set_Ekind (Ent, E_Loop); if Total_Errors_Detected /= 0 then
Ent :=
New_Internal_Entity
(E_Loop, Current_Scope, Sloc (Loop_Statement), 'L');
else
raise Program_Error;
end if;
else
Generate_Reference (Ent, Loop_Statement, ' ');
Generate_Definition (Ent);
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then -- If we found a label, mark its type. If not, ignore it, since it
Set_Label_Construct (Parent (Ent), Loop_Statement); -- means we have a conflicting declaration, which would already
-- have been diagnosed at declaration time. Set Label_Construct
-- of the implicit label declaration, which is not created by the
-- parser for generic units.
if Ekind (Ent) = E_Label then
Set_Ekind (Ent, E_Loop);
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
Set_Label_Construct (Parent (Ent), Loop_Statement);
end if;
end if; end if;
end if; end if;
...@@ -1928,10 +1963,10 @@ package body Sem_Ch5 is ...@@ -1928,10 +1963,10 @@ package body Sem_Ch5 is
Set_Parent (Ent, Loop_Statement); Set_Parent (Ent, Loop_Statement);
end if; end if;
-- Kill current values on entry to loop, since statements in body -- Kill current values on entry to loop, since statements in body of
-- of loop may have been executed before the loop is entered. -- loop may have been executed before the loop is entered. Similarly we
-- Similarly we kill values after the loop, since we do not know -- kill values after the loop, since we do not know that the body of the
-- that the body of the loop was executed. -- loop was executed.
Kill_Current_Values; Kill_Current_Values;
Push_Scope (Ent); Push_Scope (Ent);
...@@ -1941,6 +1976,13 @@ package body Sem_Ch5 is ...@@ -1941,6 +1976,13 @@ package body Sem_Ch5 is
End_Scope; End_Scope;
Kill_Current_Values; Kill_Current_Values;
Check_Infinite_Loop_Warning (N); Check_Infinite_Loop_Warning (N);
-- Code after loop is unreachable if the loop has no WHILE or FOR
-- and contains no EXIT statements within the body of the loop.
if No (Iter) and then not Has_Exit (Ent) then
Check_Unreachable_Code (N);
end if;
end Analyze_Loop_Statement; end Analyze_Loop_Statement;
---------------------------- ----------------------------
......
gcc/ada/sem_ch5.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, 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- --
...@@ -47,9 +47,9 @@ package Sem_Ch5 is ...@@ -47,9 +47,9 @@ package Sem_Ch5 is
-- be assumed to be reachable. -- be assumed to be reachable.
procedure Check_Unreachable_Code (N : Node_Id); procedure Check_Unreachable_Code (N : Node_Id);
-- This procedure is called with N being the node for a statement that -- This procedure is called with N being the node for a statement that is
-- is an unconditional transfer of control. It checks to see if the -- an unconditional transfer of control or an apparent infinite loop. It
-- statement is followed by some other statement, and if so generates -- checks to see if the statement is followed by some other statement, and
-- an appropriate warning for unreachable code. -- if so generates an appropriate warning for unreachable code.
end Sem_Ch5; end Sem_Ch5;
gcc/ada/sem_eval.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2007, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2008, 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- --
...@@ -578,9 +578,7 @@ package body Sem_Eval is ...@@ -578,9 +578,7 @@ package body Sem_Eval is
if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
and then Entity (Lf) = Entity (Rf) and then Entity (Lf) = Entity (Rf)
and then not Is_Floating_Point_Type (Etype (L)) and then not Is_Floating_Point_Type (Etype (L))
and then (Ekind (Entity (Lf)) = E_Constant or else and then Is_Constant_Object (Entity (Lf))
Ekind (Entity (Lf)) = E_In_Parameter or else
Ekind (Entity (Lf)) = E_Loop_Parameter)
then then
return True; return True;
...@@ -1432,9 +1430,7 @@ package body Sem_Eval is ...@@ -1432,9 +1430,7 @@ package body Sem_Eval is
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold); Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if (C_Typ = Standard_Character if Is_Standard_Character_Type (C_Typ)
or else C_Typ = Standard_Wide_Character
or else C_Typ = Standard_Wide_Wide_Character)
and then Fold and then Fold
then then
null; null;
...@@ -2269,14 +2265,13 @@ package body Sem_Eval is ...@@ -2269,14 +2265,13 @@ package body Sem_Eval is
Fold : Boolean; Fold : Boolean;
begin begin
-- One special case to deal with first. If we can tell that -- One special case to deal with first. If we can tell that the result
-- the result will be false because the lengths of one or -- will be false because the lengths of one or more index subtypes are
-- more index subtypes are compile time known and different, -- compile time known and different, then we can replace the entire
-- then we can replace the entire result by False. We only -- result by False. We only do this for one dimensional arrays, because
-- do this for one dimensional arrays, because the case of -- the case of multi-dimensional arrays is rare and too much trouble! If
-- multi-dimensional arrays is rare and too much trouble! -- one of the operands is an illegal aggregate, its type might still be
-- If one of the operands is an illegal aggregate, its type -- an arbitrary composite type, so nothing to do.
-- might still be an arbitrary composite type, so nothing to do.
if Is_Array_Type (Typ) if Is_Array_Type (Typ)
and then Typ /= Any_Composite and then Typ /= Any_Composite
...@@ -2289,7 +2284,9 @@ package body Sem_Eval is ...@@ -2289,7 +2284,9 @@ package body Sem_Eval is
return; return;
end if; end if;
declare -- OK, we have the case where we may be able to do this fold
Length_Mismatch : declare
procedure Get_Static_Length (Op : Node_Id; Len : out Uint); procedure Get_Static_Length (Op : Node_Id; Len : out Uint);
-- If Op is an expression for a constrained array with a known -- If Op is an expression for a constrained array with a known
-- at compile time length, then Len is set to this (non-negative -- at compile time length, then Len is set to this (non-negative
...@@ -2303,33 +2300,145 @@ package body Sem_Eval is ...@@ -2303,33 +2300,145 @@ package body Sem_Eval is
T : Entity_Id; T : Entity_Id;
begin begin
-- First easy case string literal
if Nkind (Op) = N_String_Literal then if Nkind (Op) = N_String_Literal then
Len := UI_From_Int (String_Length (Strval (Op))); Len := UI_From_Int (String_Length (Strval (Op)));
return;
end if;
-- Second easy case, not constrained subtype, so no length
elsif not Is_Constrained (Etype (Op)) then if not Is_Constrained (Etype (Op)) then
Len := Uint_Minus_1; Len := Uint_Minus_1;
return;
end if;
else -- General case
T := Etype (First_Index (Etype (Op)));
if Is_Discrete_Type (T) T := Etype (First_Index (Etype (Op)));
and then
Compile_Time_Known_Value (Type_Low_Bound (T)) -- The simple case, both bounds are known at compile time
and then
Compile_Time_Known_Value (Type_High_Bound (T)) if Is_Discrete_Type (T)
and then
Compile_Time_Known_Value (Type_Low_Bound (T))
and then
Compile_Time_Known_Value (Type_High_Bound (T))
then
Len := UI_Max (Uint_0,
Expr_Value (Type_High_Bound (T)) -
Expr_Value (Type_Low_Bound (T)) + 1);
return;
end if;
-- A more complex case, where the bounds are of the form
-- X [+/- K1] .. X [+/- K2]), where X is an expression that is
-- either A'First or A'Last (with A an entity name), or X is an
-- entity name, and the two X's are the same and K1 and K2 are
-- known at compile time, in this case, the length can also be
-- computed at compile time, even though the bounds are not
-- known. A common case of this is e.g. (X'First..X'First+5).
Extract_Length : declare
procedure Decompose_Expr
(Expr : Node_Id;
Ent : out Entity_Id;
Kind : out Character;
Cons : out Uint);
-- Given an expression, see if is of the form above,
-- X [+/- K]. If so Ent is set to the entity in X,
-- Kind is 'F','L','E' for 'First/'Last/simple entity,
-- and Cons is the value of K. If the expression is
-- not of the required form, Ent is set to Empty.
--------------------
-- Decompose_Expr --
--------------------
procedure Decompose_Expr
(Expr : Node_Id;
Ent : out Entity_Id;
Kind : out Character;
Cons : out Uint)
is
Exp : Node_Id;
begin
if Nkind (Expr) = N_Op_Add
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
Exp := Left_Opnd (Expr);
Cons := Expr_Value (Right_Opnd (Expr));
elsif Nkind (Expr) = N_Op_Subtract
and then Compile_Time_Known_Value (Right_Opnd (Expr))
then
Exp := Left_Opnd (Expr);
Cons := -Expr_Value (Right_Opnd (Expr));
else
Exp := Expr;
Cons := Uint_0;
end if;
-- At this stage Exp is set to the potential X
if Nkind (Exp) = N_Attribute_Reference then
if Attribute_Name (Exp) = Name_First then
Kind := 'F';
elsif Attribute_Name (Exp) = Name_Last then
Kind := 'L';
else
Ent := Empty;
return;
end if;
Exp := Prefix (Exp);
else
Kind := 'E';
end if;
if Is_Entity_Name (Exp)
and then Present (Entity (Exp))
then
Ent := Entity (Exp);
else
Ent := Empty;
end if;
end Decompose_Expr;
-- Local Variables
Ent1, Ent2 : Entity_Id;
Kind1, Kind2 : Character;
Cons1, Cons2 : Uint;
-- Start of processing for Extract_Length
begin
Decompose_Expr (Type_Low_Bound (T), Ent1, Kind1, Cons1);
Decompose_Expr (Type_High_Bound (T), Ent2, Kind2, Cons2);
if Present (Ent1)
and then Kind1 = Kind2
and then Ent1 = Ent2
then then
Len := UI_Max (Uint_0, Len := Cons2 - Cons1 + 1;
Expr_Value (Type_High_Bound (T)) -
Expr_Value (Type_Low_Bound (T)) + 1);
else else
Len := Uint_Minus_1; Len := Uint_Minus_1;
end if; end if;
end if; end Extract_Length;
end Get_Static_Length; end Get_Static_Length;
-- Local Variables
Len_L : Uint; Len_L : Uint;
Len_R : Uint; Len_R : Uint;
-- Start of processing for Length_Mismatch
begin begin
Get_Static_Length (Left, Len_L); Get_Static_Length (Left, Len_L);
Get_Static_Length (Right, Len_R); Get_Static_Length (Right, Len_R);
...@@ -2342,12 +2451,13 @@ package body Sem_Eval is ...@@ -2342,12 +2451,13 @@ package body Sem_Eval is
Warn_On_Known_Condition (N); Warn_On_Known_Condition (N);
return; return;
end if; end if;
end; end Length_Mismatch;
end if;
-- Another special case: comparisons of access types, where one or both -- Another special case: comparisons of access types, where one or both
-- operands are known to be null, so the result can be determined. -- operands are known to be null, so the result can be determined.
elsif Is_Access_Type (Typ) then if Is_Access_Type (Typ) then
if Known_Null (Left) then if Known_Null (Left) then
if Known_Null (Right) then if Known_Null (Right) then
Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False); Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False);
......
gcc/ada/sem_res.adb
...@@ -68,6 +68,7 @@ with Sinfo; use Sinfo; ...@@ -68,6 +68,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames; with Snames; use Snames;
with Stand; use Stand; with Stand; use Stand;
with Stringt; use Stringt; with Stringt; use Stringt;
with Style; use Style;
with Targparm; use Targparm; with Targparm; use Targparm;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp; with Uintp; use Uintp;
...@@ -395,9 +396,9 @@ package body Sem_Res is ...@@ -395,9 +396,9 @@ package body Sem_Res is
D : Node_Id; D : Node_Id;
begin begin
-- Any use in a default expression is legal -- Any use in a a spec-expression is legal
if In_Default_Expression then if In_Spec_Expression then
null; null;
elsif Nkind (PN) = N_Range then elsif Nkind (PN) = N_Range then
...@@ -434,10 +435,9 @@ package body Sem_Res is ...@@ -434,10 +435,9 @@ package body Sem_Res is
and then Scope (Disc) = Current_Scope and then Scope (Disc) = Current_Scope
and then not and then not
(Nkind (Parent (P)) = N_Subtype_Indication (Nkind (Parent (P)) = N_Subtype_Indication
and then and then
(Nkind (Parent (Parent (P))) = N_Component_Definition Nkind_In (Parent (Parent (P)), N_Component_Definition,
or else N_Subtype_Declaration)
Nkind (Parent (Parent (P))) = N_Subtype_Declaration)
and then Paren_Count (N) = 0) and then Paren_Count (N) = 0)
then then
Error_Msg_N Error_Msg_N
...@@ -554,8 +554,8 @@ package body Sem_Res is ...@@ -554,8 +554,8 @@ package body Sem_Res is
-- Legal case is in index or discriminant constraint -- Legal case is in index or discriminant constraint
elsif Nkind (PN) = N_Index_Or_Discriminant_Constraint elsif Nkind_In (PN, N_Index_Or_Discriminant_Constraint,
or else Nkind (PN) = N_Discriminant_Association N_Discriminant_Association)
then then
if Paren_Count (N) > 0 then if Paren_Count (N) > 0 then
Error_Msg_N Error_Msg_N
...@@ -576,9 +576,9 @@ package body Sem_Res is ...@@ -576,9 +576,9 @@ package body Sem_Res is
else else
D := PN; D := PN;
P := Parent (PN); P := Parent (PN);
while Nkind (P) /= N_Component_Declaration while not Nkind_In (P, N_Component_Declaration,
and then Nkind (P) /= N_Subtype_Indication N_Subtype_Indication,
and then Nkind (P) /= N_Entry_Declaration N_Entry_Declaration)
loop loop
D := P; D := P;
P := Parent (P); P := Parent (P);
...@@ -591,10 +591,8 @@ package body Sem_Res is ...@@ -591,10 +591,8 @@ package body Sem_Res is
-- is of course a double fault. -- is of course a double fault.
if (Nkind (P) = N_Subtype_Indication if (Nkind (P) = N_Subtype_Indication
and then and then Nkind_In (Parent (P), N_Component_Definition,
(Nkind (Parent (P)) = N_Component_Definition N_Derived_Type_Definition)
or else
Nkind (Parent (P)) = N_Derived_Type_Definition)
and then D = Constraint (P)) and then D = Constraint (P))
-- The constraint itself may be given by a subtype indication, -- The constraint itself may be given by a subtype indication,
...@@ -753,11 +751,10 @@ package body Sem_Res is ...@@ -753,11 +751,10 @@ package body Sem_Res is
loop loop
P := Parent (C); P := Parent (C);
exit when Nkind (P) = N_Subprogram_Body; exit when Nkind (P) = N_Subprogram_Body;
if Nkind_In (P, N_Or_Else,
if Nkind (P) = N_Or_Else or else N_And_Then,
Nkind (P) = N_And_Then or else N_If_Statement,
Nkind (P) = N_If_Statement or else N_Case_Statement)
Nkind (P) = N_Case_Statement
then then
return False; return False;
...@@ -963,25 +960,24 @@ package body Sem_Res is ...@@ -963,25 +960,24 @@ package body Sem_Res is
Require_Entity (N); Require_Entity (N);
end if; end if;
-- If the context expects a value, and the name is a procedure, -- If the context expects a value, and the name is a procedure, this is
-- this is most likely a missing 'Access. Do not try to resolve -- most likely a missing 'Access. Don't try to resolve the parameterless
-- the parameterless call, error will be caught when the outer -- call, error will be caught when the outer call is analyzed.
-- call is analyzed.
if Is_Entity_Name (N) if Is_Entity_Name (N)
and then Ekind (Entity (N)) = E_Procedure and then Ekind (Entity (N)) = E_Procedure
and then not Is_Overloaded (N) and then not Is_Overloaded (N)
and then and then
(Nkind (Parent (N)) = N_Parameter_Association Nkind_In (Parent (N), N_Parameter_Association,
or else Nkind (Parent (N)) = N_Function_Call N_Function_Call,
or else Nkind (Parent (N)) = N_Procedure_Call_Statement) N_Procedure_Call_Statement)
then then
return; return;
end if; end if;
-- Rewrite as call if overloadable entity that is (or could be, in -- Rewrite as call if overloadable entity that is (or could be, in the
-- the overloaded case) a function call. If we know for sure that -- overloaded case) a function call. If we know for sure that the entity
-- the entity is an enumeration literal, we do not rewrite it. -- is an enumeration literal, we do not rewrite it.
if (Is_Entity_Name (N) if (Is_Entity_Name (N)
and then Is_Overloadable (Entity (N)) and then Is_Overloadable (Entity (N))
...@@ -1386,7 +1382,19 @@ package body Sem_Res is ...@@ -1386,7 +1382,19 @@ package body Sem_Res is
Set_Entity (Op_Node, Op_Id); Set_Entity (Op_Node, Op_Id);
Generate_Reference (Op_Id, N, ' '); Generate_Reference (Op_Id, N, ' ');
Rewrite (N, Op_Node);
-- Do rewrite setting Comes_From_Source on the result if the original
-- call came from source. Although it is not strictly the case that the
-- operator as such comes from the source, logically it corresponds
-- exactly to the function call in the source, so it should be marked
-- this way (e.g. to make sure that validity checks work fine).
declare
CS : constant Boolean := Comes_From_Source (N);
begin
Rewrite (N, Op_Node);
Set_Comes_From_Source (N, CS);
end;
-- If this is an arithmetic operator and the result type is private, -- If this is an arithmetic operator and the result type is private,
-- the operands and the result must be wrapped in conversion to -- the operands and the result must be wrapped in conversion to
...@@ -1487,11 +1495,11 @@ package body Sem_Res is ...@@ -1487,11 +1495,11 @@ package body Sem_Res is
return Kind; return Kind;
end Operator_Kind; end Operator_Kind;
----------------------------- ----------------------------
-- Pre_Analyze_And_Resolve -- -- Preanalyze_And_Resolve --
----------------------------- ----------------------------
procedure Pre_Analyze_And_Resolve (N : Node_Id; T : Entity_Id) is procedure Preanalyze_And_Resolve (N : Node_Id; T : Entity_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis; Save_Full_Analysis : constant Boolean := Full_Analysis;
begin begin
...@@ -1506,11 +1514,11 @@ package body Sem_Res is ...@@ -1506,11 +1514,11 @@ package body Sem_Res is
Expander_Mode_Restore; Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis; Full_Analysis := Save_Full_Analysis;
end Pre_Analyze_And_Resolve; end Preanalyze_And_Resolve;
-- Version without context type -- Version without context type
procedure Pre_Analyze_And_Resolve (N : Node_Id) is procedure Preanalyze_And_Resolve (N : Node_Id) is
Save_Full_Analysis : constant Boolean := Full_Analysis; Save_Full_Analysis : constant Boolean := Full_Analysis;
begin begin
...@@ -1522,7 +1530,7 @@ package body Sem_Res is ...@@ -1522,7 +1530,7 @@ package body Sem_Res is
Expander_Mode_Restore; Expander_Mode_Restore;
Full_Analysis := Save_Full_Analysis; Full_Analysis := Save_Full_Analysis;
end Pre_Analyze_And_Resolve; end Preanalyze_And_Resolve;
---------------------------------- ----------------------------------
-- Replace_Actual_Discriminants -- -- Replace_Actual_Discriminants --
...@@ -1647,6 +1655,7 @@ package body Sem_Res is ...@@ -1647,6 +1655,7 @@ package body Sem_Res is
Intval => UR_To_Uint (Realval (N)))); Intval => UR_To_Uint (Realval (N))));
Set_Etype (N, Universal_Integer); Set_Etype (N, Universal_Integer);
Set_Is_Static_Expression (N); Set_Is_Static_Expression (N);
elsif Nkind (N) = N_String_Literal elsif Nkind (N) = N_String_Literal
and then Is_Character_Type (Typ) and then Is_Character_Type (Typ)
then then
...@@ -1909,8 +1918,8 @@ package body Sem_Res is ...@@ -1909,8 +1918,8 @@ package body Sem_Res is
-- of the arguments is Any_Type, and if so, suppress -- of the arguments is Any_Type, and if so, suppress
-- the message, since it is a cascaded error. -- the message, since it is a cascaded error.
if Nkind (N) = N_Function_Call if Nkind_In (N, N_Function_Call,
or else Nkind (N) = N_Procedure_Call_Statement N_Procedure_Call_Statement)
then then
declare declare
A : Node_Id; A : Node_Id;
...@@ -2079,14 +2088,14 @@ package body Sem_Res is ...@@ -2079,14 +2088,14 @@ package body Sem_Res is
-- with a name that is an explicit dereference, there is -- with a name that is an explicit dereference, there is
-- nothing to be done at this point. -- nothing to be done at this point.
elsif Nkind (N) = N_Explicit_Dereference elsif Nkind_In (N, N_Explicit_Dereference,
or else Nkind (N) = N_Attribute_Reference N_Attribute_Reference,
or else Nkind (N) = N_And_Then N_And_Then,
or else Nkind (N) = N_Indexed_Component N_Indexed_Component,
or else Nkind (N) = N_Or_Else N_Or_Else,
or else Nkind (N) = N_Range N_Range,
or else Nkind (N) = N_Selected_Component N_Selected_Component,
or else Nkind (N) = N_Slice N_Slice)
or else Nkind (Name (N)) = N_Explicit_Dereference or else Nkind (Name (N)) = N_Explicit_Dereference
then then
null; null;
...@@ -2094,8 +2103,7 @@ package body Sem_Res is ...@@ -2094,8 +2103,7 @@ package body Sem_Res is
-- For procedure or function calls, set the type of the name, -- For procedure or function calls, set the type of the name,
-- and also the entity pointer for the prefix -- and also the entity pointer for the prefix
elsif (Nkind (N) = N_Procedure_Call_Statement elsif Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call)
or else Nkind (N) = N_Function_Call)
and then (Is_Entity_Name (Name (N)) and then (Is_Entity_Name (Name (N))
or else Nkind (Name (N)) = N_Operator_Symbol) or else Nkind (Name (N)) = N_Operator_Symbol)
then then
...@@ -2398,8 +2406,8 @@ package body Sem_Res is ...@@ -2398,8 +2406,8 @@ package body Sem_Res is
elsif Present (Alias (Entity (N))) elsif Present (Alias (Entity (N)))
and then and then
Nkind (Parent (Parent (Entity (N)))) Nkind (Parent (Parent (Entity (N)))) =
= N_Subprogram_Renaming_Declaration N_Subprogram_Renaming_Declaration
then then
Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ); Rewrite_Renamed_Operator (N, Alias (Entity (N)), Typ);
...@@ -2613,6 +2621,11 @@ package body Sem_Res is ...@@ -2613,6 +2621,11 @@ package body Sem_Res is
Prev : Node_Id := Empty; Prev : Node_Id := Empty;
Orig_A : Node_Id; Orig_A : Node_Id;
procedure Check_Argument_Order;
-- Performs a check for the case where the actuals are all simple
-- identifiers that correspond to the formal names, but in the wrong
-- order, which is considered suspicious and cause for a warning.
procedure Check_Prefixed_Call; procedure Check_Prefixed_Call;
-- If the original node is an overloaded call in prefix notation, -- If the original node is an overloaded call in prefix notation,
-- insert an 'Access or a dereference as needed over the first actual. -- insert an 'Access or a dereference as needed over the first actual.
...@@ -2630,6 +2643,119 @@ package body Sem_Res is ...@@ -2630,6 +2643,119 @@ package body Sem_Res is
-- common type. Used to enforce the restrictions on array conversions -- common type. Used to enforce the restrictions on array conversions
-- of AI95-00246. -- of AI95-00246.
--------------------------
-- Check_Argument_Order --
--------------------------
procedure Check_Argument_Order is
begin
-- Nothing to do if no parameters, or original node is neither a
-- function call nor a procedure call statement (happens in the
-- operator-transformed-to-function call case), or the call does
-- not come from source, or this warning is off.
if not Warn_On_Parameter_Order
or else
No (Parameter_Associations (N))
or else
not Nkind_In (Original_Node (N), N_Procedure_Call_Statement,
N_Function_Call)
or else
not Comes_From_Source (N)
then
return;
end if;
declare
Nargs : constant Nat := List_Length (Parameter_Associations (N));
begin
-- Nothing to do if only one parameter
if Nargs < 2 then
return;
end if;
-- Here if at least two arguments
declare
Actuals : array (1 .. Nargs) of Node_Id;
Actual : Node_Id;
Formal : Node_Id;
Wrong_Order : Boolean := False;
-- Set True if an out of order case is found
begin
-- Collect identifier names of actuals, fail if any actual is
-- not a simple identifier, and record max length of name.
Actual := First (Parameter_Associations (N));
for J in Actuals'Range loop
if Nkind (Actual) /= N_Identifier then
return;
else
Actuals (J) := Actual;
Next (Actual);
end if;
end loop;
-- If we got this far, all actuals are identifiers and the list
-- of their names is stored in the Actuals array.
Formal := First_Formal (Nam);
for J in Actuals'Range loop
-- If we ran out of formals, that's odd, probably an error
-- which will be detected elsewhere, but abandon the search.
if No (Formal) then
return;
end if;
-- If name matches and is in order OK
if Chars (Formal) = Chars (Actuals (J)) then
null;
else
-- If no match, see if it is elsewhere in list and if so
-- flag potential wrong order if type is compatible.
for K in Actuals'Range loop
if Chars (Formal) = Chars (Actuals (K))
and then
Has_Compatible_Type (Actuals (K), Etype (Formal))
then
Wrong_Order := True;
goto Continue;
end if;
end loop;
-- No match
return;
end if;
<<Continue>> Next_Formal (Formal);
end loop;
-- If Formals left over, also probably an error, skip warning
if Present (Formal) then
return;
end if;
-- Here we give the warning if something was out of order
if Wrong_Order then
Error_Msg_N
("actuals for this call may be in wrong order?", N);
end if;
end;
end;
end Check_Argument_Order;
------------------------- -------------------------
-- Check_Prefixed_Call -- -- Check_Prefixed_Call --
------------------------- -------------------------
...@@ -2866,6 +2992,8 @@ package body Sem_Res is ...@@ -2866,6 +2992,8 @@ package body Sem_Res is
-- Start of processing for Resolve_Actuals -- Start of processing for Resolve_Actuals
begin begin
Check_Argument_Order;
if Present (First_Actual (N)) then if Present (First_Actual (N)) then
Check_Prefixed_Call; Check_Prefixed_Call;
end if; end if;
...@@ -2889,7 +3017,7 @@ package body Sem_Res is ...@@ -2889,7 +3017,7 @@ package body Sem_Res is
-- Case where actual is present -- Case where actual is present
-- If the actual is an entity, generate a reference to it now. We -- If the actual is an entity, generate a reference to it now. We
-- do this before the actual is resolved, because a formal of some -- do this before the actual is resolved, because a formal of some
-- protected subprogram, or a task discriminant, will be rewritten -- protected subprogram, or a task discriminant, will be rewritten
-- during expansion, and the reference to the source entity may -- during expansion, and the reference to the source entity may
...@@ -2906,7 +3034,6 @@ package body Sem_Res is ...@@ -2906,7 +3034,6 @@ package body Sem_Res is
and then Ekind (F) /= E_In_Parameter and then Ekind (F) /= E_In_Parameter
then then
Generate_Reference (Orig_A, A, 'm'); Generate_Reference (Orig_A, A, 'm');
elsif not Is_Overloaded (A) then elsif not Is_Overloaded (A) then
Generate_Reference (Orig_A, A); Generate_Reference (Orig_A, A);
end if; end if;
...@@ -2918,6 +3045,14 @@ package body Sem_Res is ...@@ -2918,6 +3045,14 @@ package body Sem_Res is
or else or else
Chars (Selector_Name (Parent (A))) = Chars (F)) Chars (Selector_Name (Parent (A))) = Chars (F))
then then
-- If style checking mode on, check match of formal name
if Style_Check then
if Nkind (Parent (A)) = N_Parameter_Association then
Check_Identifier (Selector_Name (Parent (A)), F);
end if;
end if;
-- If the formal is Out or In_Out, do not resolve and expand the -- If the formal is Out or In_Out, do not resolve and expand the
-- conversion, because it is subsequently expanded into explicit -- conversion, because it is subsequently expanded into explicit
-- temporaries and assignments. However, the object of the -- temporaries and assignments. However, the object of the
...@@ -2941,32 +3076,51 @@ package body Sem_Res is ...@@ -2941,32 +3076,51 @@ package body Sem_Res is
if Has_Aliased_Components (Etype (Expression (A))) if Has_Aliased_Components (Etype (Expression (A)))
/= Has_Aliased_Components (Etype (F)) /= Has_Aliased_Components (Etype (F))
then then
if Ada_Version < Ada_05 then
Error_Msg_N
("both component types in a view conversion must be"
& " aliased, or neither", A);
-- Ada 2005: rule is relaxed (see AI-363) -- In a view conversion, the conversion must be legal in
-- both directions, and thus both component types must be
-- aliased, or neither (4.6 (8)).
elsif Has_Aliased_Components (Etype (F)) -- The additional rule 4.6 (24.9.2) seems unduly
and then -- restrictive: the privacy requirement should not
not Has_Aliased_Components (Etype (Expression (A))) -- apply to generic types, and should be checked in
-- an instance. ARG query is in order.
Error_Msg_N
("both component types in a view conversion must be"
& " aliased, or neither", A);
elsif
not Same_Ancestor (Etype (F), Etype (Expression (A)))
then
if Is_By_Reference_Type (Etype (F))
or else Is_By_Reference_Type (Etype (Expression (A)))
then then
Error_Msg_N Error_Msg_N
("view conversion operand must have aliased " & ("view conversion between unrelated by reference " &
"components", N); "array types not allowed (\'A'I-00246)", A);
Error_Msg_N else
("\since target type has aliased components", N); declare
Comp_Type : constant Entity_Id :=
Component_Type
(Etype (Expression (A)));
begin
if Comes_From_Source (A)
and then Ada_Version >= Ada_05
and then
((Is_Private_Type (Comp_Type)
and then not Is_Generic_Type (Comp_Type))
or else Is_Tagged_Type (Comp_Type)
or else Is_Volatile (Comp_Type))
then
Error_Msg_N
("component type of a view conversion cannot"
& " be private, tagged, or volatile"
& " (RM 4.6 (24))",
Expression (A));
end if;
end;
end if; end if;
elsif not Same_Ancestor (Etype (F), Etype (Expression (A)))
and then
(Is_By_Reference_Type (Etype (F))
or else Is_By_Reference_Type (Etype (Expression (A))))
then
Error_Msg_N
("view conversion between unrelated by reference " &
"array types not allowed (\'A'I-00246)", A);
end if; end if;
end if; end if;
...@@ -3024,14 +3178,15 @@ package body Sem_Res is ...@@ -3024,14 +3178,15 @@ package body Sem_Res is
declare declare
DDT : constant Entity_Id := DDT : constant Entity_Id :=
Directly_Designated_Type (Base_Type (Etype (F))); Directly_Designated_Type (Base_Type (Etype (F)));
New_Itype : Entity_Id; New_Itype : Entity_Id;
begin begin
if Is_Class_Wide_Type (DDT) if Is_Class_Wide_Type (DDT)
and then Is_Interface (DDT) and then Is_Interface (DDT)
then then
New_Itype := Create_Itype (E_Anonymous_Access_Type, A); New_Itype := Create_Itype (E_Anonymous_Access_Type, A);
Set_Etype (New_Itype, Etype (A)); Set_Etype (New_Itype, Etype (A));
Init_Size_Align (New_Itype);
Set_Directly_Designated_Type (New_Itype, Set_Directly_Designated_Type (New_Itype,
Directly_Designated_Type (Etype (A))); Directly_Designated_Type (Etype (A)));
Set_Etype (A, New_Itype); Set_Etype (A, New_Itype);
...@@ -3043,8 +3198,7 @@ package body Sem_Res is ...@@ -3043,8 +3198,7 @@ package body Sem_Res is
-- enabled only, otherwise the transient scope will not -- enabled only, otherwise the transient scope will not
-- be removed in the expansion of the wrapped construct. -- be removed in the expansion of the wrapped construct.
if (Is_Controlled (DDT) if (Is_Controlled (DDT) or else Has_Task (DDT))
or else Has_Task (DDT))
and then Expander_Active and then Expander_Active
then then
Establish_Transient_Scope (A, False); Establish_Transient_Scope (A, False);
...@@ -3056,9 +3210,13 @@ package body Sem_Res is ...@@ -3056,9 +3210,13 @@ package body Sem_Res is
-- a tagged synchronized type, declared outside of the type. -- a tagged synchronized type, declared outside of the type.
-- In this case the controlling actual must be converted to -- In this case the controlling actual must be converted to
-- its corresponding record type, which is the formal type. -- its corresponding record type, which is the formal type.
-- The actual may be a subtype, either because of a constraint
-- or because it is a generic actual, so use base type to
-- locate concurrent type.
if Is_Concurrent_Type (Etype (A)) if Is_Concurrent_Type (Etype (A))
and then Etype (F) = Corresponding_Record_Type (Etype (A)) and then Etype (F) =
Corresponding_Record_Type (Base_Type (Etype (A)))
then then
Rewrite (A, Rewrite (A,
Unchecked_Convert_To Unchecked_Convert_To
...@@ -3130,14 +3288,14 @@ package body Sem_Res is ...@@ -3130,14 +3288,14 @@ package body Sem_Res is
if Ekind (F) /= E_In_Parameter then if Ekind (F) /= E_In_Parameter then
-- For an Out parameter, check for useless assignment. Note -- For an Out parameter, check for useless assignment. Note
-- that we can't set Last_Assignment this early, because we -- that we can't set Last_Assignment this early, because we may
-- may kill current values in Resolve_Call, and that call -- kill current values in Resolve_Call, and that call would
-- would clobber the Last_Assignment field. -- clobber the Last_Assignment field.
-- Note: call Warn_On_Useless_Assignment before doing the -- Note: call Warn_On_Useless_Assignment before doing the check
-- check below for Is_OK_Variable_For_Out_Formal so that the -- below for Is_OK_Variable_For_Out_Formal so that the setting
-- setting of Referenced_As_LHS/Referenced_As_Out_Formal -- of Referenced_As_LHS/Referenced_As_Out_Formal properly
-- properly reflects the last assignment, not this one! -- reflects the last assignment, not this one!
if Ekind (F) = E_Out_Parameter then if Ekind (F) = E_Out_Parameter then
if Warn_On_Modified_As_Out_Parameter (F) if Warn_On_Modified_As_Out_Parameter (F)
...@@ -3258,8 +3416,8 @@ package body Sem_Res is ...@@ -3258,8 +3416,8 @@ package body Sem_Res is
end if; end if;
-- An actual associated with an access parameter is implicitly -- An actual associated with an access parameter is implicitly
-- converted to the anonymous access type of the formal and -- converted to the anonymous access type of the formal and must
-- must satisfy the legality checks for access conversions. -- satisfy the legality checks for access conversions.
if Ekind (F_Typ) = E_Anonymous_Access_Type then if Ekind (F_Typ) = E_Anonymous_Access_Type then
if not Valid_Conversion (A, F_Typ, A) then if not Valid_Conversion (A, F_Typ, A) then
...@@ -3500,8 +3658,7 @@ package body Sem_Res is ...@@ -3500,8 +3658,7 @@ package body Sem_Res is
function In_Dispatching_Context return Boolean is function In_Dispatching_Context return Boolean is
Par : constant Node_Id := Parent (N); Par : constant Node_Id := Parent (N);
begin begin
return (Nkind (Par) = N_Function_Call return Nkind_In (Par, N_Function_Call, N_Procedure_Call_Statement)
or else Nkind (Par) = N_Procedure_Call_Statement)
and then Is_Entity_Name (Name (Par)) and then Is_Entity_Name (Name (Par))
and then Is_Dispatching_Operation (Entity (Name (Par))); and then Is_Dispatching_Operation (Entity (Name (Par)));
end In_Dispatching_Context; end In_Dispatching_Context;
...@@ -3691,10 +3848,7 @@ package body Sem_Res is ...@@ -3691,10 +3848,7 @@ package body Sem_Res is
Aggr := Original_Node (Expression (E)); Aggr := Original_Node (Expression (E));
if Has_Discriminants (Subtyp) if Has_Discriminants (Subtyp)
and then and then Nkind_In (Aggr, N_Aggregate, N_Extension_Aggregate)
(Nkind (Aggr) = N_Aggregate
or else
Nkind (Aggr) = N_Extension_Aggregate)
then then
Discrim := First_Discriminant (Base_Type (Subtyp)); Discrim := First_Discriminant (Base_Type (Subtyp));
...@@ -3938,18 +4092,18 @@ package body Sem_Res is ...@@ -3938,18 +4092,18 @@ package body Sem_Res is
-- N is the expression after "delta" in a fixed_point_definition; -- N is the expression after "delta" in a fixed_point_definition;
-- see RM-3.5.9(6): -- see RM-3.5.9(6):
return Nkind (Parent (N)) = N_Ordinary_Fixed_Point_Definition return Nkind_In (Parent (N), N_Ordinary_Fixed_Point_Definition,
or else Nkind (Parent (N)) = N_Decimal_Fixed_Point_Definition N_Decimal_Fixed_Point_Definition,
-- N is one of the bounds in a real_range_specification; -- N is one of the bounds in a real_range_specification;
-- see RM-3.5.7(5): -- see RM-3.5.7(5):
or else Nkind (Parent (N)) = N_Real_Range_Specification N_Real_Range_Specification,
-- N is the expression of a delta_constraint; -- N is the expression of a delta_constraint;
-- see RM-J.3(3): -- see RM-J.3(3):
or else Nkind (Parent (N)) = N_Delta_Constraint; N_Delta_Constraint);
end Expected_Type_Is_Any_Real; end Expected_Type_Is_Any_Real;
----------------------------- -----------------------------
...@@ -4143,8 +4297,7 @@ package body Sem_Res is ...@@ -4143,8 +4297,7 @@ package body Sem_Res is
-- conversion to a specific fixed-point type (instead the expander -- conversion to a specific fixed-point type (instead the expander
-- takes care of the case). -- takes care of the case).
elsif (B_Typ = Universal_Integer elsif (B_Typ = Universal_Integer or else B_Typ = Universal_Real)
or else B_Typ = Universal_Real)
and then Present (Universal_Interpretation (L)) and then Present (Universal_Interpretation (L))
and then Present (Universal_Interpretation (R)) and then Present (Universal_Interpretation (R))
then then
...@@ -4153,15 +4306,14 @@ package body Sem_Res is ...@@ -4153,15 +4306,14 @@ package body Sem_Res is
Set_Etype (N, B_Typ); Set_Etype (N, B_Typ);
elsif (B_Typ = Universal_Real elsif (B_Typ = Universal_Real
or else Etype (N) = Universal_Fixed or else Etype (N) = Universal_Fixed
or else (Etype (N) = Any_Fixed or else (Etype (N) = Any_Fixed
and then Is_Fixed_Point_Type (B_Typ)) and then Is_Fixed_Point_Type (B_Typ))
or else (Is_Fixed_Point_Type (B_Typ) or else (Is_Fixed_Point_Type (B_Typ)
and then (Is_Integer_Or_Universal (L) and then (Is_Integer_Or_Universal (L)
or else or else
Is_Integer_Or_Universal (R)))) Is_Integer_Or_Universal (R))))
and then (Nkind (N) = N_Op_Multiply or else and then Nkind_In (N, N_Op_Multiply, N_Op_Divide)
Nkind (N) = N_Op_Divide)
then then
if TL = Universal_Integer or else TR = Universal_Integer then if TL = Universal_Integer or else TR = Universal_Integer then
Check_For_Visible_Operator (N, B_Typ); Check_For_Visible_Operator (N, B_Typ);
...@@ -4189,38 +4341,36 @@ package body Sem_Res is ...@@ -4189,38 +4341,36 @@ package body Sem_Res is
Set_Mixed_Mode_Operand (R, TL); Set_Mixed_Mode_Operand (R, TL);
end if; end if;
-- Check the rule in RM05-4.5.5(19.1/2) disallowing the -- Check the rule in RM05-4.5.5(19.1/2) disallowing universal_fixed
-- universal_fixed multiplying operators from being used when the -- multiplying operators from being used when the expected type is
-- expected type is also universal_fixed. Note that B_Typ will be -- also universal_fixed. Note that B_Typ will be Universal_Fixed in
-- Universal_Fixed in some cases where the expected type is actually -- some cases where the expected type is actually Any_Real;
-- Any_Real; Expected_Type_Is_Any_Real takes care of that case. -- Expected_Type_Is_Any_Real takes care of that case.
if Etype (N) = Universal_Fixed if Etype (N) = Universal_Fixed
or else Etype (N) = Any_Fixed or else Etype (N) = Any_Fixed
then then
if B_Typ = Universal_Fixed if B_Typ = Universal_Fixed
and then not Expected_Type_Is_Any_Real (N) and then not Expected_Type_Is_Any_Real (N)
and then Nkind (Parent (N)) /= N_Type_Conversion and then not Nkind_In (Parent (N), N_Type_Conversion,
and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion N_Unchecked_Type_Conversion)
then then
Error_Msg_N Error_Msg_N ("type cannot be determined from context!", N);
("type cannot be determined from context!", N); Error_Msg_N ("\explicit conversion to result type required", N);
Error_Msg_N
("\explicit conversion to result type required", N);
Set_Etype (L, Any_Type); Set_Etype (L, Any_Type);
Set_Etype (R, Any_Type); Set_Etype (R, Any_Type);
else else
if Ada_Version = Ada_83 if Ada_Version = Ada_83
and then Etype (N) = Universal_Fixed and then Etype (N) = Universal_Fixed
and then Nkind (Parent (N)) /= N_Type_Conversion and then not
and then Nkind (Parent (N)) /= N_Unchecked_Type_Conversion Nkind_In (Parent (N), N_Type_Conversion,
N_Unchecked_Type_Conversion)
then then
Error_Msg_N Error_Msg_N
("(Ada 83) fixed-point operation " & ("(Ada 83) fixed-point operation "
"needs explicit conversion", & "needs explicit conversion", N);
N);
end if; end if;
-- The expected type is "any real type" in contexts like -- The expected type is "any real type" in contexts like
...@@ -4239,8 +4389,7 @@ package body Sem_Res is ...@@ -4239,8 +4389,7 @@ package body Sem_Res is
and then (Is_Integer_Or_Universal (L) and then (Is_Integer_Or_Universal (L)
or else Nkind (L) = N_Real_Literal or else Nkind (L) = N_Real_Literal
or else Nkind (R) = N_Real_Literal or else Nkind (R) = N_Real_Literal
or else or else Is_Integer_Or_Universal (R))
Is_Integer_Or_Universal (R))
then then
Set_Etype (N, B_Typ); Set_Etype (N, B_Typ);
...@@ -4254,7 +4403,8 @@ package body Sem_Res is ...@@ -4254,7 +4403,8 @@ package body Sem_Res is
else else
if (TL = Universal_Integer or else TL = Universal_Real) if (TL = Universal_Integer or else TL = Universal_Real)
and then (TR = Universal_Integer or else TR = Universal_Real) and then
(TR = Universal_Integer or else TR = Universal_Real)
then then
Check_For_Visible_Operator (N, B_Typ); Check_For_Visible_Operator (N, B_Typ);
end if; end if;
...@@ -4263,9 +4413,7 @@ package body Sem_Res is ...@@ -4263,9 +4413,7 @@ package body Sem_Res is
-- universal fixed, this is an error, unless there is only one -- universal fixed, this is an error, unless there is only one
-- applicable fixed_point type (usually duration). -- applicable fixed_point type (usually duration).
if B_Typ = Universal_Fixed if B_Typ = Universal_Fixed and then Etype (L) = Universal_Fixed then
and then Etype (L) = Universal_Fixed
then
T := Unique_Fixed_Point_Type (N); T := Unique_Fixed_Point_Type (N);
if T = Any_Type then if T = Any_Type then
...@@ -4306,19 +4454,17 @@ package body Sem_Res is ...@@ -4306,19 +4454,17 @@ package body Sem_Res is
-- Give warning if explicit division by zero -- Give warning if explicit division by zero
if (Nkind (N) = N_Op_Divide if Nkind_In (N, N_Op_Divide, N_Op_Rem, N_Op_Mod)
or else Nkind (N) = N_Op_Rem
or else Nkind (N) = N_Op_Mod)
and then not Division_Checks_Suppressed (Etype (N)) and then not Division_Checks_Suppressed (Etype (N))
then then
Rop := Right_Opnd (N); Rop := Right_Opnd (N);
if Compile_Time_Known_Value (Rop) if Compile_Time_Known_Value (Rop)
and then ((Is_Integer_Type (Etype (Rop)) and then ((Is_Integer_Type (Etype (Rop))
and then Expr_Value (Rop) = Uint_0) and then Expr_Value (Rop) = Uint_0)
or else or else
(Is_Real_Type (Etype (Rop)) (Is_Real_Type (Etype (Rop))
and then Expr_Value_R (Rop) = Ureal_0)) and then Expr_Value_R (Rop) = Ureal_0))
then then
-- Specialize the warning message according to the operation -- Specialize the warning message according to the operation
...@@ -4351,6 +4497,38 @@ package body Sem_Res is ...@@ -4351,6 +4497,38 @@ package body Sem_Res is
Activate_Division_Check (N); Activate_Division_Check (N);
end if; end if;
end if; end if;
-- If Restriction No_Implicit_Conditionals is active, then it is
-- violated if either operand can be negative for mod, or for rem
-- if both operands can be negative.
if Restrictions.Set (No_Implicit_Conditionals)
and then Nkind_In (N, N_Op_Rem, N_Op_Mod)
then
declare
Lo : Uint;
Hi : Uint;
OK : Boolean;
LNeg : Boolean;
RNeg : Boolean;
-- Set if corresponding operand might be negative
begin
Determine_Range (Left_Opnd (N), OK, Lo, Hi);
LNeg := (not OK) or else Lo < 0;
Determine_Range (Right_Opnd (N), OK, Lo, Hi);
RNeg := (not OK) or else Lo < 0;
if (Nkind (N) = N_Op_Rem and then (LNeg and RNeg))
or else
(Nkind (N) = N_Op_Mod and then (LNeg or RNeg))
then
Check_Restriction (No_Implicit_Conditionals, N);
end if;
end;
end if;
end if; end if;
Check_Unset_Reference (L); Check_Unset_Reference (L);
...@@ -4426,8 +4604,7 @@ package body Sem_Res is ...@@ -4426,8 +4604,7 @@ package body Sem_Res is
-- operations use the same circuitry because the name in the call -- operations use the same circuitry because the name in the call
-- can be an arbitrary expression with special resolution rules. -- can be an arbitrary expression with special resolution rules.
elsif Nkind (Subp) = N_Selected_Component elsif Nkind_In (Subp, N_Selected_Component, N_Indexed_Component)
or else Nkind (Subp) = N_Indexed_Component
or else (Is_Entity_Name (Subp) or else (Is_Entity_Name (Subp)
and then Ekind (Entity (Subp)) = E_Entry) and then Ekind (Entity (Subp)) = E_Entry)
then then
...@@ -4474,11 +4651,16 @@ package body Sem_Res is ...@@ -4474,11 +4651,16 @@ package body Sem_Res is
P := N; P := N;
loop loop
P := Parent (P); P := Parent (P);
exit when No (P);
-- Exclude calls that occur within the default of a formal
-- parameter of the entry, since those are evaluated outside
-- of the body.
exit when No (P) or else Nkind (P) = N_Parameter_Specification;
if Nkind (P) = N_Entry_Body if Nkind (P) = N_Entry_Body
or else (Nkind (P) = N_Subprogram_Body or else (Nkind (P) = N_Subprogram_Body
and then Is_Entry_Barrier_Function (P)) and then Is_Entry_Barrier_Function (P))
then then
Rtype := Etype (N); Rtype := Etype (N);
Error_Msg_NE Error_Msg_NE
...@@ -4540,7 +4722,7 @@ package body Sem_Res is ...@@ -4540,7 +4722,7 @@ package body Sem_Res is
Error_Msg_N ("\cannot call operation that may modify it", N); Error_Msg_N ("\cannot call operation that may modify it", N);
end if; end if;
-- Freeze the subprogram name if not in default expression. Note that we -- Freeze the subprogram name if not in a spec-expression. Note that we
-- freeze procedure calls as well as function calls. Procedure calls are -- freeze procedure calls as well as function calls. Procedure calls are
-- not frozen according to the rules (RM 13.14(14)) because it is -- not frozen according to the rules (RM 13.14(14)) because it is
-- impossible to have a procedure call to a non-frozen procedure in pure -- impossible to have a procedure call to a non-frozen procedure in pure
...@@ -4548,7 +4730,7 @@ package body Sem_Res is ...@@ -4548,7 +4730,7 @@ package body Sem_Res is
-- needs extending because we can generate procedure calls that need -- needs extending because we can generate procedure calls that need
-- freezing. -- freezing.
if Is_Entity_Name (Subp) and then not In_Default_Expression then if Is_Entity_Name (Subp) and then not In_Spec_Expression then
Freeze_Expression (Subp); Freeze_Expression (Subp);
end if; end if;
...@@ -4803,12 +4985,14 @@ package body Sem_Res is ...@@ -4803,12 +4985,14 @@ package body Sem_Res is
-- If the subprogram is marked Inline_Always, then even if it returns -- If the subprogram is marked Inline_Always, then even if it returns
-- an unconstrained type the call does not require use of the secondary -- an unconstrained type the call does not require use of the secondary
-- stack. -- stack. However, inlining will only take place if the body to inline
-- is already present. It may not be available if e.g. the subprogram is
-- declared in a child instance.
if Is_Inlined (Nam) if Is_Inlined (Nam)
and then Present (First_Rep_Item (Nam)) and then Has_Pragma_Inline_Always (Nam)
and then Nkind (First_Rep_Item (Nam)) = N_Pragma and then Nkind (Unit_Declaration_Node (Nam)) = N_Subprogram_Declaration
and then Pragma_Name (First_Rep_Item (Nam)) = Name_Inline_Always and then Present (Body_To_Inline (Unit_Declaration_Node (Nam)))
then then
null; null;
...@@ -4883,8 +5067,14 @@ package body Sem_Res is ...@@ -4883,8 +5067,14 @@ package body Sem_Res is
-- way we still take advantage of the current value information while -- way we still take advantage of the current value information while
-- scanning the actuals. -- scanning the actuals.
if (not Is_Library_Level_Entity (Nam) -- We suppress killing values if we are processing the nodes associated
or else Suppress_Value_Tracking_On_Call (Current_Scope)) -- with N_Freeze_Entity nodes. Otherwise the declaration of a tagged
-- type kills all the values as part of analyzing the code that
-- initializes the dispatch tables.
if Inside_Freezing_Actions = 0
and then (not Is_Library_Level_Entity (Nam)
or else Suppress_Value_Tracking_On_Call (Current_Scope))
and then (Comes_From_Source (Nam) and then (Comes_From_Source (Nam)
or else (Present (Alias (Nam)) or else (Present (Alias (Nam))
and then Comes_From_Source (Alias (Nam)))) and then Comes_From_Source (Alias (Nam))))
...@@ -5291,7 +5481,7 @@ package body Sem_Res is ...@@ -5291,7 +5481,7 @@ package body Sem_Res is
and then Comes_From_Source (E) and then Comes_From_Source (E)
and then No (Constant_Value (E)) and then No (Constant_Value (E))
and then Is_Frozen (Etype (E)) and then Is_Frozen (Etype (E))
and then not In_Default_Expression and then not In_Spec_Expression
and then not Is_Imported (E) and then not Is_Imported (E)
then then
...@@ -5852,6 +6042,7 @@ package body Sem_Res is ...@@ -5852,6 +6042,7 @@ package body Sem_Res is
(Corresponding_Equality (Entity (N))) (Corresponding_Equality (Entity (N)))
then then
Eval_Relational_Op (N); Eval_Relational_Op (N);
elsif Nkind (N) = N_Op_Ne elsif Nkind (N) = N_Op_Ne
and then Is_Abstract_Subprogram (Entity (N)) and then Is_Abstract_Subprogram (Entity (N))
then then
...@@ -6382,9 +6573,8 @@ package body Sem_Res is ...@@ -6382,9 +6573,8 @@ package body Sem_Res is
-- In the common case of a call which uses an explicitly null -- In the common case of a call which uses an explicitly null
-- value for an access parameter, give specialized error msg -- value for an access parameter, give specialized error msg
if Nkind (Parent (N)) = N_Procedure_Call_Statement if Nkind_In (Parent (N), N_Procedure_Call_Statement,
or else N_Function_Call)
Nkind (Parent (N)) = N_Function_Call
then then
Error_Msg_N Error_Msg_N
("null is not allowed as argument for an access parameter", N); ("null is not allowed as argument for an access parameter", N);
...@@ -6999,7 +7189,7 @@ package body Sem_Res is ...@@ -6999,7 +7189,7 @@ package body Sem_Res is
-- sequences that otherwise fail to notice the modification. -- sequences that otherwise fail to notice the modification.
if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then if Is_Entity_Name (P) and then Treat_As_Volatile (Entity (P)) then
Note_Possible_Modification (P); Note_Possible_Modification (P, Sure => False);
end if; end if;
end Resolve_Reference; end Resolve_Reference;
...@@ -7223,8 +7413,8 @@ package body Sem_Res is ...@@ -7223,8 +7413,8 @@ package body Sem_Res is
Resolve (L, B_Typ); Resolve (L, B_Typ);
Resolve (R, B_Typ); Resolve (R, B_Typ);
-- Check for issuing warning for always False assert, this happens -- Check for issuing warning for always False assert/check, this happens
-- when assertions are turned off, in which case the pragma Assert -- when assertions are turned off, in which case the pragma Assert/Check
-- was transformed into: -- was transformed into:
-- if False and then <condition> then ... -- if False and then <condition> then ...
...@@ -7241,6 +7431,7 @@ package body Sem_Res is ...@@ -7241,6 +7431,7 @@ package body Sem_Res is
then then
declare declare
Orig : constant Node_Id := Original_Node (Parent (N)); Orig : constant Node_Id := Original_Node (Parent (N));
begin begin
if Nkind (Orig) = N_Pragma if Nkind (Orig) = N_Pragma
and then Pragma_Name (Orig) = Name_Assert and then Pragma_Name (Orig) = Name_Assert
...@@ -7269,6 +7460,29 @@ package body Sem_Res is ...@@ -7269,6 +7460,29 @@ package body Sem_Res is
Error_Msg_N ("?assertion would fail at run-time", Orig); Error_Msg_N ("?assertion would fail at run-time", Orig);
end if; end if;
end; end;
-- Similar processing for Check pragma
elsif Nkind (Orig) = N_Pragma
and then Pragma_Name (Orig) = Name_Check
then
-- Don't want to warn if original condition is explicit False
declare
Expr : constant Node_Id :=
Original_Node
(Expression
(Next (First
(Pragma_Argument_Associations (Orig)))));
begin
if Is_Entity_Name (Expr)
and then Entity (Expr) = Standard_False
then
null;
else
Error_Msg_N ("?check would fail at run-time", Orig);
end if;
end;
end if; end if;
end; end;
end if; end if;
...@@ -7477,16 +7691,17 @@ package body Sem_Res is ...@@ -7477,16 +7691,17 @@ package body Sem_Res is
elsif Nkind (Parent (N)) = N_Op_Concat elsif Nkind (Parent (N)) = N_Op_Concat
and then not Need_Check and then not Need_Check
and then Nkind (Original_Node (N)) /= N_Character_Literal and then not Nkind_In (Original_Node (N), N_Character_Literal,
and then Nkind (Original_Node (N)) /= N_Attribute_Reference N_Attribute_Reference,
and then Nkind (Original_Node (N)) /= N_Qualified_Expression N_Qualified_Expression,
and then Nkind (Original_Node (N)) /= N_Type_Conversion N_Type_Conversion)
then then
Subtype_Id := Typ; Subtype_Id := Typ;
-- Otherwise we must create a string literal subtype. Note that the -- Otherwise we must create a string literal subtype. Note that the
-- whole idea of string literal subtypes is simply to avoid the need -- whole idea of string literal subtypes is simply to avoid the need
-- for building a full fledged array subtype for each literal. -- for building a full fledged array subtype for each literal.
else else
Set_String_Literal_Subtype (N, Typ); Set_String_Literal_Subtype (N, Typ);
Subtype_Id := Etype (N); Subtype_Id := Etype (N);
...@@ -7607,10 +7822,8 @@ package body Sem_Res is ...@@ -7607,10 +7822,8 @@ package body Sem_Res is
-- corresponding character aggregate and let the aggregate -- corresponding character aggregate and let the aggregate
-- code do the checking. -- code do the checking.
if R_Typ = Standard_Character if Is_Standard_Character_Type (R_Typ) then
or else R_Typ = Standard_Wide_Character
or else R_Typ = Standard_Wide_Wide_Character
then
-- Check for the case of full range, where we are definitely OK -- Check for the case of full range, where we are definitely OK
if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then if Component_Type (Typ) = Base_Type (Component_Type (Typ)) then
...@@ -7730,10 +7943,10 @@ package body Sem_Res is ...@@ -7730,10 +7943,10 @@ package body Sem_Res is
Set_Etype (Operand, Universal_Real); Set_Etype (Operand, Universal_Real);
elsif Is_Numeric_Type (Typ) elsif Is_Numeric_Type (Typ)
and then (Nkind (Operand) = N_Op_Multiply and then Nkind_In (Operand, N_Op_Multiply, N_Op_Divide)
or else Nkind (Operand) = N_Op_Divide)
and then (Etype (Right_Opnd (Operand)) = Universal_Real and then (Etype (Right_Opnd (Operand)) = Universal_Real
or else Etype (Left_Opnd (Operand)) = Universal_Real) or else
Etype (Left_Opnd (Operand)) = Universal_Real)
then then
-- Return if expression is ambiguous -- Return if expression is ambiguous
...@@ -8043,11 +8256,7 @@ package body Sem_Res is ...@@ -8043,11 +8256,7 @@ package body Sem_Res is
-- mod. These are the cases where the grouping can affect results. -- mod. These are the cases where the grouping can affect results.
if Paren_Count (Rorig) = 0 if Paren_Count (Rorig) = 0
and then (Nkind (Rorig) = N_Op_Mod and then Nkind_In (Rorig, N_Op_Mod, N_Op_Multiply, N_Op_Divide)
or else
Nkind (Rorig) = N_Op_Multiply
or else
Nkind (Rorig) = N_Op_Divide)
then then
-- For mod, we always give the warning, since the value is -- For mod, we always give the warning, since the value is
-- affected by the parenthesization (e.g. (-5) mod 315 /= -- affected by the parenthesization (e.g. (-5) mod 315 /=
...@@ -8129,9 +8338,7 @@ package body Sem_Res is ...@@ -8129,9 +8338,7 @@ package body Sem_Res is
-- overflow is impossible (divisor > 1) or we have a case of -- overflow is impossible (divisor > 1) or we have a case of
-- division by zero in any case. -- division by zero in any case.
if (Nkind (Rorig) = N_Op_Divide if Nkind_In (Rorig, N_Op_Divide, N_Op_Rem)
or else
Nkind (Rorig) = N_Op_Rem)
and then Compile_Time_Known_Value (Right_Opnd (Rorig)) and then Compile_Time_Known_Value (Right_Opnd (Rorig))
and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1 and then UI_Abs (Expr_Value (Right_Opnd (Rorig))) /= 1
then then
...@@ -8334,7 +8541,6 @@ package body Sem_Res is ...@@ -8334,7 +8541,6 @@ package body Sem_Res is
Set_First_Index (Slice_Subtype, Index); Set_First_Index (Slice_Subtype, Index);
Set_Etype (Slice_Subtype, Base_Type (Etype (N))); Set_Etype (Slice_Subtype, Base_Type (Etype (N)));
Set_Is_Constrained (Slice_Subtype, True); Set_Is_Constrained (Slice_Subtype, True);
Init_Size_Align (Slice_Subtype);
Check_Compile_Time_Size (Slice_Subtype); Check_Compile_Time_Size (Slice_Subtype);
...@@ -8349,7 +8555,9 @@ package body Sem_Res is ...@@ -8349,7 +8555,9 @@ package body Sem_Res is
-- call to Check_Compile_Time_Size could be eliminated, which would -- call to Check_Compile_Time_Size could be eliminated, which would
-- be nice, because then that routine could be made private to Freeze. -- be nice, because then that routine could be made private to Freeze.
if Is_Packed (Slice_Subtype) and not In_Default_Expression then -- Why the test for In_Spec_Expression here ???
if Is_Packed (Slice_Subtype) and not In_Spec_Expression then
Freeze_Itype (Slice_Subtype, N); Freeze_Itype (Slice_Subtype, N);
end if; end if;
...@@ -8435,7 +8643,6 @@ package body Sem_Res is ...@@ -8435,7 +8643,6 @@ package body Sem_Res is
Set_First_Index (Array_Subtype, Index); Set_First_Index (Array_Subtype, Index);
Set_Etype (Array_Subtype, Base_Type (Typ)); Set_Etype (Array_Subtype, Base_Type (Typ));
Set_Is_Constrained (Array_Subtype, True); Set_Is_Constrained (Array_Subtype, True);
Init_Size_Align (Array_Subtype);
Rewrite (N, Rewrite (N,
Make_Unchecked_Type_Conversion (Loc, Make_Unchecked_Type_Conversion (Loc,
...@@ -8573,7 +8780,6 @@ package body Sem_Res is ...@@ -8573,7 +8780,6 @@ package body Sem_Res is
if Nkind (N) = N_Real_Literal then if Nkind (N) = N_Real_Literal then
Error_Msg_NE ("?real literal interpreted as }!", N, T1); Error_Msg_NE ("?real literal interpreted as }!", N, T1);
else else
Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1); Error_Msg_NE ("?universal_fixed expression interpreted as }!", N, T1);
end if; end if;
...@@ -8736,11 +8942,12 @@ package body Sem_Res is ...@@ -8736,11 +8942,12 @@ package body Sem_Res is
return False; return False;
end if; end if;
-- Check that component subtypes statically match -- Check that component subtypes statically match. For numeric
-- types this means that both must be either constrained or
-- unconstrained. For enumeration types the bounds must match.
-- All of this is checked in Subtypes_Statically_Match.
if Is_Constrained (Target_Comp_Type) /= if not Subtypes_Statically_Match
Is_Constrained (Opnd_Comp_Type)
or else not Subtypes_Statically_Match
(Target_Comp_Type, Opnd_Comp_Type) (Target_Comp_Type, Opnd_Comp_Type)
then then
Error_Msg_N Error_Msg_N
...@@ -8993,7 +9200,7 @@ package body Sem_Res is ...@@ -8993,7 +9200,7 @@ package body Sem_Res is
if Nkind (Operand) = N_Selected_Component if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) > and then Object_Access_Level (Operand) >
Type_Access_Level (Target_Type) Type_Access_Level (Target_Type)
then then
-- In an instance, this is a run-time check, but one we -- In an instance, this is a run-time check, but one we
-- know will fail, so generate an appropriate warning. -- know will fail, so generate an appropriate warning.
...@@ -9102,8 +9309,8 @@ package body Sem_Res is ...@@ -9102,8 +9309,8 @@ package body Sem_Res is
-- handles checking the prefix of the operand for this case.) -- handles checking the prefix of the operand for this case.)
if Nkind (Operand) = N_Selected_Component if Nkind (Operand) = N_Selected_Component
and then Object_Access_Level (Operand) and then Object_Access_Level (Operand) >
> Type_Access_Level (Target_Type) Type_Access_Level (Target_Type)
then then
-- In an instance, this is a run-time check, but one we -- In an instance, this is a run-time check, but one we
-- know will fail, so generate an appropriate warning. -- know will fail, so generate an appropriate warning.
......
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