diff options
Diffstat (limited to 'gcc/ada/gnatlink.adb')
| -rw-r--r-- | gcc/ada/gnatlink.adb | 137 |
1 files changed, 66 insertions, 71 deletions
diff --git a/gcc/ada/gnatlink.adb b/gcc/ada/gnatlink.adb index 09ce5bb0f5d..d6834ab5ae2 100644 --- a/gcc/ada/gnatlink.adb +++ b/gcc/ada/gnatlink.adb @@ -178,6 +178,19 @@ procedure Gnatlink is -- Predicate indicating whether the linker has an option whereby the -- names of object files can be passed to the linker in a file. + Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr; + pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option"); + -- Pointer to a string representing the linker option which specifies + -- the response file. + + Object_File_Option : constant String := Value (Object_File_Option_Ptr); + -- The linker option which specifies the response file as a string + + Using_GNU_response_file : constant Boolean := + Object_File_Option'Length > 0 + and then Object_File_Option (Object_File_Option'Last) = '@'; + -- Whether a GNU response file is used + Object_List_File_Required : Boolean := False; -- Set to True to force generation of a response file @@ -760,28 +773,12 @@ procedure Gnatlink is -- Pointer to string specifying the default extension for -- object libraries, e.g. Unix uses ".a", VMS uses ".olb". - Object_File_Option_Ptr : Interfaces.C.Strings.chars_ptr; - pragma Import (C, Object_File_Option_Ptr, "__gnat_object_file_option"); - -- Pointer to a string representing the linker option which specifies - -- the response file. - - Using_GNU_Linker : Boolean; - for Using_GNU_Linker'Size use Character'Size; - pragma Import (C, Using_GNU_Linker, "__gnat_using_gnu_linker"); - -- Predicate indicating whether this target uses the GNU linker. In - -- this case we must output a GNU linker compatible response file. - Separate_Run_Path_Options : Boolean; for Separate_Run_Path_Options'Size use Character'Size; pragma Import (C, Separate_Run_Path_Options, "__gnat_separate_run_path_options"); -- Whether separate rpath options should be emitted for each directory - Opening : aliased constant String := """"; - Closing : aliased constant String := '"' & ASCII.LF; - -- Needed to quote object paths in object list files when GNU linker - -- is used. - procedure Get_Next_Line; -- Read the next line from the binder file without the line -- terminator. @@ -804,6 +801,10 @@ procedure Gnatlink is -- after Store_File_Context. The binder file context will be restored -- with the data stored by the last Store_File_Context call. + procedure Write_RF (S : String); + -- Write a string to the response file and check if it was successful. + -- Fail the program if it was not successful (disk full). + ------------------- -- Get_Next_Line -- ------------------- @@ -897,6 +898,46 @@ procedure Gnatlink is end if; end Store_File_Context; + -------------- + -- Write_RF -- + -------------- + + procedure Write_RF (S : String) is + Success : Boolean := True; + begin + -- If a GNU response file is used, space and backslash need to be + -- escaped because they are interpreted as a string separator and + -- an escape character respectively by the underlying mechanism. + -- On the other hand, quote and double-quote are not escaped since + -- they are interpreted as string delimiters on both sides. + + if Using_GNU_response_file then + for I in S'Range loop + if S (I) = ' ' or else S (I) = '\' then + if Write (Tname_FD, ASCII.BACK_SLASH'Address, 1) /= 1 then + Success := False; + end if; + end if; + + if Write (Tname_FD, S (I)'Address, 1) /= 1 then + Success := False; + end if; + end loop; + else + if Write (Tname_FD, S'Address, S'Length) /= S'Length then + Success := False; + end if; + end if; + + if Write (Tname_FD, ASCII.LF'Address, 1) /= 1 then + Success := False; + end if; + + if not Success then + Exit_With_Error ("Error generating response file: disk full"); + end if; + end Write_RF; + -- Start of processing for Process_Binder_File begin @@ -985,61 +1026,14 @@ procedure Gnatlink is -- ??? Status of Write and Close operations should be checked, and -- failure should occur if a status is wrong. - -- If target is using the GNU linker we must add a special header - -- and footer in the response file. - - -- The syntax is : INPUT (object1.o object2.o ... ) - - -- Because the GNU linker does not like name with characters such - -- as '!', we must put the object paths between double quotes. - - if Using_GNU_Linker then - declare - GNU_Header : aliased constant String := "INPUT ("; - - begin - Status := Write (Tname_FD, GNU_Header'Address, - GNU_Header'Length); - end; - end if; - for J in Objs_Begin .. Objs_End loop - - -- Opening quote for GNU linker - - if Using_GNU_Linker then - Status := Write (Tname_FD, Opening'Address, 1); - end if; - - Status := Write (Tname_FD, Linker_Objects.Table (J).all'Address, - Linker_Objects.Table (J).all'Length); - - -- Closing quote for GNU linker - - if Using_GNU_Linker then - Status := Write (Tname_FD, Closing'Address, 2); - - else - Status := Write (Tname_FD, ASCII.LF'Address, 1); - end if; + Write_RF (Linker_Objects.Table (J).all); Response_File_Objects.Increment_Last; Response_File_Objects.Table (Response_File_Objects.Last) := Linker_Objects.Table (J); end loop; - -- Handle GNU linker response file footer - - if Using_GNU_Linker then - declare - GNU_Footer : aliased constant String := ")"; - - begin - Status := Write (Tname_FD, GNU_Footer'Address, - GNU_Footer'Length); - end; - end if; - Close (Tname_FD, Closing_Status); -- Add the special objects list file option together with the name @@ -1047,7 +1041,7 @@ procedure Gnatlink is -- file table. Linker_Objects.Table (Objs_Begin) := - new String'(Value (Object_File_Option_Ptr) & + new String'(Object_File_Option & Tname (Tname'First .. Tname'Last - 1)); -- The slots containing these object file names are then removed @@ -2213,14 +2207,15 @@ begin System.OS_Lib.Spawn (Linker_Path.all, Args, Success); - -- Delete the temporary file used in conjunction with linking if - -- one was created. See Process_Bind_File for details. + if Success then + -- Delete the temporary file used in conjunction with linking + -- if one was created. See Process_Bind_File for details. - if Tname_FD /= Invalid_FD then - Delete (Tname); - end if; + if Tname_FD /= Invalid_FD then + Delete (Tname); + end if; - if not Success then + else Error_Msg ("error when calling " & Linker_Path.all); Exit_Program (E_Fatal); end if; |