diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1fa08b96111..eb9d2fde025 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,59 @@ +2015-11-13 Eric Botcazou + + * sigtramp-ios.c, init.c: Minor cosmetic tweaks. + +2015-11-13 Hristian Kirtchev + + * s-gloloc.adb, g-debpoo.adb: Minor reformatting. + +2015-11-13 Ed Schonberg + + * sem_ch5.adb (Analyze_Iterator_Specification): Improve error + message for the case the iterable name (array or container) + is a component that depends on a discriminant. + +2015-11-13 Ed Schonberg + + * sem_ch4.adb (Indicate_Name_And_Type): If the analysis of + one interpretation succeeds, set type of name in call, for + completeness. + (Try_Container_Indexing): If there are multiple indexing + functions, collect possible interpretations that are compatible + with given parameters, and add implicit dereference types when + present. + * sem_util.adb (Build_Explicit_Dereference): If the expression + is an overloaded function call use the given discriminant to + resolve the call, and set properly the type of the call and of + the resulting dereference. + +2015-11-13 Hristian Kirtchev + + * sem_prag.adb (Analyze_Pragma): Pragma Constant_After_Elaboration can + now apply to a variable without an initialization expression. + +2015-11-13 Hristian Kirtchev + + * exp_ch9.adb (Add_Matching_Formals): Parameter Actuals is now of mode + IN OUT. Create a new list when list Actuals is not present. + (Build_Contract_Wrapper): Create the wrapper + only when the entry has at least on checked contract case or + pre/postcondition. Ensure that the call to the original entry + lacks an actual parameter list when the entry appears without + formal parameters. + (Expand_Entry_Declaration): Code cleanup. + +2015-11-13 Hristian Kirtchev + + * sem_ch13.adb (Analyze_Aspect_Specifications): Continue the analysis + after encountering an illegal aspect Part_Of. + +2015-11-13 Ed Schonberg + + * exp_attr.adb (Expand_N_Attribute_Reference, case + Overlaps_Storage): Add copies for nodes that represent the integer + addresses of the two actuals, to prevent identical nodes in the + tree, which the backend cannot handle properly. + 2015-11-13 Bob Duff * sem_ch6.adb (Check_Private_Overriding): Change diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index d40f49de51c..50176e7de64 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -4462,7 +4462,7 @@ package body Exp_Attr is X : constant Node_Id := Prefix (N); Y : constant Node_Id := First (Expressions (N)); - -- The argumens + -- The arguments X_Addr, Y_Addr : Node_Id; -- the expressions for their integer addresses @@ -4483,7 +4483,9 @@ package body Exp_Attr is -- with the proper address operations. We convert addresses to -- integer addresses to use predefined arithmetic. The size is - -- expressed in storage units. + -- expressed in storage units. We add copies of X_Addr and Y_Addr + -- to prevent the appearance of the same node in two places in + -- the tree. X_Addr := Unchecked_Convert_To (RTE (RE_Integer_Address), @@ -4528,7 +4530,7 @@ package body Exp_Attr is Make_Op_Ge (Loc, Left_Opnd => Make_Op_Add (Loc, - Left_Opnd => X_Addr, + Left_Opnd => New_Copy_Tree (X_Addr), Right_Opnd => Make_Op_Subtract (Loc, Left_Opnd => X_Size, @@ -4537,7 +4539,7 @@ package body Exp_Attr is Make_Op_Ge (Loc, Make_Op_Add (Loc, - Left_Opnd => Y_Addr, + Left_Opnd => New_Copy_Tree (Y_Addr), Right_Opnd => Make_Op_Subtract (Loc, Left_Opnd => Y_Size, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 80057627936..bd9a2af9551 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -1234,7 +1234,9 @@ package body Exp_Ch9 is -- Conc_Typ. Obj_Id is the entity of the wrapper formal parameter which -- represents the concurrent object. - procedure Add_Matching_Formals (Formals : List_Id; Actuals : List_Id); + procedure Add_Matching_Formals + (Formals : List_Id; + Actuals : in out List_Id); -- Add formal parameters that match those of entry E to list Formals. -- The routine also adds matching actuals for the new formals to list -- Actuals. @@ -1281,7 +1283,10 @@ package body Exp_Ch9 is -- Add_Matching_Formals -- -------------------------- - procedure Add_Matching_Formals (Formals : List_Id; Actuals : List_Id) is + procedure Add_Matching_Formals + (Formals : List_Id; + Actuals : in out List_Id) + is Formal : Entity_Id; New_Formal : Entity_Id; @@ -1301,6 +1306,10 @@ package body Exp_Ch9 is Parameter_Type => New_Occurrence_Of (Etype (Formal), Loc))); + if No (Actuals) then + Actuals := New_List; + end if; + Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); Next_Formal (Formal); end loop; @@ -1327,7 +1336,7 @@ package body Exp_Ch9 is -- Local variables Items : constant Node_Id := Contract (E); - Actuals : List_Id; + Actuals : List_Id := No_List; Call : Node_Id; Call_Nam : Node_Id; Decls : List_Id := No_List; @@ -1384,6 +1393,7 @@ package body Exp_Ch9 is while Present (Prag) loop if Nam_In (Pragma_Name (Prag), Name_Postcondition, Name_Precondition) + and then Is_Checked (Prag) then Has_Pragma := True; Transfer_Pragma (Prag, To => Decls); @@ -1397,7 +1407,9 @@ package body Exp_Ch9 is Prag := Contract_Test_Cases (Items); while Present (Prag) loop - if Pragma_Name (Prag) = Name_Contract_Cases then + if Pragma_Name (Prag) = Name_Contract_Cases + and then Is_Checked (Prag) + then Has_Pragma := True; Transfer_Pragma (Prag, To => Decls); end if; @@ -1455,17 +1467,16 @@ package body Exp_Ch9 is Expressions => New_List (New_Occurrence_Of (Index_Id, Loc))); end if; - Actuals := New_List; - Call := - Make_Procedure_Call_Statement (Loc, - Name => Call_Nam, - Parameter_Associations => Actuals); - -- Add formal parameters to match those of the entry and build actuals -- for the entry call. Add_Matching_Formals (Formals, Actuals); + Call := + Make_Procedure_Call_Statement (Loc, + Name => Call_Nam, + Parameter_Associations => Actuals); + -- Add renaming declarations for the discriminants of the enclosing type -- as the various contract items may reference them. @@ -9030,7 +9041,6 @@ package body Exp_Ch9 is Body_Id : Entity_Id; Cdecls : List_Id; Comp : Node_Id; - Comp_Id : Entity_Id; Current_Node : Node_Id := N; E_Count : Int; Entries_Aggr : Node_Id; @@ -9038,7 +9048,6 @@ package body Exp_Ch9 is Object_Comp : Node_Id; Priv : Node_Id; Rec_Decl : Node_Id; - Sub : Node_Id; procedure Check_Inlining (Subp : Entity_Id); -- If the original operation has a pragma Inline, propagate the flag @@ -9051,9 +9060,9 @@ package body Exp_Ch9 is -- static because of a discriminant constraint we can specialize the -- warning by mentioning discriminants explicitly. - procedure Expand_Entry_Declaration (Comp : Entity_Id); - -- Create the subprograms for the barrier and for the body, and append - -- then to Entry_Bodies_Array. + procedure Expand_Entry_Declaration (Decl : Node_Id); + -- Create the entry barrier and the procedure body for entry declaration + -- Decl. All generated subprograms are added to Entry_Bodies_Array. function Static_Component_Size (Comp : Entity_Id) return Boolean; -- When compiling under the Ravenscar profile, private components must @@ -9173,51 +9182,57 @@ package body Exp_Ch9 is -- Expand_Entry_Declaration -- ------------------------------ - procedure Expand_Entry_Declaration (Comp : Entity_Id) is - Bdef : Entity_Id; - Edef : Entity_Id; + procedure Expand_Entry_Declaration (Decl : Node_Id) is + Ent_Id : constant Entity_Id := Defining_Entity (Decl); + Bar_Id : Entity_Id; + Bod_Id : Entity_Id; + Subp : Node_Id; begin E_Count := E_Count + 1; - Comp_Id := Defining_Identifier (Comp); - Edef := + -- Create the protected body subprogram + + Bod_Id := Make_Defining_Identifier (Loc, - Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'E')); - Sub := + Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'E')); + Set_Protected_Body_Subprogram (Ent_Id, Bod_Id); + + Subp := Make_Subprogram_Declaration (Loc, Specification => - Build_Protected_Entry_Specification (Loc, Edef, Comp_Id)); + Build_Protected_Entry_Specification (Loc, Bod_Id, Ent_Id)); - Insert_After (Current_Node, Sub); - Analyze (Sub); + Insert_After (Current_Node, Subp); + Current_Node := Subp; + + Analyze (Subp); -- Build a wrapper procedure to handle contract cases, preconditions, -- and postconditions. - Build_Contract_Wrapper (Comp_Id, N); + Build_Contract_Wrapper (Ent_Id, N); - Set_Protected_Body_Subprogram - (Defining_Identifier (Comp), - Defining_Unit_Name (Specification (Sub))); + -- Create the barrier function - Current_Node := Sub; - - Bdef := + Bar_Id := Make_Defining_Identifier (Loc, - Chars => Build_Selected_Name (Prot_Typ, Comp_Id, 'B')); - Sub := + Chars => Build_Selected_Name (Prot_Typ, Ent_Id, 'B')); + Set_Barrier_Function (Ent_Id, Bar_Id); + + Subp := Make_Subprogram_Declaration (Loc, Specification => - Build_Barrier_Function_Specification (Loc, Bdef)); - Set_Is_Entry_Barrier_Function (Sub); + Build_Barrier_Function_Specification (Loc, Bar_Id)); + Set_Is_Entry_Barrier_Function (Subp); - Insert_After (Current_Node, Sub); - Analyze (Sub); - Set_Protected_Body_Subprogram (Bdef, Bdef); - Set_Barrier_Function (Comp_Id, Bdef); - Set_Scope (Bdef, Scope (Comp_Id)); - Current_Node := Sub; + Insert_After (Current_Node, Subp); + Current_Node := Subp; + + Analyze (Subp); + + Set_Protected_Body_Subprogram (Bar_Id, Bar_Id); + Set_Scope (Bar_Id, Scope (Ent_Id)); -- Collect pointers to the protected subprogram and the barrier -- of the current entry, for insertion into Entry_Bodies_Array. @@ -9226,10 +9241,10 @@ package body Exp_Ch9 is Make_Aggregate (Loc, Expressions => New_List ( Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Bdef, Loc), + Prefix => New_Occurrence_Of (Bar_Id, Loc), Attribute_Name => Name_Unrestricted_Access), Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Edef, Loc), + Prefix => New_Occurrence_Of (Bod_Id, Loc), Attribute_Name => Name_Unrestricted_Access)))); end Expand_Entry_Declaration; @@ -9260,6 +9275,10 @@ package body Exp_Ch9 is Append_Freeze_Action (Prot_Proc, RTS_Call); end Register_Handler; + -- Local variables + + Sub : Node_Id; + -- Start of processing for Expand_N_Protected_Type_Declaration begin diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb index 8ed8d0e277b..c5664a9939d 100644 --- a/gcc/ada/g-debpoo.adb +++ b/gcc/ada/g-debpoo.adb @@ -482,6 +482,7 @@ package body GNAT.Debug_Pools is -- Warning: secondary stack cannot be used here. When System.Memory -- implementation uses Debug_Pool, Print_Address can be called during -- secondary stack creation for foreign threads. + Put (File, Image_C (Addr)); end Print_Address; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 4e95614a2f5..4f7341e4e79 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -324,9 +324,7 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) propagation after the required low level adjustments. */ static void -__gnat_error_handler (int sig, - siginfo_t *si ATTRIBUTE_UNUSED, - void *ucontext ATTRIBUTE_UNUSED) +__gnat_error_handler (int sig, siginfo_t *si ATTRIBUTE_UNUSED, void *ucontext) { struct Exception_Data *exception; const char *msg; @@ -683,7 +681,7 @@ __gnat_error_handler (int sig) } void -__gnat_install_handler(void) +__gnat_install_handler (void) { struct sigaction act; @@ -1930,10 +1928,9 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *sc ATTRIBUTE_UNUSED) { /* In case of ARM exceptions, the registers context have the PC pointing - to the instruction that raised the signal. However the Unwinder expects - the instruction to be in the range ]PC,PC+1]. - */ - uintptr_t *pc_addr; /* address of the pc value to restore */ + to the instruction that raised the signal. However the unwinder expects + the instruction to be in the range ]PC,PC+1]. */ + uintptr_t *pc_addr; #ifdef __RTP__ mcontext_t *mcontext = &((ucontext_t *) sc)->uc_mcontext; pc_addr = (uintptr_t*)&mcontext->regs.pc; @@ -1997,7 +1994,7 @@ __gnat_error_handler (int sig, siginfo_t *si, void *sc) __gnat_adjust_context_for_raise (sig, sc); #endif - #include "sigtramp.h" +#include "sigtramp.h" __gnat_sigtramp (sig, (void *)si, (void *)sc, (__sigtramphandler_t *)&__gnat_map_signal); @@ -2189,7 +2186,7 @@ __gnat_error_handler (int sig) } void -__gnat_install_handler(void) +__gnat_install_handler (void) { struct sigaction act; @@ -2252,7 +2249,7 @@ __gnat_error_handler (int sig) } void -__gnat_install_handler(void) +__gnat_install_handler (void) { struct sigaction act; @@ -2443,8 +2440,8 @@ __gnat_error_handler (int sig, siginfo_t *si, void *ucontext) { __gnat_adjust_context_for_raise (sig, ucontext); + /* The Darwin libc comes with a signal trampoline, except for ARM64. */ #ifdef __arm64__ - /* Use a trampoline so that the unwinder won't see the signal frame. */ __gnat_sigtramp (sig, (void *)si, ucontext, (__sigtramphandler_t *)&__gnat_map_signal); #else @@ -2515,7 +2512,7 @@ __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext) static void __gnat_map_signal (int sig, siginfo_t *si ATTRIBUTE_UNUSED, - void *ucontext ATTRIBUTE_UNUSED) + void *mcontext ATTRIBUTE_UNUSED) { struct Exception_Data *exception; const char *msg; @@ -2546,9 +2543,7 @@ __gnat_map_signal (int sig, } static void -__gnat_error_handler (int sig, - siginfo_t *si ATTRIBUTE_UNUSED, - void *ucontext ATTRIBUTE_UNUSED) +__gnat_error_handler (int sig, siginfo_t *si, void *ucontext) { __gnat_adjust_context_for_raise (sig, ucontext); diff --git a/gcc/ada/s-gloloc.adb b/gcc/ada/s-gloloc.adb index 331e67ffb10..6dfc5277a7b 100644 --- a/gcc/ada/s-gloloc.adb +++ b/gcc/ada/s-gloloc.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2015, 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- -- @@ -51,7 +51,7 @@ package body System.Global_Locks is File : String; Wait : Duration := 0.1; Retries : Natural := Natural'Last); - -- Create a lock file File in directory Dir. If the file cannot be + -- Create a lock file File in directory Dir. If the file cannot be -- locked because someone already owns the lock, this procedure -- waits Wait seconds and retries at most Retries times. If the file -- still cannot be locked, Lock_Error is raised. The default is to try diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 80c5a067474..56b81b43dae 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2673,7 +2673,6 @@ package body Sem_Ch13 is Decorate (Aspect, Aitem); Insert_Pragma (Aitem); - goto Continue; else Error_Msg_NE @@ -2682,6 +2681,8 @@ package body Sem_Ch13 is Aspect, Id); end if; + goto Continue; + -- SPARK_Mode when Aspect_SPARK_Mode => diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 999a78bd36a..68988d3c3b2 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -3073,6 +3073,7 @@ package body Sem_Ch4 is if not Is_Type (Nam) then if Is_Entity_Name (Name (N)) then Set_Entity (Name (N), Nam); + Set_Etype (Name (N), Etype (Nam)); elsif Nkind (Name (N)) = N_Selected_Component then Set_Entity (Selector_Name (Name (N)), Nam); @@ -7456,6 +7457,9 @@ package body Sem_Ch4 is end if; else + -- If there are multiple indexing functions, build a function call + -- and analyze it for each of the possible interpretations. + Indexing := Make_Function_Call (Loc, Name => @@ -7464,6 +7468,8 @@ package body Sem_Ch4 is Set_Parent (Indexing, Parent (N)); Set_Generalized_Indexing (N, Indexing); + Set_Etype (N, Any_Type); + Set_Etype (Name (Indexing), Any_Type); declare I : Interp_Index; @@ -7473,21 +7479,24 @@ package body Sem_Ch4 is begin Get_First_Interp (Func_Name, I, It); Set_Etype (Indexing, Any_Type); + while Present (It.Nam) loop Analyze_One_Call (Indexing, It.Nam, False, Success); if Success then - Set_Etype (Name (Indexing), It.Typ); - Set_Entity (Name (Indexing), It.Nam); - Set_Etype (N, Etype (Indexing)); - -- Add implicit dereference interpretation + -- Function in current interpretation is a valid candidate. + -- Its result type is also a potential type for the + -- original Indexed_Component node. + + Add_One_Interp (Name (Indexing), It.Nam, It.Typ); + Add_One_Interp (N, It.Nam, It.Typ); + + -- Add implicit dereference interpretation to original node if Has_Discriminants (Etype (It.Nam)) then Check_Implicit_Dereference (N, Etype (It.Nam)); end if; - - exit; end if; Get_Next_Interp (I, It); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 418ff13edbb..519aab41503 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -2057,19 +2057,20 @@ package body Sem_Ch5 is Set_Is_Aliased (Def_Id, Has_Aliased_Components (Typ)); - -- AI12-0151 stipulates that the container cannot be a component - -- that depends on a discriminant if the enclosing object is - -- mutable, to prevent a modification of the container in the - -- course of an iteration. + -- AI12-0047 stipulates that the domain (array or container) + -- cannot be a component that depends on a discriminant if the + -- enclosing object is mutable, to prevent a modification of the + -- dowmain of iteration in the course of an iteration. - -- Should comment on need to go to Original_Node ??? + -- If the object is an expression it has been captured in a + -- temporary, so examine original node. if Nkind (Original_Node (Iter_Name)) = N_Selected_Component and then Is_Dependent_Component_Of_Mutable_Object (Original_Node (Iter_Name)) then Error_Msg_N - ("container cannot be a discriminant-dependent " + ("iterable name cannot be a discriminant-dependent " & "component of a mutable object", N); end if; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 9a67e260052..d2df5d6a0ce 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -12604,22 +12604,15 @@ package body Sem_Prag is Obj_Id := Defining_Entity (Obj_Decl); - -- The object declaration must be a library-level variable with - -- an initialization expression. The expression must depend on - -- a variable, parameter, or another constant_after_elaboration, - -- but the compiler cannot detect this property, as this requires - -- full flow analysis (SPARK RM 3.3.1). + -- The object declaration must be a library-level variable which + -- is either explicitly initialized or obtains a value during the + -- elaboration of a package body (SPARK RM 3.3.1). if Ekind (Obj_Id) = E_Variable then if not Is_Library_Level_Entity (Obj_Id) then Error_Pragma ("pragma % must apply to a library level variable"); return; - - elsif not Has_Init_Expression (Obj_Decl) then - Error_Pragma - ("pragma % must apply to a variable with initialization " - & "expression"); end if; -- Otherwise the pragma applies to a constant, which is illegal diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 36dfc4df22f..712d03d258d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1732,6 +1732,8 @@ package body Sem_Util is Disc : Entity_Id) is Loc : constant Source_Ptr := Sloc (Expr); + I : Interp_Index; + It : Interp; begin -- An entity of a type with a reference aspect is overloaded with @@ -1744,6 +1746,29 @@ package body Sem_Util is Set_Etype (Expr, Etype (Entity (Expr))); elsif Nkind (Expr) = N_Function_Call then + + -- If the name of the indexing function is overloaded, locate the one + -- whose return type has an implicit dereference on the desired + -- discriminant, and set entity and type of function call. + + if Is_Overloaded (Name (Expr)) then + Get_First_Interp (Name (Expr), I, It); + + while Present (It.Nam) loop + if Ekind ((It.Typ)) = E_Record_Type + and then First_Entity ((It.Typ)) = Disc + then + Set_Entity (Name (Expr), It.Nam); + Set_Etype (Name (Expr), Etype (It.Nam)); + exit; + end if; + + Get_Next_Interp (I, It); + end loop; + end if; + + -- Set type of call from resolved function name. + Set_Etype (Expr, Etype (Name (Expr))); end if; diff --git a/gcc/ada/sigtramp-ios.c b/gcc/ada/sigtramp-ios.c index 36c4f871791..03e798df6a5 100644 --- a/gcc/ada/sigtramp-ios.c +++ b/gcc/ada/sigtramp-ios.c @@ -178,7 +178,7 @@ void __gnat_sigtramp (int signo, void *si, void *ucontext, TCR(COMMON_LONG128_CFI(GR(27))) \ TCR(COMMON_LONG128_CFI(GR(28))) \ TCR(COMMON_LONG128_CFI(GR(29))) \ - TCR(COMMON_LONG256_CFI(PC)) \ + TCR(COMMON_LONG256_CFI(PC)) /* Trampoline body block --------------------- */