|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 18432 (0x4800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, procedure Build_Interchange_Package_Body, seg_020ba3, separate Rpc_Io
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
with Map_Generic;
with Lrm_Utilities;
separate (Rpc_Io)
procedure Build_Interchange_Package_Body (From_Db : Analysis.Database;
Named_With_Root : String;
In_File : Io.File_Type) is
use Rpc_Conventions;
Iter : Analysis.Unique_Type_Iterator;
Decl : Analysis.Type_Decl;
package Ada_Decl_Maps is new Map_Generic (Size => 1024,
Domain_Type => Ada.Declaration,
Range_Type => Boolean,
Hash => Lrm_Utilities.Hash);
Type_Decls_Table : Ada_Decl_Maps.Map;
function Stream_Formal_Name (Kind : Interchange_Kind) return String is
begin
case Kind is
when Put =>
return "Into";
when Get =>
return "From";
end case;
end Stream_Formal_Name;
procedure Register (This_Type_Decl : Ada.Declaration) is
Range_Variable : Boolean := False;
begin
Ada_Decl_Maps.Define (The_Map => Type_Decls_Table,
D => This_Type_Decl,
R => Range_Variable,
Trap_Multiples => False);
end Register;
function Is_New (This_Type_Decl : Ada.Declaration) return Boolean is
Found : Boolean;
Range_Variable : Boolean := False;
begin
Ada_Decl_Maps.Find (The_Map => Type_Decls_Table,
D => This_Type_Decl,
R => Range_Variable,
Success => Found);
return not Found;
end Is_New;
procedure Put (Line : String; Line_Feeds : Natural := 0) is
begin
Io.Put (In_File, Line);
if Line_Feeds > 0 then
Io.New_Line (File => In_File,
Spacing => Io.Positive_Count (Line_Feeds));
end if;
end Put;
procedure Put_Body_Start (Decl : Ada.Element;
Make_Null : Boolean := False;
Kind : Interchange_Kind;
Internal_Comment : String := "") is
procedure Put_Guts is
begin
Put (Ada_Io.Make_Begin);
if Internal_Comment /= "" then
Put (" -- " & Internal_Comment, 2);
end if;
if Make_Null then
Put ("[statement]", 1);
end if;
end Put_Guts;
begin
case Kind is
when Put =>
Put (Ascii.Lf & Ascii.Lf &
Ada_Io.Make_Procedure
(Name => "Put",
Kind => Ada_Io.Body_Part,
Parameters_Image =>
"Into : Transport_Stream.Stream_Id; " & Ascii.Lf &
"Data : " & Analysis.Reference (Decl)));
Put_Guts;
when Get =>
if Is_Constrained (Decl) then
Put (Ascii.Lf & Ascii.Lf &
Ada_Io.Make_Procedure
(Name => "Get",
Kind => Ada_Io.Body_Part,
Parameters_Image =>
"From : Transport_Stream.Stream_Id; " &
Ascii.Lf & "Data : out " &
Analysis.Reference (Decl)));
Put_Guts;
else
Put (Ascii.Lf & Ascii.Lf &
Ada_Io.Make_Function
(Name => "Get",
Kind => Ada_Io.Body_Part,
Parameters_Image =>
"From : Transport_Stream.Stream_Id",
Return_Expression => Analysis.Reference (Decl)));
Put_Guts;
end if;
end case;
end Put_Body_Start;
procedure Put_Null_Bodies (Decl : Ada.Element;
Internal_Comment : String := "") is
begin
for Kind in Interchange_Kind loop
Put_Body_Start (Decl, True, Kind, Internal_Comment);
Put (Ada_Io.Make_End, 1);
end loop;
end Put_Null_Bodies;
function Discrete_Root (Decl : Ada.Declaration) return String is
begin
return "Discrete_" & Analysis.Name (Decl);
end Discrete_Root;
function Discrete_Instance (Decl : Ada.Declaration) return String is
begin
return Rpc_Names.Interchange_Package (Root => Discrete_Root (Decl));
end Discrete_Instance;
procedure Traverse (Type_Decl : Ada.Declaration);
procedure Put_Code_For_Array_Type
(Array_Type_Decl : Ada.Declaration;
Array_Type_Def : Ada.Element) is separate;
procedure Traverse (Type_Decl : Ada.Declaration) is
Type_Def : Ada.Element := Decls.Type_Specification (Type_Decl);
Ground_Type_Def : Ada.Element := Types.Ground_Type (Type_Def);
Base_Type_Decl : Ada.Declaration :=
Decls.Enclosing_Declaration
(Types.Base_Type (Decls.Type_Specification (Type_Decl)));
Base_Type_Def : Ada.Element :=
Decls.Type_Specification (Base_Type_Decl);
Comp_Iter : Ada.Element_Iterator;
Component : Ada.Element;
Comp_Type : Ada.Element;
begin
if Is_New (Base_Type_Decl) and not Is_Predefined (Base_Type_Decl) then
Register (Base_Type_Decl);
case Types.Kind (Base_Type_Def) is
when Types.A_Subtype_Indication |
Types.An_Integer_Type_Definition |
Types.A_Float_Type_Definition =>
raise Program_Error;
when Types.An_Enumeration_Type_Definition =>
Put (Ascii.Lf & "package " &
Discrete_Instance (Base_Type_Decl) &
" is new Transport_Interchange.Discrete (" &
Analysis.Reference (Base_Type_Decl) & ");", 2);
for Kind in Interchange_Kind loop
Put_Body_Start (Base_Type_Decl,
Kind => Kind,
Internal_Comment => "");
Put (Make_Interchange_Call
(Data_Name => "Data",
Data_Conversion => "",
Stream_Name => Stream_Formal_Name (Kind),
Root_Name => Discrete_Root (Base_Type_Decl),
Data_Type => Base_Type_Decl,
Kind => Kind), 1);
Put (Ada_Io.Make_End);
end loop;
when Types.An_Array_Type_Definition =>
Put_Code_For_Array_Type (Array_Type_Decl => Base_Type_Decl,
Array_Type_Def => Base_Type_Def);
when Types.A_Record_Type_Definition =>
Comp_Iter := Types.Record_Components (Base_Type_Def);
if Types.Is_Discriminated (Base_Type_Def) then
Put_Null_Bodies
(Base_Type_Decl,
Internal_Comment =>
"Interchange of discriminated record types not yet implemented");
else
Comp_Iter := Types.Record_Components (Base_Type_Def);
while not Ada.Done (Comp_Iter) loop
Component := Ada.Value (Comp_Iter);
Comp_Type := Decls.Enclosing_Declaration
(Ada.Definition (Decls.Object_Type
(Component)));
Traverse (Comp_Type);
Ada.Next (Comp_Iter);
end loop;
Ada.Reset (Comp_Iter);
for Kind in Interchange_Kind loop
Put_Body_Start (Base_Type_Decl,
Kind => Kind,
Internal_Comment => "");
while not Ada.Done (Comp_Iter) loop
Component := Ada.Value (Comp_Iter);
Comp_Type := Decls.Enclosing_Declaration
(Ada.Definition
(Decls.Object_Type
(Component)));
if Is_Constrained (Comp_Type) or Kind = Put then
Put
(Make_Interchange_Call
(Data_Name =>
"Data." & Decls.Name (Component),
Data_Conversion =>
Predefined_Interchange_Conversion
(Comp_Type),
Stream_Name =>
Stream_Formal_Name (Kind),
Root_Name => Named_With_Root,
Data_Type => Comp_Type,
Kind => Kind),
1);
else
Put
(Ada_Io.Make_Assignment
(Name =>
"Data." & Decls.Name (Component),
Expression =>
Make_Interchange_Call
(Data_Name =>
"Data." &
Decls.Name (Component),
Data_Conversion =>
Predefined_Interchange_Conversion
(Comp_Type),
Stream_Name =>
Stream_Formal_Name (Kind),
Root_Name => Named_With_Root,
Data_Type => Comp_Type,
Kind => Kind)));
end if;
Ada.Next (Comp_Iter);
end loop;
Put (Ada_Io.Make_End);
Ada.Reset (Comp_Iter);
end loop;
end if;
when Types.A_Derived_Type_Definition =>
Traverse (Decls.Enclosing_Declaration (Ground_Type_Def));
for Kind in Interchange_Kind loop
Put_Body_Start (Base_Type_Decl,
Kind => Kind,
Internal_Comment => "");
Put (Make_Interchange_Call
(Data_Name => "Data",
Data_Conversion =>
Analysis.Reference
(Decls.Enclosing_Declaration
(Ground_Type_Def)),
Stream_Name => Stream_Formal_Name (Kind),
Root_Name => Named_With_Root,
Data_Type => Base_Type_Decl,
Kind => Kind), 1);
Put (Ada_Io.Make_End);
end loop;
when Types.A_Fixed_Type_Definition =>
Put_Null_Bodies
(Base_Type_Decl,
Internal_Comment =>
"Interchange of fixed types not yet implemented");
when Types.A_Task_Type_Definition =>
Put_Null_Bodies
(Base_Type_Decl,
Internal_Comment =>
"Interchange of task types may be impossible");
when Types.An_Access_Type_Definition =>
Put_Null_Bodies
(Base_Type_Decl,
Internal_Comment =>
"Interchange of access types may not be possible");
when Types.A_Private_Type_Definition ..
Types.A_Limited_Private_Type_Definition =>
Put_Null_Bodies
(Base_Type_Decl,
Internal_Comment =>
"Interchange of private types requires special attention");
when Types.Not_A_Type_Definition =>
raise Program_Error;
end case;
end if;
end Traverse;
begin
Put (Ada_Io.Make_With_Clause ("Interchange"));
Put (Ada_Io.Make_With_Clause ("Transport_Interchange"));
Put (Ada_Io.Make_Package (Rpc_Names.Interchange_Package (Named_With_Root),
Ada_Io.Body_Part), 1);
Analysis.Init (From_Db, Iter);
Ada_Decl_Maps.Initialize (Type_Decls_Table);
while not Analysis.Done (Iter) loop
Decl := Analysis.Decl (Iter);
Traverse (Decl);
Analysis.Next (Iter);
end loop;
Put (Ada_Io.Make_End);
end Build_Interchange_Package_Body;
nblk1=11
nid=0
hdr6=22
[0x00] rec0=1e rec1=00 rec2=01 rec3=020
[0x01] rec0=1a rec1=00 rec2=02 rec3=01a
[0x02] rec0=00 rec1=00 rec2=11 rec3=012
[0x03] rec0=1a rec1=00 rec2=03 rec3=01e
[0x04] rec0=14 rec1=00 rec2=04 rec3=040
[0x05] rec0=19 rec1=00 rec2=05 rec3=08c
[0x06] rec0=18 rec1=00 rec2=06 rec3=03a
[0x07] rec0=00 rec1=00 rec2=10 rec3=014
[0x08] rec0=14 rec1=00 rec2=07 rec3=058
[0x09] rec0=13 rec1=00 rec2=08 rec3=018
[0x0a] rec0=12 rec1=00 rec2=09 rec3=072
[0x0b] rec0=10 rec1=00 rec2=0a rec3=02e
[0x0c] rec0=0f rec1=00 rec2=0b rec3=06e
[0x0d] rec0=15 rec1=00 rec2=0c rec3=01a
[0x0e] rec0=14 rec1=00 rec2=0d rec3=00a
[0x0f] rec0=15 rec1=00 rec2=0e rec3=08a
[0x10] rec0=1b rec1=00 rec2=0f rec3=000
tail 0x2171d2e2e838d450c9a2d 0x42a00088462061e03