|
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 - downloadIndex: ┃ B T ┃
Length: 25039 (0x61cf)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦49e7f20b9⟧
└─⟦this⟧
with Xlbt_Proc_Var;
use Xlbt_Proc_Var;
with Xlbt_String;
use Xlbt_String;
with Test_Io;
use Test_Io;
package body Exe_100 is
------------------------------------------------------------------------------
-- Test Procedure Variables - for Procedure types
------------------------------------------------------------------------------
--\f
procedure Assert (Hypothesis : Boolean) is
Something_Wrong : exception;
begin
if not Hypothesis then
raise Something_Wrong;
end if;
end Assert;
--\f
function Value return X_String is
A : constant X_String := To_X_String ("x_string");
begin
return A;
end Value;
function Value (Arg : X_String) return Boolean is
begin
return Arg = To_X_String ("x_string");
end Value;
--\f
function Value return Access_Type is
A : Access_Type := new Boolean'(False);
begin
return A;
end Value;
function Out_Value return Access_Type is
A : Access_Type := new Boolean'(True);
begin
return A;
end Out_Value;
function Value (Arg : Access_Type) return Boolean is
begin
return Arg.all = False;
end Value;
function Out_Value (Arg : Access_Type) return Boolean is
begin
return Arg.all = True;
end Out_Value;
--\f
function Value return Enumeration_Type is
A : Enumeration_Type := Enumeration_Type'First;
begin
return A;
end Value;
function Out_Value return Enumeration_Type is
A : Enumeration_Type := Enumeration_Type'Last;
begin
return A;
end Out_Value;
function Value (Arg : Enumeration_Type) return Boolean is
begin
return Arg = Enumeration_Type'First;
end Value;
function Out_Value (Arg : Enumeration_Type) return Boolean is
begin
return Arg = Enumeration_Type'Last;
end Out_Value;
--\f
function Value return Boolean_Type is
A : Boolean_Type := Boolean_Type'First;
begin
return A;
end Value;
function Out_Value return Boolean_Type is
A : Boolean_Type := Boolean_Type'Last;
begin
return A;
end Out_Value;
function Value (Arg : Boolean_Type) return Boolean is
begin
return Arg = Boolean_Type'First;
end Value;
function Out_Value (Arg : Boolean_Type) return Boolean is
begin
return Arg = Boolean_Type'Last;
end Out_Value;
--\f
function Value return Fixed_Type is
A : Fixed_Type := Fixed_Type'First;
begin
return A;
end Value;
function Out_Value return Fixed_Type is
A : Fixed_Type := Fixed_Type'Last;
begin
return A;
end Out_Value;
function Value (Arg : Fixed_Type) return Boolean is
begin
return Arg = Fixed_Type'First;
end Value;
function Out_Value (Arg : Fixed_Type) return Boolean is
begin
return Arg = Fixed_Type'Last;
end Out_Value;
--\f
function Value return Float_Type is
A : Float_Type := Float_Type'First;
begin
return A;
end Value;
function Out_Value return Float_Type is
A : Float_Type := Float_Type'Last;
begin
return A;
end Out_Value;
function Value (Arg : Float_Type) return Boolean is
begin
return Arg = Float_Type'First;
end Value;
function Out_Value (Arg : Float_Type) return Boolean is
begin
return Arg = Float_Type'Last;
end Out_Value;
--\f
function Value return Constrained_Record_Type is
A : Constrained_Record_Type := (S => "aaaaaaaaaa");
begin
return A;
end Value;
function Out_Value return Constrained_Record_Type is
A : Constrained_Record_Type := (S => "zzzzzzzzzz");
begin
return A;
end Out_Value;
function Value (Arg : Constrained_Record_Type) return Boolean is
begin
return Arg.S = "aaaaaaaaaa";
end Value;
function Out_Value (Arg : Constrained_Record_Type) return Boolean is
begin
return Arg.S = "zzzzzzzzzz";
end Out_Value;
--\f
function Value return Unconstrained_Record_Type is
A : Unconstrained_Record_Type (10) := (D => 10, S => "aaaaaaaaaa");
begin
return A;
end Value;
function Out_Value return Unconstrained_Record_Type is
A : Unconstrained_Record_Type (10) := (D => 10, S => "zzzzzzzzzz");
begin
return A;
end Out_Value;
function Value (Arg : Unconstrained_Record_Type) return Boolean is
begin
return Arg.S = "aaaaaaaaaa";
end Value;
function Out_Value (Arg : Unconstrained_Record_Type) return Boolean is
begin
return Arg.S = "zzzzzzzzzz";
end Out_Value;
--\f
function Value return Constrained_String_Type is
A : Constrained_String_Type := "aaaaaaaaaa";
begin
return A;
end Value;
function Out_Value return Constrained_String_Type is
A : Constrained_String_Type := "zzzzzzzzzz";
begin
return A;
end Out_Value;
function Value (Arg : Constrained_String_Type) return Boolean is
begin
return Arg = "aaaaaaaaaa";
end Value;
function Out_Value (Arg : Constrained_String_Type) return Boolean is
begin
return Arg = "zzzzzzzzzz";
end Out_Value;
--\f
function Value return Unconstrained_String_Type is
A : Unconstrained_String_Type (1 .. 10) := "aaaaaaaaaa";
begin
return A;
end Value;
function Out_Value return Unconstrained_String_Type is
A : Unconstrained_String_Type (1 .. 10) := "zzzzzzzzzz";
begin
return A;
end Out_Value;
function Value (Arg : Unconstrained_String_Type) return Boolean is
begin
return Arg = "aaaaaaaaaa";
end Value;
function Out_Value (Arg : Unconstrained_String_Type) return Boolean is
begin
return Arg = "zzzzzzzzzz";
end Out_Value;
--\f
package body Test_Proc_Inout is
procedure Real_Op (Arg1 : in out Argument_Type);
package Pack is new Proc_Inout (Argument_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
procedure Real_Op (Arg1 : in out Argument_Type) is
begin
Assert (Value (Arg1));
Arg1 := Out_Value;
Executed_Real_Op := True;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Proc_Inout");
Arg1 := Value;
Real_Op (Arg1);
Assert (Out_Value (Arg1));
Executed_Real_Op := False;
Arg1 := Value;
Pack.Call (Pvv, Arg1);
Assert (Out_Value (Arg1));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Proc_Inout;
--\f
package body Test_Proc_In is
procedure Real_Op (Arg1 : in Argument_Type);
package Pack is new Proc_In (Argument_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
procedure Real_Op (Arg1 : in Argument_Type) is
begin
Assert (Value (Arg1));
Executed_Real_Op := True;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Proc_In");
Real_Op (Value);
Executed_Real_Op := False;
Pack.Call (Pvv, Value);
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Proc_In;
--\f
package body Test_Proc_In_In is
procedure Real_Op (Arg1 : in Argument1_Type; Arg2 : in Argument2_Type);
package Pack is new Proc_In_In (Argument1_Type, Argument2_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type) is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Executed_Real_Op := True;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Proc_In_In");
Real_Op (Value, Value);
Executed_Real_Op := False;
Pack.Call (Pvv, Value, Value);
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Proc_In_In;
--\f
package body Test_Proc_In_In_In is
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type);
package Pack is new Proc_In_In_In
(Argument1_Type, Argument2_Type, Argument3_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type) is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Assert (Value (Arg3));
Executed_Real_Op := True;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Proc_In_In_In");
Real_Op (Value, Value, Value);
Executed_Real_Op := False;
Pack.Call (Pvv, Value, Value, Value);
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Proc_In_In_In;
--\f
package body Test_Proc_In_In_In_In is
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : in Argument4_Type);
package Pack is new Proc_In_In_In_In (Argument1_Type, Argument2_Type,
Argument3_Type, Argument4_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : in Argument4_Type) is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Assert (Value (Arg3));
Assert (Value (Arg4));
Executed_Real_Op := True;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Proc_In_In_In_In");
Real_Op (Value, Value, Value, Value);
Executed_Real_Op := False;
Pack.Call (Pvv, Value, Value, Value, Value);
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Proc_In_In_In_In;
--\f
package body Test_Proc_In10 is
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : in Argument4_Type;
Arg5 : in Argument5_Type;
Arg6 : in Argument6_Type;
Arg7 : in Argument7_Type;
Arg8 : in Argument8_Type;
Arg9 : in Argument9_Type;
Arg10 : in Argument10_Type);
package Pack is new Proc_In10 (Argument1_Type, Argument2_Type,
Argument3_Type, Argument4_Type,
Argument5_Type, Argument6_Type,
Argument7_Type, Argument8_Type,
Argument9_Type, Argument10_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : in Argument4_Type;
Arg5 : in Argument5_Type;
Arg6 : in Argument6_Type;
Arg7 : in Argument7_Type;
Arg8 : in Argument8_Type;
Arg9 : in Argument9_Type;
Arg10 : in Argument10_Type) is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Assert (Value (Arg3));
Assert (Value (Arg4));
Assert (Value (Arg5));
Assert (Value (Arg6));
Assert (Value (Arg7));
Assert (Value (Arg8));
Assert (Value (Arg9));
Assert (Value (Arg10));
Executed_Real_Op := True;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Proc_In10");
Real_Op (Value, Value, Value, Value, Value,
Value, Value, Value, Value, Value);
Executed_Real_Op := False;
Pack.Call (Pvv, Value, Value, Value, Value, Value,
Value, Value, Value, Value, Value);
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Proc_In10;
--\f
package body Test_Proc_In_In_In_Out_Out is
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : out Argument4_Type;
Arg5 : out Argument5_Type);
package Pack is new Proc_In_In_In_Out_Out
(Argument1_Type, Argument2_Type, Argument3_Type,
Argument4_Type, Argument5_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : out Argument4_Type;
Arg5 : out Argument5_Type) is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Assert (Value (Arg3));
Arg4 := Out_Value;
Arg5 := Out_Value;
Executed_Real_Op := True;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Proc_In_In_In_Out_Out");
Real_Op (Value, Value, Value, Arg4, Arg5);
Assert (Out_Value (Arg4));
Assert (Out_Value (Arg5));
Executed_Real_Op := False;
Arg4 := Value;
Arg5 := Value;
Pack.Call (Pvv, Value, Value, Value, Arg4, Arg5);
Assert (Out_Value (Arg4));
Assert (Out_Value (Arg5));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Proc_In_In_In_Out_Out;
--\f
package body Test_Proc_In_In_Out_Out is
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : out Argument3_Type;
Arg4 : out Argument4_Type);
package Pack is new Proc_In_In_Out_Out (Argument1_Type, Argument2_Type,
Argument3_Type, Argument4_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
procedure Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : out Argument3_Type;
Arg4 : out Argument4_Type) is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Arg3 := Out_Value;
Arg4 := Out_Value;
Executed_Real_Op := True;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Proc_In_In_Out_Out");
Real_Op (Value, Value, Arg3, Arg4);
Assert (Out_Value (Arg3));
Assert (Out_Value (Arg4));
Executed_Real_Op := False;
Arg3 := Value;
Arg4 := Value;
Pack.Call (Pvv, Value, Value, Arg3, Arg4);
Assert (Out_Value (Arg3));
Assert (Out_Value (Arg4));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Proc_In_In_Out_Out;
--\f
package body Test_Func_In is
function Real_Op (Arg1 : in Argument_Type) return Result_Type;
package Pack is new Func_In (Argument_Type, Result_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
function Real_Op (Arg1 : in Argument_Type) return Result_Type is
begin
Assert (Value (Arg1));
Executed_Real_Op := True;
return Value;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Func_In");
Executed_Real_Op := False;
Assert (Value (Pack.Call (Pvv, Value)));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Func_In;
--\f
package body Test_Func_In_X_String is
function Real_Op (Arg1 : in Argument_Type) return X_String;
package Pack is new Func_In_X_String (Argument_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
function Real_Op (Arg1 : in Argument_Type) return X_String is
begin
Assert (Value (Arg1));
Executed_Real_Op := True;
return Value;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Func_In_X_String");
Executed_Real_Op := False;
Assert (Value (Pack.Call (Pvv, Value)));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Func_In_X_String;
--\f
package body Test_Func_In_In_In_X_String is
function Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type) return X_String;
package Pack is new Func_In_In_In_X_String
(Argument1_Type, Argument2_Type, Argument3_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
function Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type) return X_String is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Assert (Value (Arg3));
Executed_Real_Op := True;
return Value;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Func_In_In_In_X_String");
Executed_Real_Op := False;
Assert (Value (Pack.Call (Pvv, Value, Value, Value)));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Func_In_In_In_X_String;
--\f
package body Test_Func_In_In_In is
function Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type) return Result_Type;
package Pack is new Func_In_In_In (Argument1_Type, Argument2_Type,
Argument3_Type, Result_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
function Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type) return Result_Type is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Assert (Value (Arg3));
Executed_Real_Op := True;
return Value;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Func_In_In_In");
Executed_Real_Op := False;
Assert (Value (Pack.Call (Pvv, Value, Value, Value)));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Func_In_In_In;
--\f
package body Test_Func_In5 is
function Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : in Argument4_Type;
Arg5 : in Argument5_Type) return Result_Type;
package Pack is new Func_In5 (Argument1_Type, Argument2_Type,
Argument3_Type, Argument4_Type,
Argument5_Type, Result_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
function Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : in Argument4_Type;
Arg5 : in Argument5_Type) return Result_Type is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Assert (Value (Arg3));
Assert (Value (Arg4));
Assert (Value (Arg5));
Executed_Real_Op := True;
return Value;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Func_In5");
Executed_Real_Op := False;
Assert (Value (Pack.Call (Pvv, Value, Value, Value, Value, Value)));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Func_In5;
--\f
package body Test_Func_In10 is
function Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : in Argument4_Type;
Arg5 : in Argument5_Type;
Arg6 : in Argument6_Type;
Arg7 : in Argument7_Type;
Arg8 : in Argument8_Type;
Arg9 : in Argument9_Type;
Arg10 : in Argument10_Type) return Result_Type;
package Pack is new Func_In10
(Argument1_Type, Argument2_Type, Argument3_Type,
Argument4_Type, Argument5_Type, Argument6_Type,
Argument7_Type, Argument8_Type,
Argument9_Type, Argument10_Type, Result_Type);
function Pack_Value is new Pack.Value (Real_Op);
Pvv : Pack.Pv := Pack_Value;
function Real_Op (Arg1 : in Argument1_Type;
Arg2 : in Argument2_Type;
Arg3 : in Argument3_Type;
Arg4 : in Argument4_Type;
Arg5 : in Argument5_Type;
Arg6 : in Argument6_Type;
Arg7 : in Argument7_Type;
Arg8 : in Argument8_Type;
Arg9 : in Argument9_Type;
Arg10 : in Argument10_Type) return Result_Type is
begin
Assert (Value (Arg1));
Assert (Value (Arg2));
Assert (Value (Arg3));
Assert (Value (Arg4));
Assert (Value (Arg5));
Assert (Value (Arg6));
Assert (Value (Arg7));
Assert (Value (Arg8));
Assert (Value (Arg9));
Assert (Value (Arg10));
Executed_Real_Op := True;
return Value;
end Real_Op;
procedure Zot is
begin
Put_Line ("Test_Func_In10");
Executed_Real_Op := False;
Assert (Value (Pack.Call (Pvv, Value, Value, Value, Value, Value,
Value, Value, Value, Value, Value)));
Assert (Executed_Real_Op);
Pack.Free (Pvv);
end Zot;
end Test_Func_In10;
--\f
end Exe_100;