From e1f3cb584d01e98206cea8feeb094ca025534ff7 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 24 Jun 2009 12:11:52 +0200 Subject: [multiple changes] 2009-06-24 Robert Dewar * prj-nmsc.adb, prj-nmsc.ads, prj-proc.adb, prj.adb: Minor reformatting * a-strsea.adb (Count): Avoid local copy on stack, speed up unmapped case. (Index): Ditto. 2009-06-24 Ed Schonberg * sem_ch4.adb (Analyze_One_Call): Check that at least one actual is present when checking whether a call may be interpreted as an indexing of the result of a call. * exp_ch9.adb (Expand_N_Subprogram_Declaration): Place the generated body for a null procedure on the freeze actions for the procedure, so that it will be analyzed at the proper place without premature freezing of actuals. * sem_ch3.adb (Check_Completion): Code cleanup. Do not diagnose a null procedure without a body, if previous errors have disabled expansion. 2009-06-24 Doug Rupp * init.c [VMS] Resignal C$_SIGKILL 2009-06-24 Ed Falis * s-vxwext.adb, s-vxwext-kernel.adb: Add s-vxwext body for VxWorks 5 Define ERROR in body for VxWorks 6 kernel 2009-06-24 Pascal Obry * g-socket.adb, g-socket.ads: Fix possible unexpected constraint error in [Send/Receive]_Socket. From-SVN: r148905 --- gcc/ada/ChangeLog | 37 ++++++ gcc/ada/a-strsea.adb | 269 +++++++++++++++++++++++++++++--------------- gcc/ada/exp_ch6.adb | 40 +++---- gcc/ada/g-socket.adb | 20 +++- gcc/ada/g-socket.ads | 22 ++-- gcc/ada/init.c | 2 + gcc/ada/prj-nmsc.adb | 145 ++++++++++++------------ gcc/ada/prj-nmsc.ads | 15 +-- gcc/ada/prj-proc.adb | 28 ++--- gcc/ada/prj.adb | 62 +++++++--- gcc/ada/s-vxwext-kernel.adb | 2 + gcc/ada/s-vxwext.adb | 50 ++++++++ gcc/ada/sem_ch3.adb | 36 ++++-- gcc/ada/sem_ch4.adb | 4 +- 14 files changed, 490 insertions(+), 242 deletions(-) create mode 100644 gcc/ada/s-vxwext.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a1c4d33..5d58ca3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,40 @@ +2009-06-24 Robert Dewar + + * prj-nmsc.adb, prj-nmsc.ads, prj-proc.adb, prj.adb: Minor reformatting + + * a-strsea.adb (Count): Avoid local copy on stack, speed up unmapped + case. + (Index): Ditto. + +2009-06-24 Ed Schonberg + + * sem_ch4.adb (Analyze_One_Call): Check that at least one actual is + present when checking whether a call may be interpreted as an indexing + of the result of a call. + + * exp_ch9.adb (Expand_N_Subprogram_Declaration): Place the generated + body for a null procedure on the freeze actions for the procedure, so + that it will be analyzed at the proper place without premature freezing + of actuals. + + * sem_ch3.adb (Check_Completion): Code cleanup. + Do not diagnose a null procedure without a body, if previous errors + have disabled expansion. + +2009-06-24 Doug Rupp + + * init.c [VMS] Resignal C$_SIGKILL + +2009-06-24 Ed Falis + + * s-vxwext.adb, s-vxwext-kernel.adb: Add s-vxwext body for VxWorks 5 + Define ERROR in body for VxWorks 6 kernel + +2009-06-24 Pascal Obry + + * g-socket.adb, g-socket.ads: Fix possible unexpected constraint error + in [Send/Receive]_Socket. + 2009-06-24 Emmanuel Briot * prj-proc.adb, prj-proc.ads, prj.ads, prj-nmsc.adb, prj-nmsc.ads, diff --git a/gcc/ada/a-strsea.adb b/gcc/ada/a-strsea.adb index b613895..1994745 100644 --- a/gcc/ada/a-strsea.adb +++ b/gcc/ada/a-strsea.adb @@ -36,6 +36,7 @@ -- is specialized (rather than using the general Index routine). with Ada.Strings.Maps; use Ada.Strings.Maps; +with System; use System; package body Ada.Strings.Search is @@ -77,33 +78,58 @@ package body Ada.Strings.Search is Pattern : String; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is - N : Natural; - J : Natural; - - Mapped_Source : String (Source'Range); + PL1 : constant Integer := Pattern'Length - 1; + Num : Natural; + Ind : Natural; + Cur : Natural; begin - for J in Source'Range loop - Mapped_Source (J) := Value (Mapping, Source (J)); - end loop; - if Pattern = "" then raise Pattern_Error; end if; - N := 0; - J := Source'First; + Num := 0; + Ind := Source'First; - while J <= Source'Last - (Pattern'Length - 1) loop - if Mapped_Source (J .. J + (Pattern'Length - 1)) = Pattern then - N := N + 1; - J := J + Pattern'Length; - else - J := J + 1; - end if; - end loop; + -- Unmapped case - return N; + if Mapping'Address = Maps.Identity'Address then + Ind := Source'First; + while Ind <= Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + Num := Num + 1; + Ind := Ind + Pattern'Length; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped case + + else + Ind := Source'First; + while Ind <= Source'Length - PL1 loop + Cur := Ind; + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + Ind := Ind + 1; + goto Cont; + else + Cur := Cur + 1; + end if; + end loop; + + Num := Num + 1; + Ind := Ind + Pattern'Length; + + <> + null; + end loop; + end if; + + -- Return result + + return Num; end Count; function Count @@ -111,41 +137,43 @@ package body Ada.Strings.Search is Pattern : String; Mapping : Maps.Character_Mapping_Function) return Natural is - Mapped_Source : String (Source'Range); - N : Natural; - J : Natural; + PL1 : constant Integer := Pattern'Length - 1; + Num : Natural; + Ind : Natural; + Cur : Natural; begin if Pattern = "" then raise Pattern_Error; end if; - -- We make sure Access_Check is unsuppressed so that the Mapping.all - -- call will generate a friendly Constraint_Error if the value for - -- Mapping is uninitialized (and hence null). + -- Check for null pointer in case checks are off - declare - pragma Unsuppress (Access_Check); + if Mapping = null then + raise Constraint_Error; + end if; - begin - for J in Source'Range loop - Mapped_Source (J) := Mapping.all (Source (J)); + Num := 0; + Ind := Source'First; + while Ind <= Source'Last - PL1 loop + Cur := Ind; + for K in Pattern'Range loop + if Pattern (K) /= Mapping (Source (Cur)) then + Ind := Ind + 1; + goto Cont; + else + Cur := Cur + 1; + end if; end loop; - end; - N := 0; - J := Source'First; + Num := Num + 1; + Ind := Ind + Pattern'Length; - while J <= Source'Last - (Pattern'Length - 1) loop - if Mapped_Source (J .. J + (Pattern'Length - 1)) = Pattern then - N := N + 1; - J := J + Pattern'Length; - else - J := J + 1; - end if; + <> + null; end loop; - return N; + return Num; end Count; function Count @@ -187,8 +215,8 @@ package body Ada.Strings.Search is end if; end loop; - -- Here if J indexes 1st char of token, and all chars - -- after J are in the token + -- Here if J indexes first char of token, and all chars after J + -- are in the token. Last := Source'Last; return; @@ -211,43 +239,88 @@ package body Ada.Strings.Search is Going : Direction := Forward; Mapping : Maps.Character_Mapping := Maps.Identity) return Natural is - Cur_Index : Natural; - Mapped_Source : String (Source'Range); + PL1 : constant Integer := Pattern'Length - 1; + Ind : Natural; + Cur : Natural; begin if Pattern = "" then raise Pattern_Error; end if; - for J in Source'Range loop - Mapped_Source (J) := Value (Mapping, Source (J)); - end loop; - -- Forwards case if Going = Forward then - for J in 1 .. Source'Length - Pattern'Length + 1 loop - Cur_Index := Source'First + J - 1; + Ind := Source'First; - if Pattern = Mapped_Source - (Cur_Index .. Cur_Index + Pattern'Length - 1) - then - return Cur_Index; - end if; - end loop; + -- Unmapped forward case + + if Mapping'Address = Maps.Identity'Address then + for J in 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped forward case + + else + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + end if; -- Backwards case else - for J in reverse 1 .. Source'Length - Pattern'Length + 1 loop - Cur_Index := Source'First + J - 1; + -- Unmapped backward case - if Pattern = Mapped_Source - (Cur_Index .. Cur_Index + Pattern'Length - 1) - then - return Cur_Index; - end if; - end loop; + Ind := Source'Last - PL1; + + if Mapping'Address = Maps.Identity'Address then + for J in reverse 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind - 1; + end if; + end loop; + + -- Mapped backward case + + else + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; end if; -- Fall through if no match found. Note that the loops are skipped @@ -262,53 +335,67 @@ package body Ada.Strings.Search is Going : Direction := Forward; Mapping : Maps.Character_Mapping_Function) return Natural is - Mapped_Source : String (Source'Range); - Cur_Index : Natural; + PL1 : constant Integer := Pattern'Length - 1; + Ind : Natural; + Cur : Natural; begin if Pattern = "" then raise Pattern_Error; end if; - -- We make sure Access_Check is unsuppressed so that the Mapping.all - -- call will generate a friendly Constraint_Error if the value for - -- Mapping is uninitialized (and hence null). + -- Check for null pointer in case checks are off - declare - pragma Unsuppress (Access_Check); - begin - for J in Source'Range loop - Mapped_Source (J) := Mapping.all (Source (J)); - end loop; - end; + if Mapping = null then + raise Constraint_Error; + end if; -- Forwards case if Going = Forward then - for J in 1 .. Source'Length - Pattern'Length + 1 loop - Cur_Index := Source'First + J - 1; + Ind := Source'First; + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; - if Pattern = Mapped_Source - (Cur_Index .. Cur_Index + Pattern'Length - 1) - then - return Cur_Index; - end if; + return Ind; + + <> + Ind := Ind + 1; end loop; -- Backwards case else - for J in reverse 1 .. Source'Length - Pattern'Length + 1 loop - Cur_Index := Source'First + J - 1; + Ind := Source'Last - PL1; + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; - if Pattern = Mapped_Source - (Cur_Index .. Cur_Index + Pattern'Length - 1) - then - return Cur_Index; - end if; + return Ind; + + <> + Ind := Ind - 1; end loop; end if; + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + return 0; end Index; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 011472d..0b4ea23 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4440,35 +4440,24 @@ package body Exp_Ch6 is Pop_Scope; end if; - -- Ada 2005 (AI-348): Generation of the null body + -- Ada 2005 (AI-348): Generate body for a null procedure. + -- In most cases this is superfluous because calls to it + -- will be automatically inlined, but we definitely need + -- the body if preconditions for the procedure are present. elsif Nkind (Specification (N)) = N_Procedure_Specification and then Null_Present (Specification (N)) then declare - Bod : constant Node_Id := - Make_Subprogram_Body (Loc, - Specification => - New_Copy_Tree (Specification (N)), - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Make_Null_Statement (Loc)))); + Bod : constant Node_Id := Body_To_Inline (N); begin - Set_Body_To_Inline (N, Bod); - Insert_After (N, Bod); - Analyze (Bod); + Set_Has_Completion (Subp, False); + Append_Freeze_Action (Subp, Bod); - -- Corresponding_Spec isn't being set by Analyze_Subprogram_Body, - -- evidently because Set_Has_Completion is called earlier for null - -- procedures in Analyze_Subprogram_Declaration, so we force its - -- setting here. If the setting of Has_Completion is not set - -- earlier, then it can result in missing body errors if other - -- errors were already reported (since expansion is turned off). + -- The body now contains raise statements, so calls to it will + -- not be inlined. - -- Should creation of the empty body be moved to the analyzer??? - - Set_Corresponding_Spec (Bod, Defining_Entity (Specification (N))); + Set_Is_Inlined (Subp, False); end; end if; end Expand_N_Subprogram_Declaration; @@ -4910,8 +4899,8 @@ package body Exp_Ch6 is -- Check if this is a declared null procedure elsif Nkind (Decl) = N_Subprogram_Declaration then - if Null_Present (Specification (Decl)) then - return True; + if not Null_Present (Specification (Decl)) then + return False; elsif No (Body_To_Inline (Decl)) then return False; @@ -4936,8 +4925,9 @@ package body Exp_Ch6 is Stat2 := Next (Stat); return - Nkind (Stat) = N_Null_Statement - and then + Is_Empty_List (Declarations (Orig_Bod)) + and then Nkind (Stat) = N_Null_Statement + and then (No (Stat2) or else (Nkind (Stat2) = N_Simple_Return_Statement diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index b15f52f..909cf0d 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -1617,7 +1617,15 @@ package body GNAT.Sockets is Raise_Socket_Error (Socket_Errno); end if; - Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + if Res = 0 + and then Item'First = Ada.Streams.Stream_Element_Offset'First + then + -- No data sent and first index is first Stream_Element_Offset'First + -- Last is set to Stream_Element_Offset'Last. + Last := Ada.Streams.Stream_Element_Offset'Last; + else + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + end if; end Receive_Socket; -------------------- @@ -1889,7 +1897,15 @@ package body GNAT.Sockets is Raise_Socket_Error (Socket_Errno); end if; - Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + if Res = 0 + and then Item'First = Ada.Streams.Stream_Element_Offset'First + then + -- No data sent and first index is first Stream_Element_Offset'First + -- Last is set to Stream_Element_Offset'Last. + Last := Ada.Streams.Stream_Element_Offset'Last; + else + Last := Item'First + Ada.Streams.Stream_Element_Offset (Res - 1); + end if; end Send_Socket; ----------------- diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads index e84bd0f..593c96e 100644 --- a/gcc/ada/g-socket.ads +++ b/gcc/ada/g-socket.ads @@ -895,9 +895,10 @@ package GNAT.Sockets is Flags : Request_Flag_Type := No_Request_Flag); -- Receive message from Socket. Last is the index value such that Item -- (Last) is the last character assigned. Note that Last is set to - -- Item'First - 1 when the socket has been closed by peer. This is not an - -- error and no exception is raised. Flags allows to control the - -- reception. Raise Socket_Error on error. + -- Item'First - 1 (or to Stream_Element_Array'Last if Item'First is + -- Stream_Element_Offset'First) when the socket has been closed by peer. + -- This is not an error and no exception is raised. Flags allows to + -- control the reception. Raise Socket_Error on error. procedure Receive_Socket (Socket : Socket_Type; @@ -933,11 +934,16 @@ package GNAT.Sockets is To : access Sock_Addr_Type; Flags : Request_Flag_Type := No_Request_Flag); pragma Inline (Send_Socket); - -- Transmit a message over a socket. For a datagram socket, the address is - -- given by To.all. For a stream socket, To must be null. Flags - -- allows to control the transmission. Raises Socket_Error on error. - -- Note: this subprogram is inlined because it is also used to implement - -- the two variants below. + -- Transmit a message over a socket. For a datagram socket, the address + -- is given by To.all. For a stream socket, To must be null. Last is + -- the index value such that Item (Last) is the last character + -- sent. Note that Last is set to Item'First - 1 (or to + -- Stream_Element_Array'Last if Item'First is + -- Stream_Element_Offset'First) when the socket has been closed by + -- peer. This is not an error and no exception is raised. Flags allows + -- to control the transmission. Raises Socket_Error on error. Note: + -- this subprogram is inlined because it is also used to implement the + -- two variants below. procedure Send_Socket (Socket : Socket_Type; diff --git a/gcc/ada/init.c b/gcc/ada/init.c index 1a24b67..8d9b195 100644 --- a/gcc/ada/init.c +++ b/gcc/ada/init.c @@ -1136,6 +1136,7 @@ extern char *__gnat_error_prehandler_stack; /* Alternate signal stack */ #define SS$_RESIGNAL 2328 /* These codes are in standard message libraries. */ +extern int C$_SIGKILL; extern int CMA$_EXIT_THREAD; extern int SS$_DEBUG; extern int SS$_INTDIV; @@ -1312,6 +1313,7 @@ typedef int resignal_predicate (int code); const int *cond_resignal_table [] = { + &C$_SIGKILL, &CMA$_EXIT_THREAD, &SS$_DEBUG, &LIB$_KEYNOTFOU, diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index c503b5e..d3e6be3 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -355,10 +355,10 @@ package body Prj.Nmsc is In_Tree : Project_Tree_Ref; Explicit_Sources_Only : Boolean; Proc_Data : in out Processing_Data); - -- Find all Ada sources by traversing all source directories. - -- If Explicit_Sources_Only is True, then the sources found must belong to - -- the list of sources specified explicitly in the project file. - -- If Explicit_Sources_Only is False, then all sources matching the naming + -- Find all Ada sources by traversing all source directories. If + -- Explicit_Sources_Only is True, then the sources found must belong to + -- the list of sources specified explicitly in the project file. If + -- Explicit_Sources_Only is False, then all sources matching the naming -- scheme are recorded. function Compute_Directory_Last (Dir : String) return Natural; @@ -375,30 +375,29 @@ package body Prj.Nmsc is -- Error_Report. procedure Search_Directories - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - For_All_Sources : Boolean; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + For_All_Sources : Boolean; Allow_Duplicate_Basenames : Boolean); - -- Search the source directories to find the sources. - -- If For_All_Sources is True, check each regular file name against the - -- naming schemes of the different languages. Otherwise consider only the - -- file names in the hash table Source_Names. - -- If Allow_Duplicate_Basenames, then files with the same base names are - -- authorized within a project for source-based languages (never for unit - -- based languages) + -- Search the source directories to find the sources. If For_All_Sources is + -- True, check each regular file name against the naming schemes of the + -- different languages. Otherwise consider only the file names in the hash + -- table Source_Names. If Allow_Duplicate_Basenames, then files with the + -- same base names are authorized within a project for source-based + -- languages (never for unit based languages) procedure Check_File - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Path : Path_Name_Type; - File_Name : File_Name_Type; - Display_File_Name : File_Name_Type; - For_All_Sources : Boolean; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Path : Path_Name_Type; + File_Name : File_Name_Type; + Display_File_Name : File_Name_Type; + For_All_Sources : Boolean; Allow_Duplicate_Basenames : Boolean); -- Check if file File_Name is a valid source of the project. This is used - -- in multi-language mode only. - -- When the file matches one of the naming schemes, it is added to - -- various htables through Add_Source and to Source_Paths_Htable. + -- in multi-language mode only. When the file matches one of the naming + -- schemes, it is added to various htables through Add_Source and to + -- Source_Paths_Htable. -- -- Name is the name of the candidate file. It hasn't been normalized yet -- and is the direct result of readdir(). @@ -441,8 +440,8 @@ package body Prj.Nmsc is -- Free the internal hash tables used for checking naming exceptions procedure Get_Directories - (Project : Project_Id; - In_Tree : Project_Tree_Ref; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; Current_Dir : String); -- Get the object directory, the exec directory and the source directories -- of a project. @@ -535,17 +534,16 @@ package body Prj.Nmsc is -- computing procedure Look_For_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Proc_Data : in out Processing_Data; Allow_Duplicate_Basenames : Boolean); -- Find all the sources of project Project in project tree In_Tree and -- update its Data accordingly. This assumes that Data.First_Source has -- been initialized with the list of excluded sources and special naming - -- exceptions. - -- If Allow_Duplicate_Basenames, then files with the same base names are - -- authorized within a project for source-based languages (never for unit - -- based languages) + -- exceptions. If Allow_Duplicate_Basenames, then files with the same base + -- names are authorized within a project for source-based languages (never + -- for unit based languages) function Path_Name_Of (File_Name : File_Name_Type; @@ -570,8 +568,8 @@ package body Prj.Nmsc is Location : Source_Ptr; Source_Recorded : in out Boolean); -- Put a unit in the list of units of a project, if the file name - -- corresponds to a valid unit name. - -- Ada_Language is a pointer to the Language_Data for "Ada" in Project. + -- corresponds to a valid unit name. Ada_Language is a pointer to the + -- Language_Data for "Ada" in Project. procedure Remove_Source (Id : Source_Id; @@ -6765,9 +6763,9 @@ package body Prj.Nmsc is ------------------ procedure Find_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Proc_Data : in out Processing_Data; Allow_Duplicate_Basenames : Boolean) is Sources : constant Variable_Value := @@ -6927,13 +6925,14 @@ package body Prj.Nmsc is if Get_Mode = Ada_Only then Find_Ada_Sources - (Project, In_Tree, Explicit_Sources_Only => Has_Explicit_Sources, - Proc_Data => Proc_Data); + (Project, In_Tree, + Explicit_Sources_Only => Has_Explicit_Sources, + Proc_Data => Proc_Data); else Search_Directories (Project, In_Tree, - For_All_Sources => + For_All_Sources => Sources.Default and then Source_List_File.Default, Allow_Duplicate_Basenames => Allow_Duplicate_Basenames); end if; @@ -7346,12 +7345,12 @@ package body Prj.Nmsc is ---------------- procedure Check_File - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Path : Path_Name_Type; - File_Name : File_Name_Type; - Display_File_Name : File_Name_Type; - For_All_Sources : Boolean; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Path : Path_Name_Type; + File_Name : File_Name_Type; + Display_File_Name : File_Name_Type; + For_All_Sources : Boolean; Allow_Duplicate_Basenames : Boolean) is Canonical_Path : constant Path_Name_Type := @@ -7464,7 +7463,9 @@ package body Prj.Nmsc is or else (Source.Kind = Impl and then Kind = Spec)) then - null; -- We found the "other_part (source)" + -- We found the "other_part (source)" + + null; elsif (Unit /= No_Name and then Source.Unit /= No_Unit_Index @@ -7566,9 +7567,9 @@ package body Prj.Nmsc is ------------------------ procedure Search_Directories - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - For_All_Sources : Boolean; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + For_All_Sources : Boolean; Allow_Duplicate_Basenames : Boolean) is Source_Dir : String_List_Id; @@ -7642,12 +7643,16 @@ package body Prj.Nmsc is declare Path_Name : constant String := - Normalize_Pathname - (Name (1 .. Last), - Directory => Source_Directory - (Source_Directory'First .. Dir_Last), - Resolve_Links => Opt.Follow_Links_For_Files, - Case_Sensitive => True); -- no folding + Normalize_Pathname + (Name (1 .. Last), + Directory => + Source_Directory + (Source_Directory'First .. + Dir_Last), + Resolve_Links => + Opt.Follow_Links_For_Files, + Case_Sensitive => True); + -- Case_Sensitive set True (no folding) Path : Path_Name_Type; FF : File_Found := @@ -7672,12 +7677,13 @@ package body Prj.Nmsc is else Check_File - (Project => Project, - In_Tree => In_Tree, - Path => Path, - File_Name => File_Name, - Display_File_Name => Display_File_Name, - For_All_Sources => For_All_Sources, + (Project => Project, + In_Tree => In_Tree, + Path => Path, + File_Name => File_Name, + Display_File_Name => + Display_File_Name, + For_All_Sources => For_All_Sources, Allow_Duplicate_Basenames => Allow_Duplicate_Basenames); end if; @@ -7775,9 +7781,9 @@ package body Prj.Nmsc is ---------------------- procedure Look_For_Sources - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Proc_Data : in out Processing_Data; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Proc_Data : in out Processing_Data; Allow_Duplicate_Basenames : Boolean) is Iter : Source_Iterator; @@ -7875,6 +7881,7 @@ package body Prj.Nmsc is procedure Process_Sources_In_Multi_Language_Mode is Iter : Source_Iterator; + begin -- Check that two sources of this project do not have the same object -- file name. @@ -7947,12 +7954,12 @@ package body Prj.Nmsc is declare Src_Ind : constant Source_File_Index := - Sinput.P.Load_Project_File - (Get_Name_String - (Src_Id.Path.Name)); + Sinput.P.Load_Project_File + (Get_Name_String + (Src_Id.Path.Name)); begin if Sinput.P.Source_File_Is_Subunit - (Src_Ind) + (Src_Ind) then Override_Kind (Src_Id, Sep); else diff --git a/gcc/ada/prj-nmsc.ads b/gcc/ada/prj-nmsc.ads index dfb167c..f0f2ee5 100644 --- a/gcc/ada/prj-nmsc.ads +++ b/gcc/ada/prj-nmsc.ads @@ -41,13 +41,13 @@ private package Prj.Nmsc is -- Free the memory occupied by Proc_Data procedure Check - (Project : Project_Id; - In_Tree : Project_Tree_Ref; - Report_Error : Put_Line_Access; - When_No_Sources : Error_Warning; - Current_Dir : String; - Proc_Data : in out Processing_Data; - Is_Config_File : Boolean; + (Project : Project_Id; + In_Tree : Project_Tree_Ref; + Report_Error : Put_Line_Access; + When_No_Sources : Error_Warning; + Current_Dir : String; + Proc_Data : in out Processing_Data; + Is_Config_File : Boolean; Compiler_Driver_Mandatory : Boolean; Allow_Duplicate_Basenames : Boolean); -- Perform consistency and semantic checks on a project, starting from the @@ -75,6 +75,7 @@ private package Prj.Nmsc is -- If Compiler_Driver_Mandatory is true, then a Compiler.Driver attribute -- for each language must be defined, or we will not look for its source -- files. + -- -- If Allow_Duplicate_Basenames, then files with the same base names are -- authorized within a project for source-based languages (never for unit -- based languages) diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index 2946b42..31cd292 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -285,11 +285,11 @@ package body Prj.Proc is ----------- procedure Check - (In_Tree : Project_Tree_Ref; - Project : Project_Id; - Current_Dir : String; - When_No_Sources : Error_Warning; - Is_Config_File : Boolean; + (In_Tree : Project_Tree_Ref; + Project : Project_Id; + Current_Dir : String; + When_No_Sources : Error_Warning; + Is_Config_File : Boolean; Compiler_Driver_Mandatory : Boolean; Allow_Duplicate_Basenames : Boolean) is @@ -1259,17 +1259,17 @@ package body Prj.Proc is if not Is_Config_File then Process_Project_Tree_Phase_2 - (In_Tree => In_Tree, - Project => Project, - Success => Success, - From_Project_Node => From_Project_Node, - From_Project_Node_Tree => From_Project_Node_Tree, - Report_Error => Report_Error, - When_No_Sources => When_No_Sources, - Current_Dir => Current_Dir, + (In_Tree => In_Tree, + Project => Project, + Success => Success, + From_Project_Node => From_Project_Node, + From_Project_Node_Tree => From_Project_Node_Tree, + Report_Error => Report_Error, + When_No_Sources => When_No_Sources, + Current_Dir => Current_Dir, Compiler_Driver_Mandatory => True, Allow_Duplicate_Basenames => False, - Is_Config_File => Is_Config_File); + Is_Config_File => Is_Config_File); end if; end Process; diff --git a/gcc/ada/prj.adb b/gcc/ada/prj.adb index d3c29c9..4cc0c4d 100644 --- a/gcc/ada/prj.adb +++ b/gcc/ada/prj.adb @@ -154,7 +154,7 @@ package body Prj is procedure Language_Changed (Iter : in out Source_Iterator); procedure Project_Changed (Iter : in out Source_Iterator); - -- Called when a new project or language was selected for this iterator. + -- Called when a new project or language was selected for this iterator function Contains_ALI_Files (Dir : Path_Name_Type) return Boolean; -- Return True if there is at least one ALI file in the directory Dir @@ -845,15 +845,19 @@ package body Prj is --------------- procedure Free_List (Source : in out Source_Id) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Source_Data, Source_Id); + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Source_Data, Source_Id); + Tmp : Source_Id; + begin while Source /= No_Source loop Tmp := Source.Next_In_Lang; Free_List (Source.Alternate_Languages); - if Source.Unit /= null then + if Source.Unit /= null + and then Source.Kind in Spec_Or_Body + then Source.Unit.File_Names (Source.Kind) := null; end if; @@ -870,8 +874,9 @@ package body Prj is (List : in out Project_List; Free_Project : Boolean) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Project_List_Element, Project_List); + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Project_List_Element, Project_List); + Tmp : Project_List; begin @@ -892,9 +897,11 @@ package body Prj is --------------- procedure Free_List (Languages : in out Language_Ptr) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Language_Data, Language_Ptr); + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Language_Data, Language_Ptr); + Tmp : Language_Ptr; + begin while Languages /= null loop Tmp := Languages.Next; @@ -909,16 +916,18 @@ package body Prj is ---------------- procedure Free_Units (Table : in out Units_Htable.Instance) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Unit_Data, Unit_Index); + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Unit_Data, Unit_Index); + Unit : Unit_Index; + begin Unit := Units_Htable.Get_First (Table); - while Unit /= No_Unit_Index loop if Unit.File_Names (Spec) /= null then Unit.File_Names (Spec).Unit := No_Unit_Index; end if; + if Unit.File_Names (Impl) /= null then Unit.File_Names (Impl).Unit := No_Unit_Index; end if; @@ -935,8 +944,8 @@ package body Prj is ---------- procedure Free (Tree : in out Project_Tree_Ref) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Project_Tree_Data, Project_Tree_Ref); + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Project_Tree_Data, Project_Tree_Ref); begin if Tree /= null then @@ -1076,6 +1085,7 @@ package body Prj is procedure Set_Mode (New_Mode : Mode) is begin Current_Mode := New_Mode; + case New_Mode is when Ada_Only => Default_Language_Is_Ada := True; @@ -1462,10 +1472,12 @@ package body Prj is ---------------------------- function Get_Language_From_Name - (Project : Project_Id; Name : String) return Language_Ptr + (Project : Project_Id; + Name : String) return Language_Ptr is - N : Name_Id; + N : Name_Id; Result : Language_Ptr; + begin Name_Len := Name'Length; Name_Buffer (1 .. Name_Len) := Name; @@ -1484,6 +1496,26 @@ package body Prj is return No_Language_Index; end Get_Language_From_Name; + ---------------- + -- Other_Part -- + ---------------- + + function Other_Part (Source : Source_Id) return Source_Id is + begin + if Source.Unit /= No_Unit_Index then + case Source.Kind is + when Impl => + return Source.Unit.File_Names (Spec); + when Spec => + return Source.Unit.File_Names (Impl); + when Sep => + return No_Source; + end case; + else + return No_Source; + end if; + end Other_Part; + begin -- Make sure that the standard config and user project file extensions are -- compatible with canonical case file naming. diff --git a/gcc/ada/s-vxwext-kernel.adb b/gcc/ada/s-vxwext-kernel.adb index f93ba6b..a8455bb 100644 --- a/gcc/ada/s-vxwext-kernel.adb +++ b/gcc/ada/s-vxwext-kernel.adb @@ -34,6 +34,8 @@ package body System.VxWorks.Ext is + ERROR : constant := -1; + -------------- -- Int_Lock -- -------------- diff --git a/gcc/ada/s-vxwext.adb b/gcc/ada/s-vxwext.adb new file mode 100644 index 0000000..b13b07e --- /dev/null +++ b/gcc/ada/s-vxwext.adb @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V X W O R K S . E X T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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- -- +-- ware Foundation; either version 2, or (at your option) any later ver- -- +-- sion. GNARL is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNARL; see file COPYING. If not, write -- +-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- +-- Boston, MA 02110-1301, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides vxworks specific support functions needed +-- by System.OS_Interface. + +-- This is the VxWorks 5.x version of this package + +package body System.VxWorks.Ext is + + ERROR : constant := -1; + + ------------------------ + -- taskCpuAffinitySet -- + ------------------------ + + function taskCpuAffinitySet (tid : t_id; CPU : int) return int is + pragma Unreferenced (tid, CPU); + begin + return ERROR; + end taskCpuAffinitySet; + +end System.VxWorks.Ext; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 7479d75..828babd 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -8609,23 +8609,39 @@ package body Sem_Ch3 is -- source (including the _Call primitive operation of RAS types, -- which has to have the flag Comes_From_Source for other purposes): -- we assume that the expander will provide the missing completion. + -- In case of previous errors, other expansion actions that provide + -- bodies for null procedures with not be invoked. so inhibit message + -- in those cases. elsif Ekind (E) = E_Function or else Ekind (E) = E_Procedure or else Ekind (E) = E_Generic_Function or else Ekind (E) = E_Generic_Procedure then - if not Has_Completion (E) - and then not (Is_Subprogram (E) - and then Is_Abstract_Subprogram (E)) - and then not (Is_Subprogram (E) - and then - (not Comes_From_Source (E) - or else Chars (E) = Name_uCall)) - and then Nkind (Parent (Unit_Declaration_Node (E))) /= - N_Compilation_Unit - and then Chars (E) /= Name_uSize + if Has_Completion (E) then + null; + + elsif Is_Subprogram (E) and then Is_Abstract_Subprogram (E) then + null; + + elsif Is_Subprogram (E) + and then (not Comes_From_Source (E) + or else Chars (E) = Name_uCall) then + null; + + elsif + Nkind (Parent (Unit_Declaration_Node (E))) = N_Compilation_Unit + then + null; + + elsif Nkind (Parent (E)) = N_Procedure_Specification + and then Null_Present (Parent (E)) + and then Serious_Errors_Detected > 0 + then + null; + + else Post_Error; end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index b8e8b42..c9585a08 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2262,7 +2262,9 @@ package body Sem_Ch4 is return; end if; - if Present (Actuals) + -- An indexing requires at least one actual. + + if not Is_Empty_List (Actuals) and then (Needs_No_Actuals (Nam) or else -- cgit v1.1