diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 35 | ||||
| -rw-r--r-- | gcc/ada/a-rbtgbk.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 124 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 152 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 12 | ||||
| -rw-r--r-- | gcc/ada/gnatbind.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch8.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 27 |
9 files changed, 281 insertions, 96 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fd13214279d..c2351f9bf2f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,38 @@ +2014-07-17 Vincent Celier <celier@adacore.com> + + * gnatbind.adb: Change in message "try ... for more information". + +2014-07-17 Robert Dewar <dewar@adacore.com> + + * sprint.adb: Code clean up. + +2014-07-17 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch7.adb (Find_Last_Init): Relocate local variables to + the relevant code section. Add new local constant Obj_Id. When + a limited controlled object is initialized by a function call, + the build-in-place object access function call acts as the last + initialization statement. + * exp_util.adb (Is_Object_Access_BIP_Func_Call): New routine. + (Is_Secondary_Stack_BIP_Func_Call): Code reformatting. + * exp_util.ads (Is_Object_Access_BIP_Func_Call): New routine. + +2014-07-17 Ed Schonberg <schonberg@adacore.com> + + * sem_ch8.adb (Analyze_Generic_Renaming): For generic subprograms, + propagate intrinsic flag to renamed entity, to allow e.g. renaming + of Unchecked_Conversion. + * sem_ch3.adb (Analyze_Declarations): Do not analyze contracts + if the declaration has errors. + +2014-07-17 Ed Schonberg <schonberg@adacore.com> + + * a-rbtgbk.adb: a-rbtgbk.adb (Generic_Insert_Post): Check whether + container is busy before checking whether capacity allows for + a further insertion. Insertion in a busy container that is full + raises Program_Error rather than Capacity_Error. Previous to that + patch which exception was raised varied among container types. + 2014-07-17 Robert Dewar <dewar@adacore.com> * g-comlin.ads, g-comlin.adb: Minor clean up. diff --git a/gcc/ada/a-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb index e270abf1402..dba3e0bd095 100644 --- a/gcc/ada/a-rbtgbk.adb +++ b/gcc/ada/a-rbtgbk.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, 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- -- @@ -349,15 +349,15 @@ package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is N : Nodes_Type renames Tree.Nodes; begin - if Tree.Length >= Tree.Capacity then - raise Capacity_Error with "not enough capacity to insert new item"; - end if; - if Tree.Busy > 0 then raise Program_Error with "attempt to tamper with cursors (container is busy)"; end if; + if Tree.Length >= Tree.Capacity then + raise Capacity_Error with "not enough capacity to insert new item"; + end if; + Z := New_Node; pragma Assert (Z /= 0); diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index f48f1149b0e..2f6ae985249 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2256,10 +2256,6 @@ package body Exp_Ch7 is Last_Init : out Node_Id; Body_Insert : out Node_Id) is - Nod_1 : Node_Id := Empty; - Nod_2 : Node_Id := Empty; - Utyp : Entity_Id; - function Is_Init_Call (N : Node_Id; Typ : Entity_Id) return Boolean; @@ -2332,6 +2328,14 @@ package body Exp_Ch7 is return Result; end Next_Suitable_Statement; + -- Local variables + + Obj_Id : constant Entity_Id := Defining_Entity (Decl); + Nod_1 : Node_Id := Empty; + Nod_2 : Node_Id := Empty; + Stmt : Node_Id; + Utyp : Entity_Id; + -- Start of processing for Find_Last_Init begin @@ -2357,6 +2361,42 @@ package body Exp_Ch7 is Utyp := Full_View (Utyp); end if; + -- A limited controlled object initialized by a function call uses + -- the build-in-place machinery to obtain its value. + + -- Obj : Lim_Controlled_Type := Func_Call; + + -- is expanded into + + -- Obj : Lim_Controlled_Type; + -- type Ptr_Typ is access Lim_Controlled_Type; + -- Temp : constant Ptr_Typ := + -- Func_Call + -- (BIPalloc => 1, + -- BIPaccess => Obj'Unrestricted_Access)'reference; + + -- In this scenario the declaration of the temporary acts as the + -- last initialization statement. + + if Is_Limited_Type (Utyp) + and then Has_Init_Expression (Decl) + and then No (Expression (Decl)) + then + Stmt := Next (Decl); + while Present (Stmt) loop + if Nkind (Stmt) = N_Object_Declaration + and then Present (Expression (Stmt)) + and then Is_Object_Access_BIP_Func_Call + (Expr => Expression (Stmt), + Obj_Id => Obj_Id) + then + Last_Init := Stmt; + exit; + end if; + + Next (Stmt); + end loop; + -- The init procedures are arranged as follows: -- Object : Controlled_Type; @@ -2366,53 +2406,55 @@ package body Exp_Ch7 is -- where the user-defined initialize may be optional or may appear -- inside a block when abort deferral is needed. - Nod_1 := Next_Suitable_Statement (Decl); - if Present (Nod_1) then - Nod_2 := Next_Suitable_Statement (Nod_1); + else + Nod_1 := Next_Suitable_Statement (Decl); - -- The statement following an object declaration is always a - -- call to the type init proc. + if Present (Nod_1) then + Nod_2 := Next_Suitable_Statement (Nod_1); - Last_Init := Nod_1; - end if; + -- The statement following an object declaration is always a + -- call to the type init proc. - -- Optional user-defined init or deep init processing + Last_Init := Nod_1; + end if; - if Present (Nod_2) then + -- Optional user-defined init or deep init processing - -- The statement following the type init proc may be a block - -- statement in cases where abort deferral is required. + if Present (Nod_2) then - if Nkind (Nod_2) = N_Block_Statement then - declare - HSS : constant Node_Id := - Handled_Statement_Sequence (Nod_2); - Stmt : Node_Id; + -- The statement following the type init proc may be a block + -- statement in cases where abort deferral is required. - begin - if Present (HSS) - and then Present (Statements (HSS)) - then - Stmt := First (Statements (HSS)); + if Nkind (Nod_2) = N_Block_Statement then + declare + HSS : constant Node_Id := + Handled_Statement_Sequence (Nod_2); + Stmt : Node_Id; - -- Examine individual block statements and locate the - -- call to [Deep_]Initialze. + begin + if Present (HSS) + and then Present (Statements (HSS)) + then + -- Examine individual block statements and locate + -- the call to [Deep_]Initialze. - while Present (Stmt) loop - if Is_Init_Call (Stmt, Utyp) then - Last_Init := Stmt; - Body_Insert := Nod_2; + Stmt := First (Statements (HSS)); + while Present (Stmt) loop + if Is_Init_Call (Stmt, Utyp) then + Last_Init := Stmt; + Body_Insert := Nod_2; - exit; - end if; + exit; + end if; - Next (Stmt); - end loop; - end if; - end; + Next (Stmt); + end loop; + end if; + end; - elsif Is_Init_Call (Nod_2, Utyp) then - Last_Init := Nod_2; + elsif Is_Init_Call (Nod_2, Utyp) then + Last_Init := Nod_2; + end if; end if; end if; end Find_Last_Init; @@ -2434,7 +2476,7 @@ package body Exp_Ch7 is -- Set a new value for the state counter and insert the statement -- after the object declaration. Generate: - -- + -- Counter := <value>; Inc_Decl := @@ -2496,7 +2538,7 @@ package body Exp_Ch7 is Label_Construct => Label)); -- Create the associated jump with this object, generate: - -- + -- when <counter> => -- goto L<counter>; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index acd10734d8b..800c276d536 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -4794,6 +4794,79 @@ package body Exp_Util is and then not Is_Build_In_Place_Function_Call (Prefix (Expr)); end Is_Non_BIP_Func_Call; + ------------------------------------ + -- Is_Object_Access_BIP_Func_Call -- + ------------------------------------ + + function Is_Object_Access_BIP_Func_Call + (Expr : Node_Id; + Obj_Id : Entity_Id) return Boolean + is + Access_Nam : Name_Id := No_Name; + Actual : Node_Id; + Call : Node_Id; + Formal : Node_Id; + Param : Node_Id; + + begin + -- Build-in-place calls usually appear in 'reference format. Note that + -- the accessibility check machinery may add an extra 'reference due to + -- side effect removal. + + Call := Expr; + while Nkind (Call) = N_Reference loop + Call := Prefix (Call); + end loop; + + if Nkind_In (Call, N_Qualified_Expression, + N_Unchecked_Type_Conversion) + then + Call := Expression (Call); + end if; + + if Is_Build_In_Place_Function_Call (Call) then + + -- Examine all parameter associations of the function call + + Param := First (Parameter_Associations (Call)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association + and then Nkind (Selector_Name (Param)) = N_Identifier + then + Formal := Selector_Name (Param); + Actual := Explicit_Actual_Parameter (Param); + + -- Construct the name of formal BIPaccess. It is much easier to + -- extract the name of the function using an arbitrary formal's + -- scope rather than the Name field of Call. + + if Access_Nam = No_Name and then Present (Entity (Formal)) then + Access_Nam := + New_External_Name + (Chars (Scope (Entity (Formal))), + BIP_Formal_Suffix (BIP_Object_Access)); + end if; + + -- A match for BIPaccess => Obj_Id'Unrestricted_Access has been + -- found. + + if Chars (Formal) = Access_Nam + and then Nkind (Actual) = N_Attribute_Reference + and then Attribute_Name (Actual) = Name_Unrestricted_Access + and then Nkind (Prefix (Actual)) = N_Identifier + and then Entity (Prefix (Actual)) = Obj_Id + then + return True; + end if; + end if; + + Next (Param); + end loop; + end if; + + return False; + end Is_Object_Access_BIP_Func_Call; + ---------------------------------- -- Is_Possibly_Unaligned_Object -- ---------------------------------- @@ -5183,7 +5256,11 @@ package body Exp_Util is -------------------------------------- function Is_Secondary_Stack_BIP_Func_Call (Expr : Node_Id) return Boolean is - Call : Node_Id := Expr; + Alloc_Nam : Name_Id := No_Name; + Actual : Node_Id; + Call : Node_Id := Expr; + Formal : Node_Id; + Param : Node_Id; begin -- Build-in-place calls usually appear in 'reference format. Note that @@ -5201,49 +5278,40 @@ package body Exp_Util is end if; if Is_Build_In_Place_Function_Call (Call) then - declare - Access_Nam : Name_Id := No_Name; - Actual : Node_Id; - Param : Node_Id; - Formal : Node_Id; - - begin - -- Examine all parameter associations of the function call - - Param := First (Parameter_Associations (Call)); - while Present (Param) loop - if Nkind (Param) = N_Parameter_Association - and then Nkind (Selector_Name (Param)) = N_Identifier - then - Formal := Selector_Name (Param); - Actual := Explicit_Actual_Parameter (Param); - -- Construct the name of formal BIPalloc. It is much easier - -- to extract the name of the function using an arbitrary - -- formal's scope rather than the Name field of Call. + -- Examine all parameter associations of the function call - if Access_Nam = No_Name - and then Present (Entity (Formal)) - then - Access_Nam := - New_External_Name - (Chars (Scope (Entity (Formal))), - BIP_Formal_Suffix (BIP_Alloc_Form)); - end if; + Param := First (Parameter_Associations (Call)); + while Present (Param) loop + if Nkind (Param) = N_Parameter_Association + and then Nkind (Selector_Name (Param)) = N_Identifier + then + Formal := Selector_Name (Param); + Actual := Explicit_Actual_Parameter (Param); + + -- Construct the name of formal BIPalloc. It is much easier to + -- extract the name of the function using an arbitrary formal's + -- scope rather than the Name field of Call. + + if Alloc_Nam = No_Name and then Present (Entity (Formal)) then + Alloc_Nam := + New_External_Name + (Chars (Scope (Entity (Formal))), + BIP_Formal_Suffix (BIP_Alloc_Form)); + end if; - -- A match for BIPalloc => 2 has been found + -- A match for BIPalloc => 2 has been found - if Chars (Formal) = Access_Nam - and then Nkind (Actual) = N_Integer_Literal - and then Intval (Actual) = Uint_2 - then - return True; - end if; + if Chars (Formal) = Alloc_Nam + and then Nkind (Actual) = N_Integer_Literal + and then Intval (Actual) = Uint_2 + then + return True; end if; + end if; - Next (Param); - end loop; - end; + Next (Param); + end loop; end if; return False; @@ -5274,10 +5342,10 @@ package body Exp_Util is begin return (not Is_Tagged_Type (T) and then Is_Derived_Type (T)) or else - (Is_Private_Type (T) and then Present (Full_View (T)) - and then not Is_Tagged_Type (Full_View (T)) - and then Is_Derived_Type (Full_View (T)) - and then Etype (Full_View (T)) /= T); + (Is_Private_Type (T) and then Present (Full_View (T)) + and then not Is_Tagged_Type (Full_View (T)) + and then Is_Derived_Type (Full_View (T)) + and then Etype (Full_View (T)) /= T); end Is_Untagged_Derivation; --------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 54e051b447b..2f316ddb8d1 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -127,6 +127,12 @@ package Exp_Util is -- Assoc_Node must be a node in a list. Same as Insert_Action but the -- action will be inserted after N in a manner that is compatible with -- the transient scope mechanism. + -- + -- Note: If several successive calls to Insert_Action_After are made for + -- the same node, they will each in turn be inserted just after the node. + -- This means they will end up being executed in reverse order. Use the + -- call to Insert_Actions_After to insert a list of actions to be executed + -- in the sequence in which they are given in the list. procedure Insert_Actions_After (Assoc_Node : Node_Id; @@ -575,6 +581,12 @@ package Exp_Util is function Is_Non_BIP_Func_Call (Expr : Node_Id) return Boolean; -- Determine whether node Expr denotes a non build-in-place function call + function Is_Object_Access_BIP_Func_Call + (Expr : Node_Id; + Obj_Id : Entity_Id) return Boolean; + -- Determine if Expr denotes a build-in-place function which stores its + -- result in the BIPaccess actual parameter whose prefix must match Obj_Id. + function Is_Possibly_Unaligned_Object (N : Node_Id) return Boolean; -- Node N is an object reference. This function returns True if it is -- possible that the object may not be aligned according to the normal diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 82da0655c4c..6383e818b14 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -672,7 +672,7 @@ begin if Argument_Count = 0 then Bindusg.Display; else - Write_Line ("try `gnatbind --help` for more information."); + Write_Line ("try ""gnatbind --help"" for more information."); end if; Exit_Program (E_Fatal); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 1a02abf2ffc..b6023637575 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2366,11 +2366,14 @@ package body Sem_Ch3 is -- Analyze the contracts of subprogram declarations, subprogram bodies -- and variables now due to the delayed visibility requirements of their - -- aspects. + -- aspects. Skip analysis if the declaration already has an error. Decl := First (L); while Present (Decl) loop - if Nkind (Decl) = N_Object_Declaration then + if Error_Posted (Decl) then + null; + + elsif Nkind (Decl) = N_Object_Declaration then Analyze_Object_Contract (Defining_Entity (Decl)); elsif Nkind_In (Decl, N_Abstract_Subprogram_Declaration, diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 7598d5c9eea..2bc1ea03e07 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -706,6 +706,14 @@ package body Sem_Ch8 is Error_Msg_N ("within its scope, generic denotes its instance", N); end if; + -- For subprograms, propagate the Intrinsic flag, to allow, e.g. + -- renamings and subsequent instantiations of Unchecked_Conversion. + + if Ekind_In (Old_P, E_Generic_Function, E_Generic_Procedure) then + Set_Is_Intrinsic_Subprogram + (New_P, Is_Intrinsic_Subprogram (Old_P)); + end if; + Check_Library_Unit_Renaming (N, Old_P); end if; diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index f2ad1ec6f45..9a55e8cc65a 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -2249,13 +2249,30 @@ package body Sprint is -- Print type, we used to print the Object_Definition from -- the node, but it is much more useful to print the Etype - -- of the defining identifier. For example, this will be a - -- clear reference to the Itype with the bounds in the case - -- of an unconstrained array type like String. The object - -- after all is constrained, even if its nominal subtype is + -- of the defining identifier for the case where the nominal + -- type is an unconstrained array type. For example, this + -- will be a clear reference to the Itype with the bounds + -- in the case of a type like String. The object after + -- all is constrained, even if its nominal subtype is -- unconstrained. - Sprint_Node (Etype (Def_Id)); + declare + Odef : constant Node_Id := Object_Definition (Node); + + begin + if Nkind (Odef) = N_Identifier + and then Is_Array_Type (Etype (Odef)) + and then not Is_Constrained (Etype (Odef)) + and then Present (Etype (Def_Id)) + then + Sprint_Node (Etype (Def_Id)); + + -- In other cases, the nominal type is fine to print + + else + Sprint_Node (Odef); + end if; + end; if Present (Expression (Node)) then Write_Str (" := "); |