diff options
| -rw-r--r-- | gcc/ada/a-strsup.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/a-stwisu.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/a-stzsup.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/exp_ch2.adb | 57 | ||||
| -rw-r--r-- | gcc/ada/exp_ch2.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 142 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 235 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/lib-util.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/lib-xref.adb | 37 | ||||
| -rw-r--r-- | gcc/ada/nlists.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/treepr.adb | 3 |
12 files changed, 357 insertions, 166 deletions
diff --git a/gcc/ada/a-strsup.adb b/gcc/ada/a-strsup.adb index a53a94d5e41..bf017f87a2b 100644 --- a/gcc/ada/a-strsup.adb +++ b/gcc/ada/a-strsup.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2007, 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- -- @@ -783,7 +783,7 @@ package body Ada.Strings.Superbounded is Index : Positive) return Character is begin - if Index in 1 .. Source.Current_Length then + if Index <= Source.Current_Length then return Source.Data (Index); else raise Strings.Index_Error; diff --git a/gcc/ada/a-stwisu.adb b/gcc/ada/a-stwisu.adb index ad15f3db08c..fb44fa7555f 100644 --- a/gcc/ada/a-stwisu.adb +++ b/gcc/ada/a-stwisu.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2007, 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- -- @@ -784,7 +784,7 @@ package body Ada.Strings.Wide_Superbounded is Index : Positive) return Wide_Character is begin - if Index in 1 .. Source.Current_Length then + if Index <= Source.Current_Length then return Source.Data (Index); else raise Strings.Index_Error; diff --git a/gcc/ada/a-stzsup.adb b/gcc/ada/a-stzsup.adb index 6b8e710f2f9..b10d2cb9f9c 100644 --- a/gcc/ada/a-stzsup.adb +++ b/gcc/ada/a-stzsup.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2003-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 2003-2007, 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- -- @@ -787,7 +787,7 @@ package body Ada.Strings.Wide_Wide_Superbounded is Index : Positive) return Wide_Wide_Character is begin - if Index in 1 .. Source.Current_Length then + if Index <= Source.Current_Length then return Source.Data (Index); else raise Strings.Index_Error; diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index f486d0270de..223b51bc776 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -32,15 +32,16 @@ with Exp_Smem; use Exp_Smem; with Exp_Tss; use Exp_Tss; with Exp_Util; use Exp_Util; with Exp_VFpt; use Exp_VFpt; +with Namet; use Namet; with Nmake; use Nmake; with Opt; use Opt; with Sem; use Sem; -with Sem_Attr; use Sem_Attr; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; +with Snames; use Snames; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -90,13 +91,13 @@ package body Exp_Ch2 is procedure Expand_Entry_Parameter (N : Node_Id); -- A reference to an entry parameter is modified to be a reference to the -- corresponding component of the entry parameter record that is passed by - -- the runtime to the accept body procedure + -- the runtime to the accept body procedure. procedure Expand_Formal (N : Node_Id); -- A reference to a formal parameter of a protected subprogram is expanded -- into the corresponding formal of the unprotected procedure used to -- represent the operation within the protected object. In other cases - -- Expand_Formal is a noop. + -- 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 @@ -156,11 +157,18 @@ package body Exp_Ch2 is and then Nkind (Parent (N)) /= N_Pragma_Argument_Association - -- Same for attribute references that require a simple name prefix + -- Do not replace the prefixes of attribute references, since this + -- causes trouble with cases like 4'Size. Also for Name_Asm_Input and + -- Name_Asm_Output, don't do replacement anywhere, since we can have + -- lvalue references in the arguments. and then not (Nkind (Parent (N)) = N_Attribute_Reference - and then Requires_Simple_Name_Prefix ( - Attribute_Name (Parent (N)))) + and then + (Attribute_Name (Parent (N)) = Name_Asm_Input + or else + Attribute_Name (Parent (N)) = Name_Asm_Output + or else + Prefix (Parent (N)) = N)) then -- Case of Current_Value is a compile time known value @@ -421,6 +429,11 @@ package body Exp_Ch2 is function In_Assignment_Context (N : Node_Id) return Boolean is begin + -- Case of use in a call + + -- ??? passing a formal as actual for a mode IN formal is + -- considered as an assignment? + if Nkind (Parent (N)) = N_Procedure_Call_Statement or else Nkind (Parent (N)) = N_Entry_Call_Statement or else @@ -429,15 +442,25 @@ package body Exp_Ch2 is then return True; + -- Case of a parameter association: climb up to enclosing call + elsif Nkind (Parent (N)) = N_Parameter_Association then return In_Assignment_Context (Parent (N)); + -- Case of a selected component, indexed component or slice prefix: + -- climb up the tree, unless the prefix is of an access type (in + -- which case there is an implicit dereference, and the formal itself + -- is not being assigned to). + elsif (Nkind (Parent (N)) = N_Selected_Component or else Nkind (Parent (N)) = N_Indexed_Component or else Nkind (Parent (N)) = N_Slice) + and then N = Prefix (Parent (N)) + and then not Is_Access_Type (Etype (N)) and then In_Assignment_Context (Parent (N)) then return True; + else return False; end if; @@ -670,6 +693,8 @@ package body Exp_Ch2 is -- through an address clause is rewritten as dereference as well. function Param_Entity (N : Node_Id) return Entity_Id is + Renamed_Obj : Node_Id; + begin -- Simple reference case @@ -677,10 +702,22 @@ package body Exp_Ch2 is if Is_Formal (Entity (N)) then return Entity (N); - elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration - and then Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement - then - return Entity (N); + -- Handle renamings of formal parameters and formals of tasks that + -- are rewritten as renamings. + + elsif Nkind (Parent (Entity (N))) = N_Object_Renaming_Declaration then + Renamed_Obj := Get_Referenced_Object (Renamed_Object (Entity (N))); + + if Is_Entity_Name (Renamed_Obj) + and then Is_Formal (Entity (Renamed_Obj)) + then + return Entity (Renamed_Obj); + + elsif + Nkind (Parent (Parent (Entity (N)))) = N_Accept_Statement + then + return Entity (N); + end if; end if; else diff --git a/gcc/ada/exp_ch2.ads b/gcc/ada/exp_ch2.ads index 87c9d9e8ed6..97b231984b3 100644 --- a/gcc/ada/exp_ch2.ads +++ b/gcc/ada/exp_ch2.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-1997 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -37,9 +37,10 @@ package Exp_Ch2 is -- Given an expression N, determines if the expression is a reference -- to a formal (of a subprogram or entry), and if so returns the Id -- of the corresponding formal entity, otherwise returns Empty. The - -- reason that this is in Exp_Ch2 is that it has to deal with the - -- case where the reference is to an entry formal, and has been - -- expanded already. Since Exp_Ch2 is in charge of the expansion, it - -- is best suited to knowing how to detect this case. + -- reason that this is in Exp_Ch2 is that it has to deal with the case + -- where the reference is to an entry formal, and has been expanded + -- already. Since Exp_Ch2 is in charge of the expansion, it is best + -- suited to knowing how to detect this case. Also handles the case + -- of references to renamings of formals. end Exp_Ch2; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 1c2908e897f..3b4490adf49 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -670,7 +670,7 @@ package body Exp_Ch4 is Flist := Get_Allocator_Final_List (N, Base_Type (T), PtrT); end if; - Convert_Aggr_In_Allocator (Tmp_Node, Exp); + Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); else Node := Relocate_Node (N); Set_Analyzed (Node); @@ -741,7 +741,7 @@ package body Exp_Ch4 is Get_Allocator_Final_List (N, Base_Type (T), PtrT); end if; - Convert_Aggr_In_Allocator (Tmp_Node, Exp); + Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); else Node := Relocate_Node (N); Set_Analyzed (Node); @@ -935,7 +935,7 @@ package body Exp_Ch4 is Set_No_Initialization (Expression (Tmp_Node)); Insert_Action (N, Tmp_Node); - Convert_Aggr_In_Allocator (Tmp_Node, Exp); + Convert_Aggr_In_Allocator (N, Tmp_Node, Exp); Rewrite (N, New_Reference_To (Temp, Loc)); Analyze_And_Resolve (N, PtrT); @@ -1467,7 +1467,7 @@ package body Exp_Ch4 is Make_Implicit_If_Statement (Nod, Condition => Make_Op_Not (Loc, Right_Opnd => Test), Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc)))); end if; end Component_Equality; @@ -1749,20 +1749,20 @@ package body Exp_Ch4 is Make_Implicit_If_Statement (Nod, Condition => Test_Empty_Arrays, Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_True, Loc)))), Make_Implicit_If_Statement (Nod, Condition => Test_Lengths_Correspond, Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_False, Loc)))), Handle_One_Dimension (1, First_Index (Ltyp)), - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Occurrence_Of (Standard_True, Loc))))); Set_Has_Completion (Func_Name, True); @@ -2590,7 +2590,7 @@ package body Exp_Ch4 is Condition => S_Length_Test (1), Then_Statements => New_List (Init_L (1)), Elsif_Parts => Elsif_List, - Else_Statements => New_List (Make_Return_Statement (Loc, + Else_Statements => New_List (Make_Simple_Return_Statement (Loc, Expression => S (Nb_Opnds)))); -- Construct the declaration for H @@ -2641,7 +2641,8 @@ package body Exp_Ch4 is Then_Statements => Copy_Into_R_S (I, I = Nb_Opnds))); end loop; - Append_To (Declare_Stmts, Make_Return_Statement (Loc, Expression => R)); + Append_To + (Declare_Stmts, Make_Simple_Return_Statement (Loc, Expression => R)); -- Construct the declare block @@ -2817,7 +2818,7 @@ package body Exp_Ch4 is P := Parent (N); while Present (P) loop if Nkind (P) = N_Extended_Return_Statement - or else Nkind (P) = N_Return_Statement + or else Nkind (P) = N_Simple_Return_Statement then return True; @@ -3441,7 +3442,7 @@ package body Exp_Ch4 is -- Postpone the generation of a finalization call for the -- current allocator if it acts as a coextension. - if Is_Coextension (N) then + if Is_Dynamic_Coextension (N) then if No (Coextensions (N)) then Set_Coextensions (N, New_Elmt_List); end if; @@ -3762,24 +3763,42 @@ package body Exp_Ch4 is Lo : constant Node_Id := Low_Bound (Rop); Hi : constant Node_Id := High_Bound (Rop); + Ltyp : constant Entity_Id := Etype (Lop); + Lo_Orig : constant Node_Id := Original_Node (Lo); Hi_Orig : constant Node_Id := Original_Node (Hi); Lcheck : constant Compare_Result := Compile_Time_Compare (Lop, Lo); Ucheck : constant Compare_Result := Compile_Time_Compare (Lop, Hi); + Warn1 : constant Boolean := + Constant_Condition_Warnings + and then Comes_From_Source (N); + -- This must be true for any of the optimization warnings, we + -- clearly want to give them only for source with the flag on. + + Warn2 : constant Boolean := + Warn1 + and then Nkind (Original_Node (Rop)) = N_Range + and then Is_Integer_Type (Etype (Lo)); + -- For the case where only one bound warning is elided, we also + -- insist on an explicit range and an integer type. The reason is + -- that the use of enumeration ranges including an end point is + -- common, as is the use of a subtype name, one of whose bounds + -- is the same as the type of the expression. + begin -- If test is explicit x'first .. x'last, replace by valid check - if Is_Scalar_Type (Etype (Lop)) + if Is_Scalar_Type (Ltyp) and then Nkind (Lo_Orig) = N_Attribute_Reference and then Attribute_Name (Lo_Orig) = Name_First and then Nkind (Prefix (Lo_Orig)) in N_Has_Entity - and then Entity (Prefix (Lo_Orig)) = Etype (Lop) + and then Entity (Prefix (Lo_Orig)) = Ltyp and then Nkind (Hi_Orig) = N_Attribute_Reference and then Attribute_Name (Hi_Orig) = Name_Last and then Nkind (Prefix (Hi_Orig)) in N_Has_Entity - and then Entity (Prefix (Hi_Orig)) = Etype (Lop) + and then Entity (Prefix (Hi_Orig)) = Ltyp and then Comes_From_Source (N) and then VM_Target = No_VM then @@ -3787,6 +3806,24 @@ package body Exp_Ch4 is return; end if; + -- If bounds of type are known at compile time, and the end points + -- are known at compile time and identical, this is another case + -- for substituting a valid test. We only do this for discrete + -- types, since it won't arise in practice for float types. + + if Comes_From_Source (N) + and then Is_Discrete_Type (Ltyp) + and then Compile_Time_Known_Value (Type_High_Bound (Ltyp)) + and then Compile_Time_Known_Value (Type_Low_Bound (Ltyp)) + and then Compile_Time_Known_Value (Lo) + and then Compile_Time_Known_Value (Hi) + and then Expr_Value (Type_High_Bound (Ltyp)) = Expr_Value (Hi) + and then Expr_Value (Type_Low_Bound (Ltyp)) = Expr_Value (Lo) + then + Substitute_Valid_Check; + return; + end if; + -- If we have an explicit range, do a bit of optimization based -- on range analysis (we may be able to kill one or both checks). @@ -3795,44 +3832,68 @@ package body Exp_Ch4 is -- legality checks, because we are constant-folding beyond RM 4.9. if Lcheck = LT or else Ucheck = GT then + if Warn1 then + Error_Msg_N ("?range test optimized away", N); + Error_Msg_N ("\?value is known to be out of range", N); + end if; + Rewrite (N, New_Reference_To (Standard_False, Loc)); Analyze_And_Resolve (N, Rtyp); Set_Is_Static_Expression (N, Static); + return; -- If both checks are known to succeed, replace result -- by True, since we know we are in range. elsif Lcheck in Compare_GE and then Ucheck in Compare_LE then + if Warn1 then + Error_Msg_N ("?range test optimized away", N); + Error_Msg_N ("\?value is known to be in range", N); + end if; + Rewrite (N, New_Reference_To (Standard_True, Loc)); Analyze_And_Resolve (N, Rtyp); Set_Is_Static_Expression (N, Static); + return; - -- If lower bound check succeeds and upper bound check is - -- not known to succeed or fail, then replace the range check - -- with a comparison against the upper bound. + -- If lower bound check succeeds and upper bound check is not + -- known to succeed or fail, then replace the range check with + -- a comparison against the upper bound. elsif Lcheck in Compare_GE then + if Warn2 then + Error_Msg_N ("?lower bound test optimized away", Lo); + Error_Msg_N ("\?value is known to be in range", Lo); + end if; + Rewrite (N, Make_Op_Le (Loc, Left_Opnd => Lop, Right_Opnd => High_Bound (Rop))); Analyze_And_Resolve (N, Rtyp); + return; - -- If upper bound check succeeds and lower bound check is - -- not known to succeed or fail, then replace the range check - -- with a comparison against the lower bound. + -- If upper bound check succeeds and lower bound check is not + -- known to succeed or fail, then replace the range check with + -- a comparison against the lower bound. elsif Ucheck in Compare_LE then + if Warn2 then + Error_Msg_N ("?upper bound test optimized away", Hi); + Error_Msg_N ("\?value is known to be in range", Hi); + end if; + Rewrite (N, Make_Op_Ge (Loc, Left_Opnd => Lop, Right_Opnd => Low_Bound (Rop))); Analyze_And_Resolve (N, Rtyp); + return; end if; end; @@ -4203,9 +4264,9 @@ package body Exp_Ch4 is Right_Opnd => Make_In (Loc, Left_Opnd => Left_Opnd (N), - Right_Opnd => Right_Opnd (N)))); + Right_Opnd => Right_Opnd (N)))); - -- We want this tp appear as coming from source if original does (see + -- We want this to appear as coming from source if original does (see -- tranformations in Expand_N_In). Set_Comes_From_Source (N, Cfs); @@ -6295,7 +6356,7 @@ package body Exp_Ch4 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Loop_Statement, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Identifier (Loc, Chars (B))))))); @@ -7413,13 +7474,23 @@ package body Exp_Ch4 is if Is_Access_Type (Target_Type) then - -- Apply an accessibility check if the operand is an - -- access parameter. Note that other checks may still - -- need to be applied below (such as tagged type checks). + -- Apply an accessibility check when the conversion operand is an + -- access parameter (or a renaming thereof), unless conversion was + -- expanded from an unchecked or unrestricted access attribute. Note + -- that other checks may still need to be applied below (such as + -- tagged type checks). if Is_Entity_Name (Operand) - and then Ekind (Entity (Operand)) in Formal_Kind + and then + (Is_Formal (Entity (Operand)) + or else + (Present (Renamed_Object (Entity (Operand))) + and then Is_Entity_Name (Renamed_Object (Entity (Operand))) + and then Is_Formal + (Entity (Renamed_Object (Entity (Operand)))))) and then Ekind (Etype (Operand)) = E_Anonymous_Access_Type + and then (Nkind (Original_Node (N)) /= N_Attribute_Reference + or else Attribute_Name (Original_Node (N)) = Name_Access) then Apply_Accessibility_Check (Operand, Target_Type); @@ -8172,9 +8243,12 @@ package body Exp_Ch4 is -- Case of an access discriminant, or (Ada 2005), of an anonymous -- access component or anonymous access function result: find the - -- final list associated with the scope of the type. + -- final list associated with the scope of the type. (In the + -- anonymous access component kind, a list controller will have + -- been allocated when freezing the record type, and PtrT has an + -- Associated_Final_Chain attribute designating it.) - else + elsif No (Associated_Final_Chain (PtrT)) then Owner := Scope (PtrT); end if; end if; @@ -8480,7 +8554,7 @@ package body Exp_Ch4 is Then_Statements => New_List (Inner_If), Else_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Make_Op_Gt (Loc, Left_Opnd => @@ -8551,7 +8625,7 @@ package body Exp_Ch4 is Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_False, Loc))), Elsif_Parts => New_List ( @@ -8567,12 +8641,12 @@ package body Exp_Ch4 is Then_Statements => New_List ( - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (Standard_True, Loc))))), Else_Statements => New_List ( Loop_Statement, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => Final_Expr))); -- (X : a; Y: a) @@ -8741,7 +8815,7 @@ package body Exp_Ch4 is Make_Handled_Sequence_Of_Statements (Loc, Statements => New_List ( Loop_Statement, - Make_Return_Statement (Loc, + Make_Simple_Return_Statement (Loc, Expression => New_Reference_To (C, Loc))))); return Func_Body; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index d3ee497d77b..71650fe8df6 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -1123,13 +1123,48 @@ package body Exp_Ch6 is Rewrite (Actual, New_Reference_To (Temp, Loc)); Analyze (Actual); - Append_To (Post_Call, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Var, Loc), - Expression => Expr)); + -- If the actual is a conversion of a packed reference, it may + -- already have been expanded by Remove_Side_Effects, and the + -- resulting variable is a temporary which does not designate + -- the proper out-parameter, which may not be addressable. In + -- that case, generate an assignment to the original expression + -- (before expansion of the packed reference) so that the proper + -- expansion of assignment to a packed component can take place. - Set_Assignment_OK (Name (Last (Post_Call))); + declare + Obj : Node_Id; + Lhs : Node_Id; + + begin + if Is_Renaming_Of_Object (Var) + and then Nkind (Renamed_Object (Var)) = N_Selected_Component + and then Is_Entity_Name (Prefix (Renamed_Object (Var))) + and then Nkind (Original_Node (Prefix (Renamed_Object (Var)))) + = N_Indexed_Component + and then + Has_Non_Standard_Rep (Etype (Prefix (Renamed_Object (Var)))) + then + Obj := Renamed_Object (Var); + Lhs := + Make_Selected_Component (Loc, + Prefix => + New_Copy_Tree (Original_Node (Prefix (Obj))), + Selector_Name => New_Copy (Selector_Name (Obj))); + Reset_Analyzed_Flags (Lhs); + + else + Lhs := New_Occurrence_Of (Var, Loc); + end if; + + Set_Assignment_OK (Lhs); + + Append_To (Post_Call, + Make_Assignment_Statement (Loc, + Name => Lhs, + Expression => Expr)); + end; end if; + end Add_Call_By_Copy_Code; ---------------------------------- @@ -2104,13 +2139,21 @@ package body Exp_Ch6 is if Is_Entity_Name (Prev_Orig) then - -- When passing an access parameter as the actual to another - -- access parameter we need to pass along the actual's own - -- associated access level parameter. This is done if we are - -- in the scope of the formal access parameter (if this is an - -- inlined body the extra formal is irrelevant). - - if Ekind (Entity (Prev_Orig)) in Formal_Kind + -- When passing an access parameter, or a renaming of an access + -- parameter, as the actual to another access parameter we need + -- to pass along the actual's own access level parameter. This + -- is done if we are within the scope of the formal access + -- parameter (if this is an inlined body the extra formal is + -- irrelevant). + + if (Is_Formal (Entity (Prev_Orig)) + or else + (Present (Renamed_Object (Entity (Prev_Orig))) + and then + Is_Entity_Name (Renamed_Object (Entity (Prev_Orig))) + and then + Is_Formal + (Entity (Renamed_Object (Entity (Prev_Orig)))))) and then Ekind (Etype (Prev_Orig)) = E_Anonymous_Access_Type and then In_Open_Scopes (Scope (Entity (Prev_Orig))) then @@ -2218,7 +2261,7 @@ package body Exp_Ch6 is if Is_Access_Type (Etype (Formal)) and then Can_Never_Be_Null (Etype (Formal)) and then Nkind (Prev) /= N_Raise_Constraint_Error - and then (Nkind (Prev) = N_Null + and then (Known_Null (Prev) or else not Can_Never_Be_Null (Etype (Prev))) then Install_Null_Excluding_Check (Prev); @@ -2410,7 +2453,7 @@ package body Exp_Ch6 is then Error_Msg_NE ("tag-indeterminate expression " - & " must have designated type& ('R'M 5.2 (6))", + & " must have designated type& (RM 5.2 (6))", N, Root_Type (Etype (Name (Ass)))); else Propagate_Tag (Name (Ass), N); @@ -2419,7 +2462,7 @@ package body Exp_Ch6 is elsif Etype (N) /= Root_Type (Etype (Name (Ass))) then Error_Msg_NE ("tag-indeterminate expression must have type&" - & "('R'M 5.2 (6))", N, Root_Type (Etype (Name (Ass)))); + & "(RM 5.2 (6))", N, Root_Type (Etype (Name (Ass)))); else Propagate_Tag (Name (Ass), N); @@ -2708,9 +2751,21 @@ package body Exp_Ch6 is -- In the case where the intrinsic is to be processed by the back end, -- the call to Expand_Intrinsic_Call will do nothing, which is fine, -- since the idea in this case is to pass the call unchanged. + -- If the intrinsic is an inherited unchecked conversion, and the + -- derived type is the target type of the conversion, we must retain + -- it as the return type of the expression. Otherwise the expansion + -- below, which uses the parent operation, will yield the wrong type. if Is_Intrinsic_Subprogram (Subp) then Expand_Intrinsic_Call (N, Subp); + + if Nkind (N) = N_Unchecked_Type_Conversion + and then Parent_Subp /= Orig_Subp + and then Etype (Parent_Subp) /= Etype (Orig_Subp) + then + Set_Etype (N, Etype (Orig_Subp)); + end if; + return; end if; @@ -3147,7 +3202,7 @@ package body Exp_Ch6 is and then (No (Stat2) or else - (Nkind (Stat2) = N_Return_Statement + (Nkind (Stat2) = N_Simple_Return_Statement and then No (Next (Stat2)))); end; end if; @@ -3211,19 +3266,21 @@ package body Exp_Ch6 is Rewrite (N, New_Occurrence_Of (A, Loc)); Check_Private_View (N); - else -- numeric literal + -- Numeric literal + + else Rewrite (N, New_Copy (A)); end if; end if; return Skip; - elsif Nkind (N) = N_Return_Statement then - + elsif Nkind (N) = N_Simple_Return_Statement then if No (Expression (N)) then Make_Exit_Label; - Rewrite (N, Make_Goto_Statement (Loc, - Name => New_Copy (Lab_Id))); + Rewrite (N, + Make_Goto_Statement (Loc, + Name => New_Copy (Lab_Id))); else if Nkind (Parent (N)) = N_Handled_Sequence_Of_Statements @@ -3863,7 +3920,7 @@ package body Exp_Ch6 is if Is_Inherently_Limited_Type (Typ) then return True; - elsif Nkind (Parent (N)) /= N_Return_Statement then + elsif Nkind (Parent (N)) /= N_Simple_Return_Statement then return False; elsif Requires_Transient_Scope (Typ) then @@ -4113,7 +4170,7 @@ package body Exp_Ch6 is Loc := Sloc (Last_Stm); end if; - Append_To (S, Make_Return_Statement (Loc)); + Append_To (S, Make_Simple_Return_Statement (Loc)); end if; end Add_Return; @@ -4275,7 +4332,8 @@ package body Exp_Ch6 is then Add_Discriminal_Declarations (Declarations (N), Scop, Name_uObject, Loc); - Add_Private_Declarations (Declarations (N), Scop, Name_uObject, Loc); + Add_Private_Declarations + (Declarations (N), Scop, Name_uObject, Loc); -- Associate privals and discriminals with the next protected -- operation body to be expanded. These are used to expand references @@ -4787,7 +4845,7 @@ package body Exp_Ch6 is function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean is begin - if Nkind (N) = N_Return_Statement + if Nkind (N) = N_Simple_Return_Statement or else Nkind (N) = N_Extended_Return_Statement then return Is_Build_In_Place_Function @@ -4841,11 +4899,7 @@ package body Exp_Ch6 is while Present (Iface_DT_Ptr) and then Ekind (Node (Iface_DT_Ptr)) = E_Constant loop - Expand_Interface_Thunk - (N => Prim, - Thunk_Alias => Prim, - Thunk_Id => Thunk_Id, - Thunk_Code => Thunk_Code); + Expand_Interface_Thunk (Prim, Thunk_Id, Thunk_Code); if Present (Thunk_Code) then Insert_Actions (N, New_List ( @@ -4867,89 +4921,88 @@ package body Exp_Ch6 is -- Local variables Subp : constant Entity_Id := Entity (N); - Typ : constant Entity_Id := Etype (Subp); - Utyp : constant Entity_Id := Underlying_Type (Typ); begin - if not Static_Dispatch_Tables then + -- We suppress the initialization of the dispatch table entry when + -- VM_Target because the dispatching mechanism is handled internally + -- by the VM. + + if Is_Dispatching_Operation (Subp) + and then not Is_Abstract_Subprogram (Subp) + and then Present (DTC_Entity (Subp)) + and then Present (Scope (DTC_Entity (Subp))) + and then VM_Target = No_VM + and then not Restriction_Active (No_Dispatching_Calls) + and then RTE_Available (RE_Tag) + then declare - E : constant Entity_Id := Subp; - Typ : Entity_Id; + Typ : constant Entity_Id := Scope (DTC_Entity (Subp)); begin - -- We assume that imported CPP primitives correspond with objects - -- whose constructor is in the CPP side (and therefore we don't - -- need to generate code to register them in the dispatch table). + -- Handle private overriden primitives - if Is_Imported (E) - and then Convention (E) = Convention_CPP - then - return; + if not Is_CPP_Class (Typ) then + Check_Overriding_Operation (Subp); end if; - -- When a primitive is frozen, enter its name in the corresponding - -- dispatch table. If the DTC_Entity field is not set this is - -- an overridden primitive that can be ignored. We suppress the - -- initialization of the dispatch table entry when VM_Target - -- because the dispatching mechanism is handled internally by - -- the VM. - - if Is_Dispatching_Operation (E) - and then not Is_Abstract_Subprogram (E) - and then Present (DTC_Entity (E)) - and then VM_Target = No_VM - and then not Is_CPP_Class (Scope (DTC_Entity (E))) - then - Check_Overriding_Operation (E); + -- We assume that imported CPP primitives correspond with objects + -- whose constructor is in the CPP side; therefore we don't need + -- to generate code to register them in the dispatch table. - -- Register the primitive in its dispatch table if we are not - -- compiling under No_Dispatching_Calls restriction + if Is_CPP_Class (Typ) then + null; - if not Restriction_Active (No_Dispatching_Calls) - and then RTE_Available (RE_Tag) - then - Typ := Scope (DTC_Entity (E)); + -- Handle CPP primitives found in derivations of CPP_Class types. + -- These primitives must have been inherited from some parent, and + -- there is no need to register them in the dispatch table because + -- Build_Inherit_Prims takes care of the initialization of these + -- slots. - if not Is_Interface (Typ) - or else Present (Abstract_Interface_Alias (E)) - then - if Is_Predefined_Dispatching_Operation (E) then - Register_Predefined_DT_Entry (E); - end if; + elsif Is_Imported (Subp) + and then (Convention (Subp) = Convention_CPP + or else Convention (Subp) = Convention_C) + then + null; + + -- Generate code to register the primitive in non statically + -- allocated dispatch tables + + elsif not Static_Dispatch_Tables + or else not + Is_Library_Level_Tagged_Type (Scope (DTC_Entity (Subp))) + then + -- When a primitive is frozen, enter its name in its dispatch + -- table slot. - Register_Primitive (Loc, - Prim => E, - Ins_Nod => N); + if not Is_Interface (Typ) + or else Present (Abstract_Interface_Alias (Subp)) + then + if Is_Predefined_Dispatching_Operation (Subp) then + Register_Predefined_DT_Entry (Subp); end if; + + Register_Primitive (Loc, + Prim => Subp, + Ins_Nod => N); end if; end if; end; - - -- GCC 4.1 backend - - else - -- Handle private overriden primitives - - if Is_Dispatching_Operation (Subp) - and then not Is_Abstract_Subprogram (Subp) - and then Present (DTC_Entity (Subp)) - and then VM_Target = No_VM - and then not Is_CPP_Class (Scope (DTC_Entity (Subp))) - then - Check_Overriding_Operation (Subp); - end if; end if; -- Mark functions that return by reference. Note that it cannot be part -- of the normal semantic analysis of the spec since the underlying -- returned type may not be known yet (for private types). - if Is_Inherently_Limited_Type (Typ) then - Set_Returns_By_Ref (Subp); - - elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then - Set_Returns_By_Ref (Subp); - end if; + declare + Typ : constant Entity_Id := Etype (Subp); + Utyp : constant Entity_Id := Underlying_Type (Typ); + begin + if Is_Inherently_Limited_Type (Typ) then + Set_Returns_By_Ref (Subp); + elsif Present (Utyp) and then CW_Or_Controlled_Type (Utyp) then + Set_Returns_By_Ref (Subp); + end if; + end; end Freeze_Subprogram; ------------------------------------------- diff --git a/gcc/ada/exp_ch6.ads b/gcc/ada/exp_ch6.ads index 415fad22bb0..43c9c4d4d54 100644 --- a/gcc/ada/exp_ch6.ads +++ b/gcc/ada/exp_ch6.ads @@ -72,7 +72,7 @@ package Exp_Ch6 is -- Present if result type contains tasks. Master associated with -- calling context. BIP_Activation_Chain, - -- Present if result type contains tasks. Caller's activation chain. + -- Present if result type contains tasks. Caller's activation chain BIP_Object_Access); -- Present for all build-in-place functions. Address at which to place -- the return object, or null if BIP_Alloc_Form indicates @@ -114,9 +114,9 @@ package Exp_Ch6 is -- expression applied to such a call; otherwise returns False. function Is_Build_In_Place_Function_Return (N : Node_Id) return Boolean; - -- Ada 2005 (AI-318-02): Returns True if N is an N_Return_Statement or - -- N_Extended_Return_Statement and it applies to a build-in-place function - -- or generic function. + -- Ada 2005 (AI-318-02): Returns True if N is an N_Simple_Return_Statement + -- or N_Extended_Return_Statement and it applies to a build-in-place + -- function or generic function. procedure Make_Build_In_Place_Call_In_Allocator (Allocator : Node_Id; diff --git a/gcc/ada/lib-util.adb b/gcc/ada/lib-util.adb index d67b8d0bf7d..36876ffaa2b 100644 --- a/gcc/ada/lib-util.adb +++ b/gcc/ada/lib-util.adb @@ -74,13 +74,19 @@ package body Lib.Util is -- Start of processing for Write_Info_Char_Code begin - if Code in 16#00# .. 16#7F# then + -- 00 .. 7F + + if Code <= 16#7F# then Write_Info_Char (Character'Val (Code)); - elsif Code in 16#80# .. 16#FF# then + -- 80 .. FF + + elsif Code <= 16#FF# then Write_Info_Char ('U'); Write_Info_Hex_Byte (Natural (Code)); + -- 0100 .. FFFF + else Write_Info_Char ('W'); Write_Info_Hex_Byte (Natural (Code / 256)); diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb index ec47ff95f7f..15755a56f84 100644 --- a/gcc/ada/lib-xref.adb +++ b/gcc/ada/lib-xref.adb @@ -223,13 +223,20 @@ package body Lib.Xref is -- Prefix Of an indexed or selected component that is present in a -- subtree rooted by an assignment statement. There is no -- restriction of nesting of components, thus cases such as - -- A.B(C).D are handled properly. + -- A.B (C).D are handled properly. + -- However a prefix of a dereference (either implicit or + -- explicit) is never considered as on a LHS. --------------- -- Is_On_LHS -- --------------- - -- Couldn't we use Is_Lvalue or whatever it is called ??? + -- ??? There are several routines here and there that perform a similar + -- (but subtly different) computation, which should be factored: + + -- Sem_Util.May_Be_Lvalue + -- Sem_Util.Known_To_Be_Assigned + -- Exp_Ch2.Expand_Entry_Parameter.In_Assignment_Context function Is_On_LHS (Node : Node_Id) return Boolean is N : Node_Id := Node; @@ -247,13 +254,28 @@ package body Lib.Xref is while Nkind (Parent (N)) /= N_Assignment_Statement loop - -- Check whether the parent is a component and the - -- current node is its prefix. + -- Check whether the parent is a component and the current node + -- is its prefix, but return False if the current node has an + -- access type, as in that case the selected or indexed component + -- is an implicit dereference, and the LHS is the designated + -- object, not the access object. + + -- ??? case of a slice assignment? + + -- ??? Note that in some cases this is called too early + -- (see comments in Sem_Ch8.Find_Direct_Name), at a point where + -- the tree is not fully typed yet. In that case we may lack + -- an Etype for N, and we must disable the check for an implicit + -- dereference. If the dereference is on an LHS, this causes a + -- false positive. if (Nkind (Parent (N)) = N_Selected_Component or else Nkind (Parent (N)) = N_Indexed_Component) and then Prefix (Parent (N)) = N + and then not (Present (Etype (N)) + and then + Is_Access_Type (Etype (N))) then N := Parent (N); else @@ -370,7 +392,7 @@ package body Lib.Xref is -- a left hand side. We also set the Referenced_As_LHS flag of a -- prefix of selected or indexed component. - if Ekind (E) = E_Variable + if (Ekind (E) = E_Variable or else Is_Formal (E)) and then Is_On_LHS (N) then Set_Referenced_As_LHS (E); @@ -1004,9 +1026,8 @@ package body Lib.Xref is end if; end if; - -- Collect inherited primitive operations that may be - -- declared in another unit and have no visible reference - -- in the current one. + -- Collect inherited primitive operations that may be declared in + -- another unit and have no visible reference in the current one. if Is_Type (Ent) and then Is_Tagged_Type (Ent) diff --git a/gcc/ada/nlists.adb b/gcc/ada/nlists.adb index 8778a9ead0f..0745f388c7f 100644 --- a/gcc/ada/nlists.adb +++ b/gcc/ada/nlists.adb @@ -304,7 +304,7 @@ package body Nlists is if List = No_List then return Empty; else - pragma Assert (List in First_List_Id .. Lists.Last); + pragma Assert (List <= Lists.Last); return Lists.Table (List).First; end if; end First; @@ -630,7 +630,7 @@ package body Nlists is function Last (List : List_Id) return Node_Id is begin - pragma Assert (List in First_List_Id .. Lists.Last); + pragma Assert (List <= Lists.Last); return Lists.Table (List).Last; end Last; @@ -1028,7 +1028,7 @@ package body Nlists is function Parent (List : List_Id) return Node_Id is begin - pragma Assert (List in First_List_Id .. Lists.Last); + pragma Assert (List <= Lists.Last); return Lists.Table (List).Parent; end Parent; @@ -1355,7 +1355,7 @@ package body Nlists is procedure Set_Parent (List : List_Id; Node : Node_Id) is begin - pragma Assert (List in First_List_Id .. Lists.Last); + pragma Assert (List <= Lists.Last); Lists.Table (List).Parent := Node; end Set_Parent; diff --git a/gcc/ada/treepr.adb b/gcc/ada/treepr.adb index 7b1268d8c60..e35ab262f27 100644 --- a/gcc/ada/treepr.adb +++ b/gcc/ada/treepr.adb @@ -796,8 +796,7 @@ package body Treepr is Notes := False; - if N not in - Atree_Private_Part.Nodes.First .. Atree_Private_Part.Nodes.Last then + if N > Atree_Private_Part.Nodes.Last then Print_Str (" (no such node)"); Print_Eol; return; |