mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-23 06:20:25 +08:00
Code Issues Packages Projects Releases Wiki Activity

exp_ch2.adb: Minor reformatting.

Browse Source 
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
This commit is contained in:
Hristian Kirtchev 2008-04-08 08:50:04 +02:00 committed by Arnaud Charlet
parent b459216877
commit 45fc7ddb49
8 changed files with 869 additions and 442 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

175
gcc/ada/exp_ch2.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -80,12 +80,12 @@ package body Exp_Ch2 is
-- Dispatches to specific expansion procedures.
procedure Expand_Entry_Index_Parameter (N : Node_Id);
-- A reference to the identifier in the entry index specification of
-- protected entry body is modified to a reference to a constant definition
-- equal to the index of the entry family member being called. This
-- constant is calculated as part of the elaboration of the expanded code
-- for the body, and is calculated from the object-wide entry index
-- returned by Next_Entry_Call.
-- A reference to the identifier in the entry index specification of an
-- entry body is modified to a reference to a constant definition equal to
-- the index of the entry family member being called. This constant is
-- calculated as part of the elaboration of the expanded code for the body,
-- and is calculated from the object-wide entry index returned by Next_
-- Entry_Call.
procedure Expand_Entry_Parameter (N : Node_Id);
-- A reference to an entry parameter is modified to be a reference to the
@ -98,12 +98,10 @@ package body Exp_Ch2 is
-- represent the operation within the protected object. In other cases
-- Expand_Formal is a no-op.
procedure Expand_Protected_Private (N : Node_Id);
-- A reference to a private component of a protected type is expanded to a
-- component selected from the record used to implement the protected
-- object. Such a record is passed to all operations on a protected object
-- 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_Protected_Component (N : Node_Id);
-- A reference to a private component of a protected type is expanded into
-- a reference to the corresponding prival in the current protected entry
-- or subprogram.
procedure Expand_Renaming (N : Node_Id);
-- For renamings, just replace the identifier by the corresponding
@ -332,16 +330,12 @@ package body Exp_Ch2 is
elsif Is_Entry_Formal (E) then
Expand_Entry_Parameter (N);
elsif Ekind (E) = E_Component
and then Is_Protected_Private (E)
then
-- Protect against junk use of tasking in no run time mode
elsif Is_Protected_Component (E) then
if No_Run_Time_Mode then
return;
end if;
Expand_Protected_Private (N);
Expand_Protected_Component (N);
elsif Ekind (E) = E_Entry_Index_Parameter then
Expand_Entry_Index_Parameter (N);
@ -385,11 +379,7 @@ package body Exp_Ch2 is
-- Interpret possible Current_Value for constant case
elsif (Ekind (E) = E_Constant
or else
Ekind (E) = E_In_Parameter
or else
Ekind (E) = E_Loop_Parameter)
elsif Is_Constant_Object (E)
and then Present (Current_Value (E))
then
Expand_Current_Value (N);
@ -401,8 +391,10 @@ package body Exp_Ch2 is
----------------------------------
procedure Expand_Entry_Index_Parameter (N : Node_Id) is
Index_Con : constant Entity_Id := Entry_Index_Constant (Entity (N));
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;
----------------------------
@ -477,10 +469,14 @@ package body Exp_Ch2 is
-- we also generate an extra parameter to hold the Constrained
-- 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
and then In_Assignment_Context (N)
then
Note_Possible_Modification (N);
Note_Possible_Modification (N, Sure => True);
end if;
Rewrite (N, New_Occurrence_Of (Renamed_Object (Entity (N)), Loc));
@ -564,93 +560,54 @@ package body Exp_Ch2 is
end if;
end Expand_N_Real_Literal;
------------------------------
-- Expand_Protected_Private --
------------------------------
--------------------------------
-- Expand_Protected_Component --
--------------------------------
procedure Expand_Protected_Private (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;
procedure Expand_Protected_Component (N : Node_Id) is
function Inside_Eliminated_Body return Boolean;
-- Determine whether the current entity is inside a subprogram or an
-- entry which has been marked as eliminated.
----------------------------
-- Inside_Eliminated_Body --
----------------------------
function Inside_Eliminated_Body return Boolean is
S : Entity_Id := Current_Scope;
begin
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
return True;
end if;
S := Scope (S);
end loop;
return False;
end Inside_Eliminated_Body;
-- Start of processing for Expand_Protected_Component
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);
-- 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;
-- If the private component appears in an assignment (either lhs or
-- rhs) and is a one-dimensional array constrained by a discriminant,
-- rewrite as P (Lo .. Hi) with an explicit range, so that discriminal
-- is directly visible. This solves delicate visibility problems.
if Comes_From_Source (N)
and then Is_Array_Type (Etype (E))
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)
and then Ekind (Entity (Lo)) = E_In_Parameter
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)
and then Ekind (Entity (Hi)) = E_In_Parameter
then
Set_High_Bound (D_Range,
Make_Identifier (Loc, Chars (Entity (Hi))));
else
Set_High_Bound (D_Range, Duplicate_Subexpr (Hi));
end if;
Rewrite (N,
Make_Slice (Loc,
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
while not Is_Protected_Type (Scope (Scop)) loop
Scop := Scope (Scop);
end loop;
Append_Elmt (N, Privals_Chain (Scop));
end Expand_Protected_Private;
end Expand_Protected_Component;
---------------------
-- Expand_Renaming --

166
gcc/ada/sem_ch12.adb
View File

@ -488,11 +488,11 @@ package body Sem_Ch12 is
-- and has already been flipped during this phase of instantiation.
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
-- must be inserted in the current scope. We leave the current scope
-- 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
-- instances of the generic parents to be in scope.
@ -685,7 +685,7 @@ package body Sem_Ch12 is
-- at the end of the enclosing generic package, which is semantically
-- neutral.
procedure Pre_Analyze_Actuals (N : Node_Id);
procedure Preanalyze_Actuals (N : Node_Id);
-- Analyze actuals to perform name resolution. Full resolution is done
-- later, when the expected types are known, but names have to be captured
-- before installing parents of generics, that are not visible for the
@ -1027,6 +1027,8 @@ package body Sem_Ch12 is
procedure Process_Default (F : Entity_Id) is
Loc : constant Source_Ptr := Sloc (I_Node);
F_Id : constant Entity_Id := Defining_Entity (F);
Decl : Node_Id;
Default : Node_Id;
Id : Entity_Id;
@ -1036,17 +1038,12 @@ package body Sem_Ch12 is
-- new defining identifier for it.
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
Id :=
Make_Defining_Identifier (Sloc (Defining_Entity (F)),
Chars => Chars (Defining_Entity (F)));
if Nkind (F) in N_Formal_Subprogram_Declaration then
Set_Defining_Unit_Name (Specification (Decl), Id);
else
Id :=
Make_Defining_Identifier (Sloc (Defining_Entity (F)),
Chars => Chars (Defining_Identifier (F)));
Set_Defining_Identifier (Decl, Id);
end if;
@ -1652,7 +1649,6 @@ package body Sem_Ch12 is
Set_Size_Known_At_Compile_Time
(T, Size_Known_At_Compile_Time (Entity (Subtype_Mark (Def))));
end Analyze_Formal_Derived_Type;
----------------------------------
@ -1855,7 +1851,7 @@ package body Sem_Ch12 is
end if;
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
Error_Msg_N
@ -2910,7 +2906,7 @@ package body Sem_Ch12 is
end if;
Generate_Definition (Act_Decl_Id);
Pre_Analyze_Actuals (N);
Preanalyze_Actuals (N);
Init_Env;
Env_Installed := True;
@ -3888,9 +3884,7 @@ package body Sem_Ch12 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
-- is created, it might conflict with the freezing actions from the
-- wrapper package (see 7206-013).
-- Should not really reference non-public TN's in comments ???
-- wrapper package.
Set_Has_Delayed_Freeze (Anon_Id, False);
@ -3946,7 +3940,7 @@ package body Sem_Ch12 is
-- Make node global for error reporting
Instantiation_Node := N;
Pre_Analyze_Actuals (N);
Preanalyze_Actuals (N);
Init_Env;
Env_Installed := True;
@ -4038,12 +4032,16 @@ package body Sem_Ch12 is
Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment);
-- Copy original generic tree, to produce text for instantiation
-- Inherit overriding indicator from instance node.
Act_Tree :=
Copy_Generic_Node
(Original_Node (Gen_Decl), Empty, Instantiating => True);
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 :=
Analyze_Associations
(N,
@ -4625,11 +4623,22 @@ package body Sem_Ch12 is
elsif Is_Overloadable (E1) then
-- Verify that the names of the entities match. Note that actuals
-- that are attributes are rewritten as subprograms.
-- Verify that the actual subprograms match. Note that actuals
-- 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
(Ekind (E2) /= Ekind (E1) or else (Alias (E1)) /= Alias (E2));
if Nkind (Unit_Declaration_Node (E1)) =
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
raise Program_Error;
@ -8226,7 +8235,7 @@ package body Sem_Ch12 is
end if;
end if;
Note_Possible_Modification (Actual);
Note_Possible_Modification (Actual, Sure => True);
-- Check for instantiation of atomic/volatile actual for
-- non-atomic/volatile formal (RM C.6 (12)).
@ -8280,7 +8289,7 @@ package body Sem_Ch12 is
Append (Decl_Node, List);
-- 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
Analyze (Actual);
@ -8306,7 +8315,7 @@ package body Sem_Ch12 is
-- a child unit.
if Nkind (Actual) = N_Aggregate then
Pre_Analyze_And_Resolve (Actual, Typ);
Preanalyze_And_Resolve (Actual, Typ);
end if;
if Is_Limited_Type (Typ)
@ -8397,13 +8406,12 @@ package body Sem_Ch12 is
Nkind_In (Actual_Decl, N_Formal_Object_Declaration,
N_Object_Declaration)
and then Nkind (Analyzed_Formal) = N_Formal_Object_Declaration
and then Has_Null_Exclusion (Actual_Decl)
and then not Has_Null_Exclusion (Analyzed_Formal)
and then not Has_Null_Exclusion (Actual_Decl)
and then Has_Null_Exclusion (Analyzed_Formal)
then
Error_Msg_Sloc := Sloc (Actual_Decl);
Error_Msg_Sloc := Sloc (Analyzed_Formal);
Error_Msg_N
("`NOT NULL` required in formal, to match actual #",
Analyzed_Formal);
("actual must exclude null to match generic formal#", Actual);
end if;
return List;
@ -8656,7 +8664,8 @@ package body Sem_Ch12 is
---------------------------------
procedure Instantiate_Subprogram_Body
(Body_Info : Pending_Body_Info)
(Body_Info : Pending_Body_Info;
Body_Optional : Boolean := False)
is
Act_Decl : constant Node_Id := Body_Info.Act_Decl;
Inst_Node : constant Node_Id := Body_Info.Inst_Node;
@ -8709,7 +8718,8 @@ package body Sem_Ch12 is
-- For other cases, commpile the body
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);
end if;
end if;
@ -8875,7 +8885,10 @@ package body Sem_Ch12 is
elsif Serious_Errors_Detected = 0
and then Nkind (Parent (Inst_Node)) /= N_Compilation_Unit
then
if Ekind (Anon_Id) = E_Procedure then
if Body_Optional then
return;
elsif Ekind (Anon_Id) = E_Procedure then
Act_Body :=
Make_Subprogram_Body (Loc,
Specification =>
@ -9074,11 +9087,10 @@ package body Sem_Ch12 is
Desig_Act := Designated_Type (Base_Type (Act_T));
-- 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
and then From_With_Type (Desig_Act)
then
if From_With_Type (Desig_Act) then
Desig_Act := Available_View (Desig_Act);
end if;
@ -9760,6 +9772,22 @@ package body Sem_Ch12 is
end loop;
end Check_Abstract_Primitives;
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;
--------------------------------------
@ -10256,7 +10284,8 @@ package body Sem_Ch12 is
-- instantiations are available, we must analyze them, to ensure that
-- 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
-- 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 --
@ -10284,6 +10313,16 @@ package body Sem_Ch12 is
then
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
Collect_Previous_Instances
(Visible_Declarations (Specification (Decl)));
@ -10416,6 +10455,7 @@ package body Sem_Ch12 is
then
declare
Decl : Elmt_Id;
Info : Pending_Body_Info;
Par : Node_Id;
begin
@ -10446,18 +10486,40 @@ package body Sem_Ch12 is
Decl := First_Elmt (Previous_Instances);
while Present (Decl) loop
Instantiate_Package_Body
(Body_Info =>
((Inst_Node => Node (Decl),
Act_Decl =>
Instance_Spec (Node (Decl)),
Expander_Status => Exp_Status,
Current_Sem_Unit =>
Get_Code_Unit (Sloc (Node (Decl))),
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top =>
Local_Suppress_Stack_Top)),
Body_Optional => True);
Info :=
(Inst_Node => Node (Decl),
Act_Decl =>
Instance_Spec (Node (Decl)),
Expander_Status => Exp_Status,
Current_Sem_Unit =>
Get_Code_Unit (Sloc (Node (Decl))),
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top =>
Local_Suppress_Stack_Top);
-- 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);
end loop;
@ -10474,7 +10536,7 @@ package body Sem_Ch12 is
Scope_Suppress => Scope_Suppress,
Local_Suppress_Stack_Top =>
Local_Suppress_Stack_Top)),
Body_Optional => Body_Optional);
Body_Optional => Body_Optional);
end;
end if;
@ -10634,7 +10696,7 @@ package body Sem_Ch12 is
-- Preanalyze_Actuals --
------------------------
procedure Pre_Analyze_Actuals (N : Node_Id) is
procedure Preanalyze_Actuals (N : Node_Id) is
Assoc : Node_Id;
Act : Node_Id;
Errs : constant Int := Serious_Errors_Detected;
@ -10724,7 +10786,7 @@ package body Sem_Ch12 is
Next (Assoc);
end loop;
end Pre_Analyze_Actuals;
end Preanalyze_Actuals;
-------------------
-- Remove_Parent --

