1-- Binary file Mach-O writer. 2-- Copyright (C) 2015 Tristan Gingold 3-- 4-- This program is free software: you can redistribute it and/or modify 5-- it under the terms of the GNU General Public License as published by 6-- the Free Software Foundation, either version 2 of the License, or 7-- (at your option) any later version. 8-- 9-- This program is distributed in the hope that it will be useful, 10-- but WITHOUT ANY WARRANTY; without even the implied warranty of 11-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12-- GNU General Public License for more details. 13-- 14-- You should have received a copy of the GNU General Public License 15-- along with this program. If not, see <gnu.org/licenses>. 16with Macho; use Macho; 17with Macho_Arch64; use Macho_Arch64; 18 19package body Binary_File.Macho is 20 procedure Write (Fd : GNAT.OS_Lib.File_Descriptor) 21 is 22 use GNAT.OS_Lib; 23 24 -- If true, discard local symbols; 25 Flag_Discard_Local : Boolean := True; 26 27 procedure Xwrite (Data : System.Address; Len : Natural) is 28 begin 29 if Write (Fd, Data, Len) /= Len then 30 raise Write_Error; 31 end if; 32 end Xwrite; 33 34 function Symbol_Discarded (S : Symbol) return Boolean is 35 begin 36 case Get_Scope (S) is 37 when Sym_Local => 38 if Flag_Discard_Local then 39 return True; 40 end if; 41 when Sym_Private => 42 null; 43 when Sym_Global => 44 null; 45 when Sym_Undef => 46 if not Get_Used (S) then 47 return True; 48 end if; 49 end case; 50 return False; 51 end Symbol_Discarded; 52 53 procedure Fill_Name (Dest : out String; Src : String) 54 is 55 subtype D_Type is String (1 .. Dest'Length); 56 D : D_Type renames Dest; 57 subtype S_Type is String (1 .. Src'Length); 58 S : S_Type renames Src; 59 begin 60 if S'Length < D'Length then 61 D (1 .. S'Length) := S; 62 D (S'Length + 1 .. D'Last) := (others => ASCII.NUL); 63 else 64 D := S (1 .. D'Last); 65 end if; 66 end Fill_Name; 67 68 type Section_Info_Type is record 69 Sect : Section_Acc; 70 -- Index of the section symbol (in symtab). 71 end record; 72 type Section_Info_Array is array (Natural range <>) of Section_Info_Type; 73 Sects_Info : Section_Info_Array (1 .. Nbr_Sections); 74 type Section_Array is array (Natural range <>) of Section; 75 Sects_Hdr : Section_Array (1 .. Nbr_Sections); 76 Nbr_Sect : Natural; 77 Sect : Section_Acc; 78 79 -- Various offsets. 80 File_Offset : Natural; 81 Seg_Offset : Natural; 82 Symtab_Offset : Natural; 83 Strtab_Offset : Natural; 84 Sizeof_Cmds : Natural; 85 86 -- Number of symtab entries. 87 Nbr_Symbols : Natural; 88 89 Str_Size : Natural; 90 91 -- If true, do local relocs. 92 Flag_Reloc : constant Boolean := True; 93 begin 94 -- If relocations are not performs, then local symbols cannot be 95 -- discarded. 96 if not Flag_Reloc then 97 Flag_Discard_Local := False; 98 end if; 99 100 -- Count sections. 101 Sect := Section_Chain; 102 Nbr_Sect := 0; 103 while Sect /= null loop 104 Nbr_Sect := Nbr_Sect + 1; 105 Sects_Info (Nbr_Sect).Sect := Sect; 106 Sect.Number := Nbr_Sect; 107 Sect := Sect.Next; 108 end loop; 109 110 -- Set sections offset. 111 Sizeof_Cmds := Lc_Size + Segment_Command_Size 112 + Nbr_Sect * Section_Size 113 + Lc_Size + Symtab_Command_Size; 114 File_Offset := Header_Size + Sizeof_Cmds; 115 Seg_Offset := File_Offset; 116 for I in 1 .. Nbr_Sect loop 117 Sect := Sects_Info (I).Sect; 118 if Sect.Data /= null then 119 -- FIXME: alignment ? 120 Sects_Hdr (I).Offset := Unsigned_32 (File_Offset); 121 File_Offset := File_Offset + Natural (Sect.Pc); 122 else 123 Sects_Hdr (I).Offset := 0; 124 end if; 125 end loop; 126 127 -- Relocs 128 -- FIXME: todo. 129 130 Symtab_Offset := File_Offset; 131 Str_Size := 0; 132 Nbr_Symbols := 0; 133 for I in Symbols.First .. Symbols.Last loop 134 if not Symbol_Discarded (I) then 135 Nbr_Symbols := Nbr_Symbols + 1; 136 Set_Number (I, Nbr_Symbols); 137 Str_Size := Str_Size + Get_Symbol_Name_Length (I) + 1; 138 else 139 Set_Number (I, 0); 140 end if; 141 end loop; 142 143 File_Offset := File_Offset + Nbr_Symbols * Nlist_Size; 144 Strtab_Offset := File_Offset; 145 146 -- Write file header. 147 declare 148 Hdr : Header; 149 Cputype : Unsigned_32; 150 begin 151 case Arch is 152 when Arch_X86 => 153 Cputype := Cputype_I386; 154 when Arch_X86_64 => 155 Cputype := Cputype_I386 + Cpu_Arch_64; 156 when others => 157 raise Program_Error; 158 end case; 159 Hdr := (Magic => Magic, 160 Cputype => Cputype, 161 Cpusubtype => Cpusubtype_I386_All, 162 Filetype => Mh_Object, 163 Ncmds => 2, 164 Sizeofcmds => Unsigned_32 (Sizeof_Cmds), 165 others => 0); 166 Xwrite (Hdr'Address, Header_Size); 167 end; 168 169 -- Write segment and section commands. 170 declare 171 Lc : Load_Command; 172 Seg : Segment_Command; 173 begin 174 Lc := (Cmd => Lc_Segment, 175 Cmdsize => Unsigned_32 (Lc_Size + Segment_Command_Size 176 + Nbr_Sect * Section_Size)); 177 Xwrite (Lc'Address, Lc_Size); 178 Seg := (Segname => (others => ASCII.NUL), 179 Vmaddr => 0, 180 Vmsize => 0, -- FIXME 181 Fileoff => Addr_T (Seg_Offset), 182 Filesize => Addr_T (Symtab_Offset - Seg_Offset), 183 Maxprot => 7, -- rwx 184 Initprot => 7, 185 Nsects => Unsigned_32 (Nbr_Sect), 186 Flags => 0); 187 Xwrite (Seg'Address, Segment_Command_Size); 188 end; 189 190 -- Write section headers. 191 for I in 1 .. Nbr_Sect loop 192 Sect := Sects_Info (I).Sect; 193 declare 194 Hdr : Section renames Sects_Hdr (I); 195 Secname_Raw : constant String := Sect.Name.all; 196 subtype S_Type is String (1 .. Secname_Raw'Length); 197 Secname : S_Type renames Secname_Raw; 198 begin 199 if Secname = ".text" then 200 Fill_Name (Hdr.Sectname, "__text"); 201 Fill_Name (Hdr.Segname, "__TEXT"); 202 elsif Secname = ".rodata" then 203 Fill_Name (Hdr.Sectname, "__const"); 204 Fill_Name (Hdr.Segname, "__TEXT"); 205 elsif (Sect.Flags and Section_Debug) /= 0 then 206 if Secname'Length > 7 207 and then Secname (1 .. 7) = ".debug_" 208 then 209 Fill_Name (Hdr.Sectname, 210 "__debug_" & Secname (8 .. Secname'Last)); 211 else 212 Fill_Name (Hdr.Sectname, Sect.Name.all); 213 end if; 214 Fill_Name (Hdr.Segname, "__DWARF"); 215 else 216 Fill_Name (Hdr.Sectname, Secname); 217 Fill_Name (Hdr.Segname, ""); 218 end if; 219 Hdr.Addr := Addr_T (Sect.Vaddr); 220 Hdr.Size := Addr_T (Sect.Pc); 221 Hdr.Align := Unsigned_32 (Sect.Align); 222 Hdr.Reloff := 0; 223 Hdr.Nreloc := 0; 224 Hdr.Flags := 0; 225 Hdr.Reserved1 := 0; 226 Hdr.Reserved2 := 0; 227 Xwrite (Hdr'Address, Section_Size); 228 end; 229 end loop; 230 231 -- Write symtab command 232 declare 233 Lc : Load_Command; 234 Symtab : Symtab_Command; 235 begin 236 Lc := (Cmd => Lc_Symtab, 237 Cmdsize => Unsigned_32 (Lc_Size + Symtab_Command_Size)); 238 Xwrite (Lc'Address, Lc_Size); 239 Symtab := (Symoff => Unsigned_32 (Symtab_Offset), 240 Nsyms => Unsigned_32 (Nbr_Symbols), 241 Stroff => Unsigned_32 (Strtab_Offset), 242 Strsize => Unsigned_32 (Str_Size)); 243 Xwrite (Symtab'Address, Symtab_Command_Size); 244 end; 245 246 -- Write sections content. 247 for I in 1 .. Nbr_Sect loop 248 Sect := Sects_Info (I).Sect; 249 if Sect.Data /= null then 250 Xwrite (Sect.Data (0)'Address, Natural (Sect.Pc)); 251 end if; 252 end loop; 253 254 -- FIXME: write relocs. 255 256 -- Write symbols. 257 declare 258 Str_Offset : Natural; 259 260 generic 261 with procedure Handle (S : Symbol); 262 procedure Foreach_Symbol; 263 264 procedure Foreach_Symbol is 265 begin 266 -- First, the local and private symbols. 267 for I in Symbols.First .. Symbols.Last loop 268 case Get_Scope (I) is 269 when Sym_Local => 270 if not Flag_Discard_Local then 271 Handle (I); 272 end if; 273 when Sym_Private => 274 Handle (I); 275 when Sym_Global 276 | Sym_Undef => 277 null; 278 end case; 279 end loop; 280 281 -- Then global symbols 282 for I in Symbols.First .. Symbols.Last loop 283 case Get_Scope (I) is 284 when Sym_Local 285 | Sym_Private => 286 null; 287 when Sym_Global => 288 Handle (I); 289 when Sym_Undef => 290 null; 291 end case; 292 end loop; 293 -- Then undef symbols. 294 for I in Symbols.First .. Symbols.Last loop 295 case Get_Scope (I) is 296 when Sym_Local 297 | Sym_Private => 298 null; 299 when Sym_Global => 300 null; 301 when Sym_Undef => 302 if Get_Used (I) then 303 Handle (I); 304 end if; 305 end case; 306 end loop; 307 end Foreach_Symbol; 308 309 procedure Write_Symbol (S : Symbol) 310 is 311 Sym : Nlist; 312 begin 313 Sym := (N_Strx => Unsigned_32 (Str_Offset), 314 N_Type => 0, 315 N_Sect => 0, 316 N_Desc => 0, 317 N_Value => Addr_T (Get_Symbol_Value (S))); 318 Str_Offset := Str_Offset + Get_Symbol_Name_Length (S) + 1; 319 if Get_Scope (S) = Sym_Undef then 320 Sym.N_Type := N_Undf; 321 else 322 if Get_Scope (S) = Sym_Global then 323 Sym.N_Type := N_Sect + N_Ext; 324 else 325 Sym.N_Type := N_Sect; 326 end if; 327 Sym.N_Sect := Unsigned_8 (Get_Section (S).Number); 328 Sym.N_Value := Sym.N_Value + Addr_T (Get_Section (S).Vaddr); 329 end if; 330 Xwrite (Sym'Address, Nlist_Size); 331 end Write_Symbol; 332 333 procedure Write_String (Sym : Symbol) 334 is 335 Str : constant String := Get_Symbol_Name (Sym) & ASCII.NUL; 336 begin 337 Xwrite (Str'Address, Str'Length); 338 end Write_String; 339 340 procedure Write_All_Symbols is new 341 Foreach_Symbol (Write_Symbol); 342 procedure Write_All_Strings is new 343 Foreach_Symbol (Write_String); 344 begin 345 Str_Offset := 0; 346 347 Write_All_Symbols; 348 Write_All_Strings; 349 end; 350 end Write; 351 352end Binary_File.Macho; 353