|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 9087 (0x237f)
Types: TextFile
Names: »B«
└─⟦180fe333a⟧ Bits:30000405 8mm tape, Rational 1000, SW CATALOG, 10_20_0
└─⟦180fe333a⟧ Bits:30000537 8mm tape, Rational 1000, SW Catalog 10_20_0
└─⟦5cb1d1d7f⟧ »DATA«
└─⟦3b1ee7bd8⟧
└─⟦this⟧
with Io;
with Directory;
with Diana;
with Diana_Utilities;
with Test_Program_Generation;
with Directory_Tools;
procedure Build_Unit_Test (Subprogram_Declarations : String := "";
Test_Program_Context : String := "") is
package Object renames Directory_Tools.Object;
package Naming renames Directory_Tools.Naming;
package Traversal renames Directory_Tools.Traversal;
package Ada_Object renames Directory_Tools.Ada_Object;
package Any_Object renames Directory_Tools.Any_Object;
package Library_Object renames Directory_Tools.Library_Object;
package Statistics renames Directory_Tools.Statistics;
package Low_Level renames Directory_Tools.Object.Low_Level;
package Gen renames Test_Program_Generation;
Data : Gen.Unit_Test_Data;
Key : Gen.Subprogram_Key;
Found : Boolean := False;
Decls : Object.Iterator :=
Naming.Resolution (Subprogram_Declarations, Objects_Only => False);
This_Object : Object.Handle;
Diana_Decl : Diana.Tree;
Return_Type : Diana.Tree;
Params : Diana_Utilities.Iterator;
A_Param : Diana.Tree;
Param_Type : Diana.Tree;
A_Decl : Object.Handle;
Comp_Unit : Diana.Tree;
Status : Object.Error_Code;
Dir_Object : Directory.Object;
Dir_Stat : Directory.Error_Status;
function Get_Mode (Param : Diana.Tree) return Gen.Mode_Kind is
begin
case Diana_Utilities.Parameter_Mode (Param) is
when Diana_Utilities.In_Mode | Diana_Utilities.Default_In_Mode =>
return Gen.In_Mode;
when Diana_Utilities.Out_Mode =>
return Gen.Out_Mode;
when Diana_Utilities.In_Out_Mode =>
return Gen.In_Out_Mode;
end case;
end Get_Mode;
function Is_Predefined (Node : Diana.Tree) return Boolean is
begin
case Diana_Utilities.Type_Kind (Node) is
when Diana_Utilities.An_Integer_Type_Definition =>
return True;
when Diana_Utilities.A_Float_Type_Definition =>
return True;
when Diana_Utilities.A_Subtype_Indication =>
if Diana_Utilities.Is_Positive (Node) then
return True;
elsif Diana_Utilities.Is_Natural (Node) then
return True;
else
return False;
end if;
when others =>
if Diana_Utilities.Is_Boolean (Node) then
return True;
elsif Diana_Utilities.Is_Character (Node) then
return True;
elsif Diana_Utilities.Is_Duration (Node) then
return True;
elsif Diana_Utilities.Is_Long_Integer (Node) then
return True;
elsif Diana_Utilities.Is_String (Node) then
return True;
else
return False;
end if;
end case;
end Is_Predefined;
function Get_Kind (Node : Diana.Tree) return Gen.Type_Kind is
begin
case Diana_Utilities.Type_Kind (Node) is
when Diana_Utilities.An_Integer_Type_Definition =>
return Gen.An_Integer;
when Diana_Utilities.A_Float_Type_Definition =>
return Gen.A_Float;
when Diana_Utilities.A_Subtype_Indication =>
return Get_Kind (Diana_Utilities.Base_Type (Node));
when others =>
if Diana_Utilities.Is_Boolean (Node) then
return Gen.A_Boolean;
elsif Diana_Utilities.Is_Character (Node) then
return Gen.A_Character;
elsif Diana_Utilities.Is_Duration (Node) then
return Gen.A_Duration;
elsif Diana_Utilities.Is_String (Node) then
return Gen.A_String;
else
return Gen.Other;
end if;
end case;
end Get_Kind;
function Lower_Bound (Constraint : Diana.Tree) return String is
Local : Diana.Tree := Constraint;
begin
loop
case Diana.Kind (Local) is
when Diana.Dn_Subtype =>
Local := Diana.As_Constrained (Local);
when Diana.Dn_Constrained =>
Local := Diana.As_Constraint (Local);
when Diana.Dn_Range =>
Local := Diana.As_Exp1 (Local);
when Diana.Dn_Numeric_Literal =>
return Diana.Image (Diana.Lx_Numrep (Local));
when others =>
return "";
end case;
end loop;
end Lower_Bound;
function Initial_Expression (Param_Type : Diana.Tree) return String is
begin
case Diana_Utilities.Type_Kind (Param_Type) is
when Diana_Utilities.An_Integer_Type_Definition =>
return "0";
when Diana_Utilities.A_Float_Type_Definition =>
return "0.0";
when Diana_Utilities.A_Subtype_Indication =>
return Lower_Bound (Param_Type);
when others =>
if Diana_Utilities.Is_Boolean (Param_Type) then
return "true";
elsif Diana_Utilities.Is_Character (Param_Type) then
return "'A'";
elsif Diana_Utilities.Is_String (Param_Type) then
return """" & """";
else
return "";
end if;
end case;
end Initial_Expression;
function Get_Containing_Package (Node : Diana.Tree) return Object.Handle is
Dir_Stat : Directory.Error_Status;
Comp_Unit : Diana.Tree;
Status : Object.Error_Code;
begin
Directory.Ada.Get_Root (Node, Comp_Unit, Dir_Stat);
return Low_Level.Make_Handle
(Status, The_Name => "", The_Declaration => Comp_Unit);
end Get_Containing_Package;
procedure Register_Parameters (Diana_Decl : Diana.Tree) is
Params : Diana_Utilities.Iterator :=
Diana_Utilities.Parameters (Diana_Decl);
A_Param : Diana.Tree;
Param_Type : Diana.Tree;
Ids : Diana_Utilities.Iterator;
An_Id : Diana.Tree;
Param_Type_Package : Object.Handle;
begin
while not Diana_Utilities.Done (Params) loop
A_Param := Diana_Utilities.Value (Params);
Param_Type := Diana_Utilities.Object_Type (A_Param);
Param_Type_Package := Get_Containing_Package (Param_Type);
Ids := Diana_Utilities.All_Ids (A_Param);
while not Diana_Utilities.Done (Ids) loop
An_Id := Diana_Utilities.Value (Ids);
Gen.Register_Parameter
(Diana_Utilities.Name (An_Id), Get_Kind (Param_Type),
Is_Predefined (Param_Type), Get_Mode (A_Param),
Diana_Utilities.Name (Param_Type),
Naming.Simple_Name (Param_Type_Package),
Initial_Expression (Param_Type), Key, Data);
Diana_Utilities.Next (Ids);
end loop;
Diana_Utilities.Next (Params);
end loop;
end Register_Parameters;
begin
if Object.Is_Bad (Decls) then
Io.Put_Line ("Bad subprogram declaration specifiction");
return;
end if;
Gen.Initialize (Data);
while not Object.Done (Decls) loop
This_Object := Object.Value (Decls);
Low_Level.Get_Declaration (Object.Value (Decls), Diana_Decl, Dir_Stat);
if not Found then
Gen.Register_Test_Package
(Get_Containing_Package (Diana_Decl), Data);
Found := True;
end if;
Diana_Decl := Diana.As_Parent (Diana_Decl);
case Diana_Utilities.Kind (Diana_Decl) is
when Diana_Utilities.A_Function_Declaration =>
Return_Type := Diana_Utilities.Return_Type (Diana_Decl);
Gen.Register_Function
(Obj => This_Object,
Op_Kind => Diana_Utilities.Operator_Kind (Diana_Decl),
Return_Type_Kind => Get_Kind (Return_Type),
Predefined => Is_Predefined (Return_Type),
Return_Type_Name => Diana_Utilities.Name (Return_Type),
Return_Type_Package =>
Naming.Simple_Name
(Get_Containing_Package (Return_Type)),
With_Data => Data,
Key => Key);
Register_Parameters (Diana_Decl);
when Diana_Utilities.A_Procedure_Declaration =>
Gen.Register_Procedure
(Obj => This_Object, With_Data => Data, Key => Key);
Register_Parameters (Diana_Decl);
when others =>
null;
end case;
Object.Next (Decls);
end loop;
Gen.Generate_Unit_Test_Program (Test_Program_Context, Data);
end Build_Unit_Test;