8
gcc/ada/sem_ch12.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -100,9 +100,11 @@ package Sem_Ch12 is
-- between the current procedure and Load_Parent_Of_Generic.
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
-- 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);
-- Traverse the original generic unit, and capture all references to

81
gcc/ada/sem_ch13.adb
View File

@ -29,7 +29,6 @@ with Einfo; use Einfo;
with Errout; use Errout;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Layout; use Layout;
with Lib; use Lib;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
@ -485,7 +484,11 @@ package body Sem_Ch13 is
-- definition clause that is the preferred approach in Ada 95.
procedure Analyze_At_Clause (N : Node_Id) is
CS : constant Boolean := Comes_From_Source (N);
begin
-- This is an obsolescent feature
Check_Restriction (No_Obsolescent_Features, N);
if Warn_On_Obsolescent_Feature then
@ -495,11 +498,21 @@ package body Sem_Ch13 is
("\use address attribute definition clause instead?", N);
end if;
-- Rewrite as address clause
Rewrite (N,
Make_Attribute_Definition_Clause (Sloc (N),
Name => Identifier (N),
Chars => Name_Address,
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);
end Analyze_At_Clause;
@ -529,6 +542,10 @@ package body Sem_Ch13 is
-- Common processing for 'Read, 'Write, 'Input and 'Output attribute
-- definition clauses.
-----------------------------------
-- Analyze_Stream_TSS_Definition --
-----------------------------------
procedure Analyze_Stream_TSS_Definition (TSS_Nam : TSS_Name_Type) is
Subp : Entity_Id := Empty;
I : Interp_Index;
@ -588,7 +605,6 @@ package body Sem_Ch13 is
return Base_Type (Typ) = Base_Type (Ent)
and then No (Next_Formal (F));
end Has_Good_Profile;
-- Start of processing for Analyze_Stream_TSS_Definition
@ -739,6 +755,22 @@ package body Sem_Ch13 is
-- Address attribute definition clause
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));
if Present (Address_Clause (U_Ent)) then
@ -875,7 +907,7 @@ package body Sem_Ch13 is
-- We mark a possible modification of a variable with an
-- 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
-- by another, and if we find this then mark the overlapped
@ -920,22 +952,25 @@ package body Sem_Ch13 is
-- If the address clause is of the form:
-- for X'Address use Y'Address
-- for Y'Address use X'Address
-- 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
-- alignment of the overlaying variable. We defer this check
-- till after code generation to take full advantage of the
-- annotation done by the back end. This entry is only made if
-- 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
Ent_X : Entity_Id := Empty;
Ent_Y : Entity_Id := Empty;
@ -945,7 +980,18 @@ package body Sem_Ch13 is
if Present (Ent_Y) and then Is_Entity_Name (Name (N)) then
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;
end if;
@ -1391,10 +1437,6 @@ package body Sem_Ch13 is
Set_Has_Small_Clause (U_Ent);
Set_Has_Small_Clause (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 Small;
@ -1857,10 +1899,7 @@ package body Sem_Ch13 is
-- Don't allow rep clause for standard [wide_[wide_]]character
elsif Root_Type (Enumtype) = Standard_Character
or else Root_Type (Enumtype) = Standard_Wide_Character
or else Root_Type (Enumtype) = Standard_Wide_Wide_Character
then
elsif Is_Standard_Character_Type (Enumtype) then
Error_Msg_N ("enumeration rep clause not allowed for this type", N);
return;
@ -2310,6 +2349,14 @@ package body Sem_Ch13 is
Error_Msg_N
("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
-- Even though the syntax allows an attribute reference for
-- implementation-defined components, GNAT does not allow the

120
gcc/ada/sem_ch5.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -118,31 +118,40 @@ package body Sem_Ch5 is
-- Some special bad cases of entity names
elsif Is_Entity_Name (N) then
if Ekind (Entity (N)) = E_In_Parameter then
Error_Msg_N
("assignment to IN mode parameter not allowed", N);
declare
Ent : constant Entity_Id := Entity (N);
-- Private declarations in a protected object are turned into
-- constants when compiling a protected function.
begin
if Ekind (Ent) = E_In_Parameter then
Error_Msg_N
("assignment to IN mode parameter not allowed", N);
elsif Present (Scope (Entity (N)))
and then Is_Protected_Type (Scope (Entity (N)))
and then
(Ekind (Current_Scope) = E_Function
or else
Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function)
then
Error_Msg_N
("protected function cannot modify protected object", N);
-- Renamings of protected private components are turned into
-- constants when compiling a protected function. In the case
-- of single protected types, the private component appears
-- directly.
elsif Ekind (Entity (N)) = E_Loop_Parameter then
Error_Msg_N
("assignment to loop parameter not allowed", N);
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);
else
Error_Msg_N
("left hand side of assignment must be a variable", N);
end if;
elsif Ekind (Ent) = E_Loop_Parameter then
Error_Msg_N
("assignment to loop parameter not allowed", N);
else
Error_Msg_N
("left hand side of assignment must be a variable", N);
end if;
end;
-- For indexed components or selected components, test prefix
@ -430,6 +439,15 @@ package body Sem_Ch5 is
("left hand of assignment must not be limited type", Lhs);
Explain_Limited_Type (T1, Lhs);
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;
-- Resolution may have updated the subtype, in case the left-hand
@ -469,6 +487,7 @@ package body Sem_Ch5 is
-- This is the point at which we check for an unset reference
Check_Unset_Reference (Rhs);
Check_Unprotected_Access (Lhs, Rhs);
-- Remaining steps are skipped if Rhs was syntactically in error
@ -588,7 +607,7 @@ package body Sem_Ch5 is
-- We still mark this as a possible modification, that's necessary
-- to reset Is_True_Constant, and desirable for xref purposes.
Note_Possible_Modification (Lhs);
Note_Possible_Modification (Lhs, Sure => True);
return;
-- If we know the right hand side is non-null, then we convert to the
@ -635,7 +654,7 @@ package body Sem_Ch5 is
-- Note: modifications of the Lhs may only be recorded after
-- checks have been applied.
Note_Possible_Modification (Lhs);
Note_Possible_Modification (Lhs, Sure => True);
-- ??? a real accessibility check is needed when ???
@ -1901,20 +1920,36 @@ package body Sem_Ch5 is
Analyze (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
-- 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.
-- Guard against serious error (typically, a scope mismatch when
-- semantic analysis is requested) by creating loop entity to
-- continue analysis.
if Ekind (Ent) = E_Label then
Set_Ekind (Ent, E_Loop);
if No (Ent) then
if Total_Errors_Detected /= 0 then
Ent :=
New_Internal_Entity
(E_Loop, Current_Scope, Sloc (Loop_Statement), 'L');
else
raise Program_Error;
end if;
if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
Set_Label_Construct (Parent (Ent), Loop_Statement);
else
Generate_Reference (Ent, Loop_Statement, ' ');
Generate_Definition (Ent);
-- If we found a label, mark its type. If not, ignore it, since it
-- 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;
@ -1928,10 +1963,10 @@ package body Sem_Ch5 is
Set_Parent (Ent, Loop_Statement);
end if;
-- Kill current values on entry to loop, since statements in body
-- of loop may have been executed before the loop is entered.
-- Similarly we kill values after the loop, since we do not know
-- that the body of the loop was executed.
-- Kill current values on entry to loop, since statements in body of
-- loop may have been executed before the loop is entered. Similarly we
-- kill values after the loop, since we do not know that the body of the
-- loop was executed.
Kill_Current_Values;
Push_Scope (Ent);
@ -1941,6 +1976,13 @@ package body Sem_Ch5 is
End_Scope;
Kill_Current_Values;
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;
----------------------------

10
gcc/ada/sem_ch5.ads
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -47,9 +47,9 @@ package Sem_Ch5 is
-- be assumed to be reachable.
procedure Check_Unreachable_Code (N : Node_Id);
-- This procedure is called with N being the node for a statement that
-- is an unconditional transfer of control. It checks to see if the
-- statement is followed by some other statement, and if so generates
-- an appropriate warning for unreachable code.
-- This procedure is called with N being the node for a statement that is
-- an unconditional transfer of control or an apparent infinite loop. It
-- checks to see if the statement is followed by some other statement, and
-- if so generates an appropriate warning for unreachable code.
end Sem_Ch5;

170
gcc/ada/sem_eval.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -578,9 +578,7 @@ package body Sem_Eval is
if Nkind (Lf) = N_Identifier and then Nkind (Rf) = N_Identifier
and then Entity (Lf) = Entity (Rf)
and then not Is_Floating_Point_Type (Etype (L))
and then (Ekind (Entity (Lf)) = E_Constant or else
Ekind (Entity (Lf)) = E_In_Parameter or else
Ekind (Entity (Lf)) = E_Loop_Parameter)
and then Is_Constant_Object (Entity (Lf))
then
return True;
@ -1432,9 +1430,7 @@ package body Sem_Eval is
Test_Expression_Is_Foldable (N, Left, Right, Stat, Fold);
if (C_Typ = Standard_Character
or else C_Typ = Standard_Wide_Character
or else C_Typ = Standard_Wide_Wide_Character)
if Is_Standard_Character_Type (C_Typ)
and then Fold
then
null;
@ -2269,14 +2265,13 @@ package body Sem_Eval is
Fold : Boolean;
begin
-- One special case to deal with first. If we can tell that
-- the result will be false because the lengths of one or
-- more index subtypes are compile time known and different,
-- then we can replace the entire result by False. We only
-- do this for one dimensional arrays, because the case of
-- multi-dimensional arrays is rare and too much trouble!
-- If one of the operands is an illegal aggregate, its type
-- might still be an arbitrary composite type, so nothing to do.
-- One special case to deal with first. If we can tell that the result
-- will be false because the lengths of one or more index subtypes are
-- compile time known and different, then we can replace the entire
-- result by False. We only do this for one dimensional arrays, because
-- the case of multi-dimensional arrays is rare and too much trouble! If
-- one of the operands is an illegal aggregate, its type might still be
-- an arbitrary composite type, so nothing to do.
if Is_Array_Type (Typ)
and then Typ /= Any_Composite
@ -2289,7 +2284,9 @@ package body Sem_Eval is
return;
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);
-- If Op is an expression for a constrained array with a known
-- at compile time length, then Len is set to this (non-negative
@ -2303,33 +2300,145 @@ package body Sem_Eval is
T : Entity_Id;
begin
-- First easy case string literal
if Nkind (Op) = N_String_Literal then
Len := UI_From_Int (String_Length (Strval (Op)));
return;
end if;
elsif not Is_Constrained (Etype (Op)) then
-- Second easy case, not constrained subtype, so no length
if not Is_Constrained (Etype (Op)) then
Len := Uint_Minus_1;
return;
end if;
else
T := Etype (First_Index (Etype (Op)));
-- General case
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))
T := Etype (First_Index (Etype (Op)));
-- The simple case, both bounds are known at compile time
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
Len := UI_Max (Uint_0,
Expr_Value (Type_High_Bound (T)) -
Expr_Value (Type_Low_Bound (T)) + 1);
Len := Cons2 - Cons1 + 1;
else
Len := Uint_Minus_1;
end if;
end if;
end Extract_Length;
end Get_Static_Length;
-- Local Variables
Len_L : Uint;
Len_R : Uint;
-- Start of processing for Length_Mismatch
begin
Get_Static_Length (Left, Len_L);
Get_Static_Length (Right, Len_R);
@ -2342,12 +2451,13 @@ package body Sem_Eval is
Warn_On_Known_Condition (N);
return;
end if;
end;
end Length_Mismatch;
end if;
-- Another special case: comparisons of access types, where one or both
-- 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 (Right) then
Fold_Uint (N, Test (Nkind (N) = N_Op_Eq), False);

581
gcc/ada/sem_res.adb
View File

File diff suppressed because it is too large Load Diff