diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 61abaee34f9..4c3620f9ced 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2015-10-26 Ed Schonberg + + * sem_disp.adb (Check_Controlling_Type): Handle properly the + case of an incomplete type whose full view is tagged, when a + primitive operation of the type is declared between the two views. + +2015-10-26 Bob Duff + + * adaint.c (__gnat_locate_exec_on_path): If the PATH environment + variable is not set, do not return NULL, because we can still find + the executable if it includes a directory name. + +2015-10-26 Ed Schonberg + + * sem_elab.adb (Elab_Warning): Under dynamic elaboration, when + elaboration warnings are enabled, emit proper warning header + when triggered by an access attribute. + +2015-10-26 Steve Baird + + * exp_ch11.adb: If CodePeer_Mode is true, generate simplified + SCIL for exception declarations. + * exp_ch11.adb (Expand_N_Exception_Declaration) If CodePeer_Mode + is True, initialize the Full_Name component of the exception + record to null instead of to the result of an unchecked + conversion. + +2015-10-26 Ed Schonberg + + * exp_unst.adb (Note_Uplevel_Ref) : Handle properly a reference + that denotes a function returning a constrained array, that has + been rewritten as a procedure. + * makeutl.ads: Minor edit. + 2015-10-26 Yannick Moy * lib-xref-spark_specific.adb (Traverse_Protected_Declaration): New diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 6e18d9433fe..59032470365 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -2787,16 +2787,19 @@ __gnat_locate_exec_on_path (char *exec_name) apath_val = (char *) alloca (EXPAND_BUFFER_SIZE); WS2SC (apath_val, wapath_val, EXPAND_BUFFER_SIZE); - return __gnat_locate_exec (exec_name, apath_val); #else char *path_val = getenv ("PATH"); - if (path_val == NULL) return NULL; + /* If PATH is not defined, proceed with __gnat_locate_exec anyway, so we can + find files that contain directory names. */ + + if (path_val == NULL) path_val = ""; apath_val = (char *) alloca (strlen (path_val) + 1); strcpy (apath_val, path_val); - return __gnat_locate_exec (exec_name, apath_val); #endif + + return __gnat_locate_exec (exec_name, apath_val); } /* Dummy functions for Osint import for non-VMS systems. diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 9580d2dd15f..814dfdd80fd 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -1288,10 +1288,18 @@ package body Exp_Ch11 is -- Full_Name component: Standard.A_Char!(Nam'Address) - Append_To (L, Unchecked_Convert_To (Standard_A_Char, - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Ex_Id, Loc), - Attribute_Name => Name_Address))); + -- The unchecked conversion causes capacity issues for CodePeer in some + -- cases and is never useful, so we set the Full_Name component to null + -- instead for CodePeer. + + if CodePeer_Mode then + Append_To (L, Make_Null (Loc)); + else + Append_To (L, Unchecked_Convert_To (Standard_A_Char, + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Ex_Id, Loc), + Attribute_Name => Name_Address))); + end if; -- HTable_Ptr component: null diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 1bea872aaf7..0b738d1b450 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -466,6 +466,16 @@ package body Exp_Unst is if Caller = Callee then return; + + -- Callee may be a function that returns an array, and + -- that has been rewritten as a procedure. If caller is + -- that procedure, nothing to do either. + + elsif Ekind (Callee) = E_Function + and then Rewritten_For_C (Callee) + and then Next_Entity (Callee) = Caller + then + return; end if; -- We have a new uplevel referenced entity diff --git a/gcc/ada/makeutl.ads b/gcc/ada/makeutl.ads index 185569bca19..c13a151dcb2 100644 --- a/gcc/ada/makeutl.ads +++ b/gcc/ada/makeutl.ads @@ -476,7 +476,7 @@ package Makeutl is function Number_Of_Mains (Tree : Project_Tree_Ref) return Natural; -- Returns the number of mains in this project tree (if Tree is null, it - -- returns the total number of project trees) + -- returns the total number of project trees). procedure Fill_From_Project (Root_Project : Project_Id; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 74a315dd3f2..d2396a37465 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -316,6 +316,18 @@ package body Sem_Disp is Tagged_Type := Base_Type (T); end if; + -- If the type is incomplete, it may have been declared without a + -- Tagged indication, but the full view may be tagged, in which case + -- that is the controlling type of the subprogram. This is one of the + -- approx. 579 places in the language where a lookahead would help. + + elsif Ekind (T) = E_Incomplete_Type + and then Present (Full_View (T)) + and then Is_Tagged_Type (Full_View (T)) + then + Set_Is_Tagged_Type (T); + Tagged_Type := Full_View (T); + elsif Ekind (T) = E_Anonymous_Access_Type and then Is_Tagged_Type (Designated_Type (T)) then @@ -595,14 +607,17 @@ package body Sem_Disp is and then Is_Entity_Name (Name (Par)) then declare + Enc_Subp : constant Entity_Id := Entity (Name (Par)); A : Node_Id; F : Entity_Id; begin - -- Find formal for which call is the actual. + -- Find formal for which call is the actual, and is + -- a controlling argument. - F := First_Formal (Entity (Name (Par))); + F := First_Formal (Enc_Subp); A := First_Actual (Par); + while Present (F) loop if Is_Controlling_Formal (F) and then (N = A or else Parent (N) = A) @@ -697,11 +712,11 @@ package body Sem_Disp is -- If the call doesn't have a controlling actual but does have an -- indeterminate actual that requires dispatching treatment, then an -- object is needed that will serve as the controlling argument for - -- a dispatching call on the indeterminate actual. This can only - -- occur in the unusual situation of a default actual given by - -- a tag-indeterminate call and where the type of the call is an - -- ancestor of the type associated with a containing call to an - -- inherited operation (see AI-239). + -- a dispatching call on the indeterminate actual. This can occur + -- in the unusual situation of a default actual given by a tag- + -- indeterminate call and where the type of the call is an ancestor + -- of the type associated with a containing call to an inherited + -- operation (see AI-239). -- Rather than create an object of the tagged type, which would -- be problematic for various reasons (default initialization, @@ -849,6 +864,7 @@ package body Sem_Disp is end if; else + -- If dispatching on result, the enclosing call, if any, will -- determine the controlling argument. Otherwise this is the -- primitive operation of the root type. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 1f60e2d1609..b206682ab0a 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -548,6 +548,12 @@ package body Sem_Elab is if Msg_D /= "" and then Elab_Warnings then Error_Msg_NE (Msg_D, N, Ent); end if; + + -- In the access case emit first warning message as well, + -- otherwise list of calls will appear as errors. + + elsif Elab_Warnings then + Error_Msg_NE (Msg_S, N, Ent); end if; -- Static elaboration checks, info message