1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- O S I N T - B -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2001-2010, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- 17-- for more details. You should have received a copy of the GNU General -- 18-- Public License distributed with GNAT; see file COPYING3. If not, go to -- 19-- http://www.gnu.org/licenses for a complete copy of the license. -- 20-- -- 21-- GNAT was originally developed by the GNAT team at New York University. -- 22-- Extensive contributions were provided by Ada Core Technologies Inc. -- 23-- -- 24------------------------------------------------------------------------------ 25 26with Opt; use Opt; 27with Output; use Output; 28with Targparm; use Targparm; 29 30package body Osint.B is 31 32 Current_List_File : File_Descriptor := Invalid_FD; 33 34 ------------------------- 35 -- Close_Binder_Output -- 36 ------------------------- 37 38 procedure Close_Binder_Output is 39 Status : Boolean; 40 begin 41 Close (Output_FD, Status); 42 43 if not Status then 44 Fail 45 ("error while closing generated file " 46 & Get_Name_String (Output_File_Name)); 47 end if; 48 49 end Close_Binder_Output; 50 51 --------------------- 52 -- Close_List_File -- 53 --------------------- 54 55 procedure Close_List_File is 56 begin 57 if Current_List_File /= Invalid_FD then 58 Close (Current_List_File); 59 Current_List_File := Invalid_FD; 60 Set_Standard_Output; 61 end if; 62 end Close_List_File; 63 64 -------------------------- 65 -- Create_Binder_Output -- 66 -------------------------- 67 68 procedure Create_Binder_Output 69 (Output_File_Name : String; 70 Typ : Character; 71 Bfile : out Name_Id) 72 is 73 File_Name : String_Ptr; 74 Findex1 : Natural; 75 Findex2 : Natural; 76 Flength : Natural; 77 78 Bind_File_Prefix_Len : Natural := 2; 79 -- Length of binder file prefix (normally set to 2 for b~, but gets 80 -- reset to 3 for VMS for b__). 81 82 begin 83 if Output_File_Name /= "" then 84 Name_Buffer (1 .. Output_File_Name'Length) := Output_File_Name; 85 Name_Buffer (Output_File_Name'Length + 1) := ASCII.NUL; 86 87 if Typ = 's' then 88 Name_Buffer (Output_File_Name'Last) := 's'; 89 end if; 90 91 Name_Len := Output_File_Name'Last; 92 93 else 94 Name_Buffer (1) := 'b'; 95 File_Name := File_Names (Current_File_Name_Index); 96 97 Findex1 := File_Name'First; 98 99 -- The ali file might be specified by a full path name. However, 100 -- the binder generated file should always be created in the 101 -- current directory, so the path might need to be stripped away. 102 -- In addition to the default directory_separator allow the '/' to 103 -- act as separator since this is allowed in MS-DOS and OS2 ports. 104 105 for J in reverse File_Name'Range loop 106 if File_Name (J) = Directory_Separator 107 or else File_Name (J) = '/' 108 then 109 Findex1 := J + 1; 110 exit; 111 end if; 112 end loop; 113 114 Findex2 := File_Name'Last; 115 while File_Name (Findex2) /= '.' loop 116 Findex2 := Findex2 - 1; 117 end loop; 118 119 Flength := Findex2 - Findex1; 120 121 if Maximum_File_Name_Length > 0 then 122 123 if OpenVMS_On_Target and then Typ /= 'c' then 124 Bind_File_Prefix_Len := 3; 125 end if; 126 127 -- Make room for the extra two characters in "b?" 128 129 while Int (Flength) > 130 Maximum_File_Name_Length - Nat (Bind_File_Prefix_Len) 131 loop 132 Findex2 := Findex2 - 1; 133 Flength := Findex2 - Findex1; 134 end loop; 135 end if; 136 137 Name_Buffer 138 (Bind_File_Prefix_Len + 1 .. Flength + Bind_File_Prefix_Len) := 139 File_Name (Findex1 .. Findex2 - 1); 140 Name_Buffer (Flength + Bind_File_Prefix_Len + 1) := '.'; 141 142 -- C bind file, name is b_xxx.c 143 144 if Typ = 'c' then 145 Name_Buffer (2) := '_'; 146 Name_Buffer (Flength + 4) := 'c'; 147 Name_Buffer (Flength + 5) := ASCII.NUL; 148 Name_Len := Flength + 4; 149 150 -- Ada bind file, name is b~xxx.adb or b~xxx.ads 151 -- (with __ instead of ~ in VMS) 152 153 else 154 if OpenVMS_On_Target then 155 Name_Buffer (2) := '_'; 156 Name_Buffer (3) := '_'; 157 else 158 Name_Buffer (2) := '~'; 159 end if; 160 161 Name_Buffer (Flength + Bind_File_Prefix_Len + 2) := 'a'; 162 Name_Buffer (Flength + Bind_File_Prefix_Len + 3) := 'd'; 163 Name_Buffer (Flength + Bind_File_Prefix_Len + 4) := Typ; 164 Name_Buffer (Flength + Bind_File_Prefix_Len + 5) := ASCII.NUL; 165 Name_Len := Flength + Bind_File_Prefix_Len + 4; 166 end if; 167 end if; 168 169 Bfile := Name_Find; 170 171 Create_File_And_Check (Output_FD, Text); 172 end Create_Binder_Output; 173 174 -------------------- 175 -- More_Lib_Files -- 176 -------------------- 177 178 function More_Lib_Files return Boolean renames More_Files; 179 180 ------------------------ 181 -- Next_Main_Lib_File -- 182 ------------------------ 183 184 function Next_Main_Lib_File return File_Name_Type renames Next_Main_File; 185 186 --------------------------------- 187 -- Set_Current_File_Name_Index -- 188 --------------------------------- 189 190 procedure Set_Current_File_Name_Index (To : Int) is 191 begin 192 Current_File_Name_Index := To; 193 end Set_Current_File_Name_Index; 194 195 ------------------- 196 -- Set_List_File -- 197 ------------------- 198 199 procedure Set_List_File (Filename : String) is 200 begin 201 pragma Assert (Current_List_File = Invalid_FD); 202 Current_List_File := Create_File (Filename, Text); 203 204 if Current_List_File = Invalid_FD then 205 Fail ("cannot create list file: " & Filename); 206 else 207 Set_Output (Current_List_File); 208 end if; 209 end Set_List_File; 210 211 ----------------------- 212 -- Write_Binder_Info -- 213 ----------------------- 214 215 procedure Write_Binder_Info (Info : String) renames Write_Info; 216 217begin 218 Set_Program (Binder); 219end Osint.B; 220