gcc/ada/symbols-processing-vms-ia64.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                    S Y M B O L S . P R O C E S S I N G                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2006, 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 2,  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 COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 --  This is the VMS/IA64 version of this package
  28
  29 with Ada.IO_Exceptions;
  30
  31 with Ada.Unchecked_Deallocation;
  32
  33 separate (Symbols)
  34 package body Processing is
  35
  36    type String_Array is array (Positive range <>) of String_Access;
  37    type Strings_Ptr is access String_Array;
  38
  39    procedure Free is
  40      new Ada.Unchecked_Deallocation (String_Array, Strings_Ptr);
  41
  42    type Section_Header is record
  43       Shname   : Integer;
  44       Shtype   : Integer;
  45       Shoffset : Integer;
  46       Shsize   : Integer;
  47       Shlink   : Integer;
  48    end record;
  49
  50    type Section_Header_Array is array (Natural range <>) of Section_Header;
  51    type Section_Header_Ptr is access Section_Header_Array;
  52
  53    procedure Free is
  54      new Ada.Unchecked_Deallocation (Section_Header_Array, Section_Header_Ptr);
  55
  56    -------------
  57    -- Process --
  58    -------------
  59
  60    procedure Process
  61      (Object_File : String;
  62       Success     : out Boolean)
  63    is
  64       B : Byte;
  65       H : Integer;
  66       W : Integer;
  67
  68       Str : String (1 .. 1000) := (others => ' ');
  69       Str_Last : Natural;
  70
  71       Strings : Strings_Ptr;
  72
  73       Shoff : Integer;
  74       Shnum : Integer;
  75       Shentsize : Integer;
  76
  77       Shname   : Integer;
  78       Shtype   : Integer;
  79       Shoffset : Integer;
  80       Shsize   : Integer;
  81       Shlink   : Integer;
  82
  83       Symtab_Index       : Natural := 0;
  84       String_Table_Index : Natural := 0;
  85
  86       End_Symtab : Integer;
  87
  88       Stname  : Integer;
  89       Stinfo  : Character;
  90       Sttype  : Integer;
  91       Stbind  : Integer;
  92       Stshndx : Integer;
  93
  94       Section_Headers : Section_Header_Ptr;
  95
  96       Offset : Natural := 0;
  97       OK     : Boolean := True;
  98
  99       procedure Get_Byte (B : out Byte);
 100       procedure Get_Half (H : out Integer);
 101       procedure Get_Word (W : out Integer);
 102       procedure Reset;
 103       --  All the above require comments ???
 104
 105       --------------
 106       -- Get_Byte --
 107       --------------
 108
 109       procedure Get_Byte (B : out Byte) is
 110       begin
 111          Byte_IO.Read (File, B);
 112          Offset := Offset + 1;
 113       end Get_Byte;
 114
 115       --------------
 116       -- Get_Half --
 117       --------------
 118
 119       procedure Get_Half (H : out Integer) is
 120          C1, C2 : Character;
 121       begin
 122          Get_Byte (C1); Get_Byte (C2);
 123          H :=
 124            Integer'(Character'Pos (C2)) * 256 + Integer'(Character'Pos (C1));
 125       end Get_Half;
 126
 127       --------------
 128       -- Get_Word --
 129       --------------
 130
 131       procedure Get_Word (W : out Integer) is
 132          H1, H2 : Integer;
 133       begin
 134          Get_Half (H1); Get_Half (H2);
 135          W := H2 * 256 * 256 + H1;
 136       end Get_Word;
 137
 138       -----------
 139       -- Reset --
 140       -----------
 141
 142       procedure Reset is
 143       begin
 144          Offset := 0;
 145          Byte_IO.Reset (File);
 146       end Reset;
 147
 148    --  Start of processing for Process
 149
 150    begin
 151       --  Open the object file with Byte_IO. Return with Success = False if
 152       --  this fails.
 153
 154       begin
 155          Open (File, In_File, Object_File);
 156       exception
 157          when others =>
 158             Put_Line
 159               ("*** Unable to open object file """ & Object_File & """");
 160             Success := False;
 161             return;
 162       end;
 163
 164       --  Assume that the object file has a correct format
 165
 166       Success := True;
 167
 168       --  Skip ELF identification
 169
 170       while Offset < 16 loop
 171          Get_Byte (B);
 172       end loop;
 173
 174       --  Skip e_type
 175
 176       Get_Half (H);
 177
 178       --  Skip e_machine
 179
 180       Get_Half (H);
 181
 182       --  Skip e_version
 183
 184       Get_Word (W);
 185
 186       --  Skip e_entry
 187
 188       for J in 1 .. 8 loop
 189          Get_Byte (B);
 190       end loop;
 191
 192       --  Skip e_phoff
 193
 194       for J in 1 .. 8 loop
 195          Get_Byte (B);
 196       end loop;
 197
 198       Get_Word (Shoff);
 199
 200       --  Skip upper half of Shoff
 201
 202       for J in 1 .. 4 loop
 203          Get_Byte (B);
 204       end loop;
 205
 206       --  Skip e_flags
 207
 208       Get_Word (W);
 209
 210       --  Skip e_ehsize
 211
 212       Get_Half (H);
 213
 214       --  Skip e_phentsize
 215
 216       Get_Half (H);
 217
 218       --  Skip e_phnum
 219
 220       Get_Half (H);
 221
 222       Get_Half (Shentsize);
 223
 224       Get_Half (Shnum);
 225
 226       Section_Headers := new Section_Header_Array (0 .. Shnum - 1);
 227
 228       --  Go to Section Headers
 229
 230       while Offset < Shoff loop
 231          Get_Byte (B);
 232       end loop;
 233
 234       --  Reset Symtab_Index
 235
 236       Symtab_Index := 0;
 237
 238       for J in Section_Headers'Range loop
 239
 240          --  Get the data for each Section Header
 241
 242          Get_Word (Shname);
 243          Get_Word (Shtype);
 244
 245          for K in 1 .. 16 loop
 246             Get_Byte (B);
 247          end loop;
 248
 249          Get_Word (Shoffset);
 250          Get_Word (W);
 251
 252          Get_Word (Shsize);
 253          Get_Word (W);
 254
 255          Get_Word (Shlink);
 256
 257          while (Offset - Shoff) mod Shentsize /= 0 loop
 258             Get_Byte (B);
 259          end loop;
 260
 261          --  If this is the Symbol Table Section Header, record its index
 262
 263          if Shtype = 2 then
 264             Symtab_Index := J;
 265          end if;
 266
 267          Section_Headers (J) := (Shname, Shtype, Shoffset, Shsize, Shlink);
 268       end loop;
 269
 270       if Symtab_Index = 0 then
 271          Success := False;
 272          return;
 273       end if;
 274
 275       End_Symtab :=
 276         Section_Headers (Symtab_Index).Shoffset +
 277         Section_Headers (Symtab_Index).Shsize;
 278
 279       String_Table_Index := Section_Headers (Symtab_Index).Shlink;
 280       Strings :=
 281         new String_Array (1 .. Section_Headers (String_Table_Index).Shsize);
 282
 283       --  Go get the String Table section for the Symbol Table
 284
 285       Reset;
 286
 287       while Offset < Section_Headers (String_Table_Index).Shoffset loop
 288          Get_Byte (B);
 289       end loop;
 290
 291       Offset := 0;
 292
 293       Get_Byte (B);  --  zero
 294
 295       while Offset < Section_Headers (String_Table_Index).Shsize loop
 296          Str_Last := 0;
 297
 298          loop
 299             Get_Byte (B);
 300             if B /= ASCII.NUL then
 301                Str_Last := Str_Last + 1;
 302                Str (Str_Last) := B;
 303
 304             else
 305                Strings (Offset - Str_Last - 1) :=
 306                  new String'(Str (1 .. Str_Last));
 307                exit;
 308             end if;
 309          end loop;
 310       end loop;
 311
 312       --  Go get the Symbol Table
 313
 314       Reset;
 315
 316       while Offset < Section_Headers (Symtab_Index).Shoffset loop
 317          Get_Byte (B);
 318       end loop;
 319
 320       while Offset < End_Symtab loop
 321          Get_Word (Stname);
 322          Get_Byte (Stinfo);
 323          Get_Byte (B);
 324          Get_Half (Stshndx);
 325          for J in 1 .. 4 loop
 326             Get_Word (W);
 327          end loop;
 328
 329          Sttype := Integer'(Character'Pos (Stinfo)) mod 16;
 330          Stbind := Integer'(Character'Pos (Stinfo)) / 16;
 331
 332          if (Sttype = 1 or else Sttype = 2)
 333               and then Stbind /= 0
 334               and then Stshndx /= 0
 335          then
 336             --  Check if this is a symbol from a generic body
 337
 338             OK := True;
 339
 340             for J in Strings (Stname)'First .. Strings (Stname)'Last - 2 loop
 341                if Strings (Stname) (J) = 'G'
 342                  and then Strings (Stname) (J + 1) = 'P'
 343                  and then Strings (Stname) (J + 2) in '0' .. '9'
 344                then
 345                   OK := False;
 346                   exit;
 347                end if;
 348             end loop;
 349
 350             if OK then
 351                declare
 352                   S_Data : Symbol_Data;
 353                begin
 354                   S_Data.Name := new String'(Strings (Stname).all);
 355
 356                   if Sttype = 1 then
 357                      S_Data.Kind := Data;
 358
 359                   else
 360                      S_Data.Kind := Proc;
 361                   end if;
 362
 363                   --  Put the new symbol in the table
 364
 365                   Symbol_Table.Increment_Last (Complete_Symbols);
 366                   Complete_Symbols.Table
 367                     (Symbol_Table.Last (Complete_Symbols)) := S_Data;
 368                end;
 369             end if;
 370          end if;
 371       end loop;
 372
 373       --  The object file has been processed, close it
 374
 375       Close (File);
 376
 377       --  Free the allocated memory
 378
 379       Free (Section_Headers);
 380
 381       for J in Strings'Range loop
 382          if Strings (J) /= null then
 383             Free (Strings (J));
 384          end if;
 385       end loop;
 386
 387       Free (Strings);
 388
 389    exception
 390       --  For any exception, output an error message, close the object file
 391       --  and return with Success = False.
 392
 393       when Ada.IO_Exceptions.End_Error =>
 394          Close (File);
 395
 396       when X : others =>
 397          Put_Line ("unexpected exception raised while processing """
 398                    & Object_File & """");
 399          Put_Line (Exception_Information (X));
 400          Close (File);
 401          Success := False;
 402    end Process;
 403
 404 end Processing;