symbols-vms-alpha.adb [plain text]
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Sequential_IO;
with Ada.Text_IO; use Ada.Text_IO;
package body Symbols is
Case_Sensitive : constant String := "case_sensitive=";
Symbol_Vector : constant String := "SYMBOL_VECTOR=(";
Equal_Data : constant String := "=DATA)";
Equal_Procedure : constant String := "=PROCEDURE)";
Gsmatch : constant String := "gsmatch=equal,";
Symbol_File_Name : String_Access := null;
Sym_Policy : Policy := Autonomous;
Major_ID : Integer := 1;
Soft_Major_ID : Boolean := True;
Minor_ID : Natural := 0;
Soft_Minor_ID : Boolean := True;
subtype Byte is Character;
package Byte_IO is new Ada.Sequential_IO (Byte);
use Byte_IO;
type Number is mod 2**16;
GSD : constant Number := 10;
C_SYM : constant Number := 1;
V_DEF_Mask : constant Number := 2**1;
V_NORM_Mask : constant Number := 2**6;
File : Byte_IO.File_Type;
B : Byte;
Number_Of_Characters : Natural := 0;
Code : Number := 0;
Length : Natural := 0;
Dummy : Number;
Nchars : Natural := 0;
Flags : Number := 0;
Symbol : String (1 .. 255);
LSymb : Natural;
function Equal (Left, Right : Symbol_Data) return Boolean;
procedure Get (N : out Number);
procedure Get (N : out Natural);
function Image (N : Integer) return String;
function Equal (Left, Right : Symbol_Data) return Boolean is
begin
return Left.Name /= null and then
Right.Name /= null and then
Left.Name.all = Right.Name.all and then
Left.Kind = Right.Kind and then
Left.Present = Right.Present;
end Equal;
procedure Get (N : out Number) is
C : Byte;
LSByte : Number;
begin
Read (File, C);
LSByte := Byte'Pos (C);
Read (File, C);
N := LSByte + (256 * Byte'Pos (C));
end Get;
procedure Get (N : out Natural) is
Result : Number;
begin
Get (Result);
N := Natural (Result);
end Get;
function Image (N : Integer) return String is
Result : constant String := N'Img;
begin
if Result (Result'First) = ' ' then
return Result (Result'First + 1 .. Result'Last);
else
return Result;
end if;
end Image;
procedure Initialize
(Symbol_File : String;
Reference : String;
Symbol_Policy : Policy;
Quiet : Boolean;
Version : String;
Success : out Boolean)
is
File : Ada.Text_IO.File_Type;
Line : String (1 .. 1_000);
Last : Natural;
begin
Symbol_File_Name := new String'(Symbol_File);
Sym_Policy := Symbol_Policy;
if Version = "" then
Major_ID := 1;
Soft_Major_ID := True;
else
begin
Major_ID := Integer'Value (Version);
Soft_Major_ID := False;
if Major_ID <= 0 then
raise Constraint_Error;
end if;
exception
when Constraint_Error =>
if not Quiet then
Put_Line ("Version """ & Version & """ is illegal.");
Put_Line ("On VMS, version must be a positive number");
end if;
Success := False;
return;
end;
end if;
Minor_ID := 0;
Soft_Minor_ID := Sym_Policy /= Autonomous;
Symbol_Table.Set_Last (Original_Symbols, 0);
Symbol_Table.Set_Last (Complete_Symbols, 0);
Success := True;
if Sym_Policy /= Autonomous then
case Sym_Policy is
when Autonomous =>
null;
when Compliant | Controlled =>
begin
Open (File, In_File, Reference);
exception
when Ada.Text_IO.Name_Error =>
Success := False;
return;
when X : others =>
if not Quiet then
Put_Line ("could not open """ & Reference & """");
Put_Line (Exception_Message (X));
end if;
Success := False;
return;
end;
when Restricted =>
begin
Open (File, In_File, Symbol_File);
exception
when Ada.Text_IO.Name_Error =>
Success := False;
return;
when X : others =>
if not Quiet then
Put_Line ("could not open """ & Symbol_File & """");
Put_Line (Exception_Message (X));
end if;
Success := False;
return;
end;
end case;
while not End_Of_File (File) loop
Get_Line (File, Line, Last);
if Last = 0 then
null;
elsif Last > Case_Sensitive'Length
and then Line (1 .. Case_Sensitive'Length) = Case_Sensitive
then
null;
elsif Last > Symbol_Vector'Length
and then Line (1 .. Symbol_Vector'Length) = Symbol_Vector
then
if Last > Symbol_Vector'Length + Equal_Data'Length and then
Line (Last - Equal_Data'Length + 1 .. Last) = Equal_Data
then
Symbol_Table.Increment_Last (Original_Symbols);
Original_Symbols.Table
(Symbol_Table.Last (Original_Symbols)) :=
(Name =>
new String'(Line (Symbol_Vector'Length + 1 ..
Last - Equal_Data'Length)),
Kind => Data,
Present => True);
elsif Last > Symbol_Vector'Length + Equal_Procedure'Length
and then
Line (Last - Equal_Procedure'Length + 1 .. Last) =
Equal_Procedure
then
Symbol_Table.Increment_Last (Original_Symbols);
Original_Symbols.Table
(Symbol_Table.Last (Original_Symbols)) :=
(Name =>
new String'(Line (Symbol_Vector'Length + 1 ..
Last - Equal_Procedure'Length)),
Kind => Proc,
Present => True);
else
if not Quiet then
Put_Line ("symbol file """ & Reference &
""" is incorrectly formatted:");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
Close (File);
Success := False;
return;
end if;
elsif Last > Gsmatch'Length
and then Line (1 .. Gsmatch'Length) = Gsmatch
then
declare
Start : Positive := Gsmatch'Length + 1;
Finish : Positive := Start;
OK : Boolean := True;
ID : Integer;
begin
loop
if Line (Finish) not in '0' .. '9'
or else Finish >= Last - 1
then
OK := False;
exit;
end if;
exit when Line (Finish + 1) = ',';
Finish := Finish + 1;
end loop;
if OK then
ID := Integer'Value (Line (Start .. Finish));
OK := ID /= 0;
if Soft_Major_ID then
Major_ID := ID;
elsif Major_ID /= ID then
Soft_Minor_ID := False;
end if;
Start := Finish + 2;
Finish := Start;
loop
if Line (Finish) not in '0' .. '9' then
OK := False;
exit;
end if;
exit when Finish = Last;
Finish := Finish + 1;
end loop;
if OK and then Soft_Minor_ID then
Minor_ID := Integer'Value (Line (Start .. Finish));
end if;
end if;
if not OK then
if not Quiet then
Put_Line ("symbol file """ & Reference &
""" is incorrectly formatted");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
Close (File);
Success := False;
return;
end if;
end;
else
if not Quiet then
Put_Line ("unexpected line in symbol file """ &
Reference & """");
Put_Line ("""" & Line (1 .. Last) & """");
end if;
Close (File);
Success := False;
return;
end if;
end loop;
Close (File);
end if;
end Initialize;
procedure Process
(Object_File : String;
Success : out Boolean)
is
begin
begin
Open (File, In_File, Object_File);
exception
when others =>
Put_Line
("*** Unable to open object file """ & Object_File & """");
Success := False;
return;
end;
Success := True;
while not End_Of_File (File) loop
Get (Code);
Get (Number_Of_Characters);
Number_Of_Characters := Number_Of_Characters - 4;
if Code /= GSD then
for J in 1 .. Number_Of_Characters loop
Read (File, B);
end loop;
else
Get (Dummy);
Get (Dummy);
Number_Of_Characters := Number_Of_Characters - 4;
loop
Get (Code);
Get (Nchars);
Get (Dummy);
Get (Flags);
Number_Of_Characters := Number_Of_Characters - 8;
Nchars := Nchars - 8;
if Code = C_SYM and then ((Flags and V_DEF_Mask) /= 0) then
for J in 1 .. 25 loop
Read (File, B);
Nchars := Nchars - 1;
Number_Of_Characters := Number_Of_Characters - 1;
end loop;
Length := Byte'Pos (B);
LSymb := 0;
for J in 1 .. Nchars loop
Read (File, B);
Number_Of_Characters := Number_Of_Characters - 1;
if Length > 0 then
LSymb := LSymb + 1;
Symbol (LSymb) := B;
Length := Length - 1;
end if;
end loop;
declare
S_Data : Symbol_Data;
begin
S_Data.Name := new String'(Symbol (1 .. LSymb));
if (Flags and V_NORM_Mask) = 0 then
S_Data.Kind := Data;
else
S_Data.Kind := Proc;
end if;
Symbol_Table.Increment_Last (Complete_Symbols);
Complete_Symbols.Table
(Symbol_Table.Last (Complete_Symbols)) := S_Data;
end;
else
for J in 1 .. Nchars loop
Read (File, B);
Number_Of_Characters := Number_Of_Characters - 1;
end loop;
end if;
exit when Number_Of_Characters = 0;
end loop;
end if;
end loop;
Close (File);
exception
when X : others =>
Put_Line ("unexpected exception raised while processing """
& Object_File & """");
Put_Line (Exception_Information (X));
Close (File);
Success := False;
end Process;
procedure Finalize
(Quiet : Boolean;
Success : out Boolean)
is
File : Ada.Text_IO.File_Type;
S_Data : Symbol_Data;
Cur : Positive := 1;
Found : Boolean;
begin
if Symbol_File_Name = null then
Success := False;
else
Cur := 1;
for Index_1 in 1 .. Symbol_Table.Last (Original_Symbols) loop
S_Data := Original_Symbols.Table (Index_1);
Found := False;
First_Object_Loop :
for Index_2 in Cur .. Symbol_Table.Last (Complete_Symbols) loop
if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
Cur := Index_2 + 1;
Complete_Symbols.Table (Index_2).Present := False;
Found := True;
exit First_Object_Loop;
end if;
end loop First_Object_Loop;
if not Found then
Second_Object_Loop :
for Index_2 in 1 .. Cur - 1 loop
if Equal (S_Data, Complete_Symbols.Table (Index_2)) then
Cur := Index_2 + 1;
Complete_Symbols.Table (Index_2).Present := False;
Found := True;
exit Second_Object_Loop;
end if;
end loop Second_Object_Loop;
end if;
if not Found then
if (not Quiet) or else Sym_Policy = Controlled then
Put_Line ("symbol """ & S_Data.Name.all &
""" is no longer present in the object files");
end if;
if Sym_Policy = Controlled or else Sym_Policy = Restricted then
Success := False;
return;
elsif Soft_Minor_ID then
Minor_ID := Minor_ID + 1;
Soft_Minor_ID := False;
end if;
Original_Symbols.Table (Index_1).Present := False;
Free (Original_Symbols.Table (Index_1).Name);
if Soft_Minor_ID then
Minor_ID := Minor_ID + 1;
Soft_Minor_ID := False;
end if;
end if;
end loop;
if Sym_Policy /= Restricted then
for Index in 1 .. Symbol_Table.Last (Complete_Symbols) loop
S_Data := Complete_Symbols.Table (Index);
if S_Data.Present then
if Sym_Policy = Controlled then
Put_Line ("symbol """ & S_Data.Name.all &
""" is not in the reference symbol file");
Success := False;
return;
elsif Soft_Minor_ID then
Minor_ID := Minor_ID + 1;
Soft_Minor_ID := False;
end if;
Symbol_Table.Increment_Last (Original_Symbols);
Original_Symbols.Table
(Symbol_Table.Last (Original_Symbols)) := S_Data;
Complete_Symbols.Table (Index).Present := False;
end if;
end loop;
Create (File, Ada.Text_IO.Out_File, Symbol_File_Name.all);
Put (File, Case_Sensitive);
Put_Line (File, "yes");
for Index in 1 .. Symbol_Table.Last (Original_Symbols) loop
if Original_Symbols.Table (Index).Present then
Put (File, Symbol_Vector);
Put (File, Original_Symbols.Table (Index).Name.all);
if Original_Symbols.Table (Index).Kind = Data then
Put_Line (File, Equal_Data);
else
Put_Line (File, Equal_Procedure);
end if;
Free (Original_Symbols.Table (Index).Name);
end if;
end loop;
Put (File, Case_Sensitive);
Put_Line (File, "NO");
Put (File, Gsmatch);
Put (File, Image (Major_ID));
Put (File, ',');
Put_Line (File, Image (Minor_ID));
Close (File);
Symbol_Table.Set_Last (Original_Symbols, 0);
Symbol_Table.Set_Last (Complete_Symbols, 0);
Free (Symbol_File_Name);
end if;
Success := True;
end if;
exception
when X : others =>
Put_Line ("unexpected exception raised while finalizing """
& Symbol_File_Name.all & """");
Put_Line (Exception_Information (X));
Success := False;
end Finalize;
end Symbols;