|
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: 8942 (0x22ee)
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 Text_Io, Io_Package, Calendar, Cpu_Time;
use Text_Io, Io_Package, Calendar, Cpu_Time;
package body Instrument is
Instr_File : File_Type;
Instr_File_Name : constant String := "instr";
Debug : constant Boolean := False; -- if true, debug output appears
Start_Time : Time;
Start_Cpu : Duration;
No_Name : constant String (1 .. 7) := "NO_NAME";
Max_Name_Len : constant := 15; -- MAXIMUM TEST NAME LENGTH.
Test_Name_Len : Integer range 0 .. Max_Name_Len := 0;
Test_Name : String (1 .. Max_Name_Len);
package Dur_Io is new Fixed_Io (Duration);
use Dur_Io;
--
package Instr_Buffers is
procedure Add_String (Str : String);
procedure Add_Record (Rec : Instrumentation_Record_Type);
procedure Put_Buffers;
end Instr_Buffers;
--
procedure Put_Msg (Msg : String);
--
package body Instr_Buffers is
Max_Chars : constant Integer := 1000;
Max_Records : constant Integer := 20;
Char_Buffer : String (1 .. Max_Chars);
First_Char : Integer := 1;
Last_Char : Integer := 0;
Inst_Buffer : array (1 .. Max_Records) of Instrumentation_Record_Type;
Last_Inst : Integer := 0;
--
procedure Add_String (Str : String) is
Str_Length : Integer := Str'Length;
begin
if Last_Char + Str_Length + 1 > Max_Chars then
raise Constraint_Error;
else
Char_Buffer (Last_Char + 1 .. Last_Char + Str_Length) := Str;
Last_Char := Last_Char + Str_Length + 1;
Char_Buffer (Last_Char) := Ascii.Lf;
if Debug then
Put_Msg (Str);
end if;
end if;
end Add_String;
--
procedure Add_Record (Rec : Instrumentation_Record_Type) is
begin
if Last_Inst >= Max_Records then
raise Constraint_Error;
end if;
Last_Inst := Last_Inst + 1;
Inst_Buffer (Last_Inst) := Rec;
end Add_Record;
--
procedure Put_Buffers is
begin
while First_Char <= Last_Char loop
for I in First_Char .. Last_Char loop
if Char_Buffer (I) = Ascii.Lf then
Put_Msg (Char_Buffer (First_Char .. I));
First_Char := I + 1;
exit;
end if;
end loop;
end loop;
begin
Open (Instr_File, Out_File, Instr_File_Name);
exception
when Name_Error =>
Create (Instr_File, Out_File, Instr_File_Name);
end;
First_Char := 1;
Last_Char := 0;
for I in 1 .. Last_Inst loop
Put (Instr_File, Inst_Buffer (I));
end loop;
Last_Inst := 0;
Close (Instr_File);
end Put_Buffers;
end Instr_Buffers;
--
use Instr_Buffers;
procedure Put_Msg (Msg : String) is
-- WRITE MESSAGE. LONG MESSAGES ARE FOLDED (AND INDENTED).
Max_Len : constant Integer range 50 .. 150 := 72; -- MAXIMUM
-- OUTPUT LINE LENGTH.
Indent : constant Integer := Test_Name_Len + 9; -- AMOUNT TO
-- INDENT CONTINUATION LINES.
I : Integer := 0; -- CURRENT INDENTATION.
M : Integer := Msg'First; -- START OF MESSAGE SLICE.
N : Integer; -- END OF MESSAGE SLICE.
begin
loop
if I + (Msg'Last - M + 1) > Max_Len then
N := M + (Max_Len - I) - 1;
if Msg (N) /= ' ' then
while N >= M and then Msg (N + 1) /= ' ' loop
N := N - 1;
end loop;
if N < M then
N := M + (Max_Len - I) - 1;
end if;
end if;
else
N := Msg'Last;
end if;
Set_Col (Count (I + 1));
Put_Line (Msg (M .. N));
I := Indent;
M := N + 1;
while M <= Msg'Last and then Msg (M) = ' ' loop
M := M + 1;
end loop;
exit when M > Msg'Last;
end loop;
end Put_Msg;
--
procedure Start (Name : String; Descr : String) is
begin
if Name'Length <= Max_Name_Len then
Test_Name_Len := Name'Length;
else
Test_Name_Len := Max_Name_Len;
end if;
Test_Name (1 .. Test_Name_Len) :=
Name (Name'First .. Name'First + Test_Name_Len - 1);
Add_String ("");
Add_String ("---- " & Test_Name (1 .. Test_Name_Len) &
" " & Descr & ".");
Add_Record ((Descr'Length, Test_Name (1 .. Unit_Name_Length),
Start_Rec, 0.0, 0.0, Descr));
Start_Time := Clock;
Start_Cpu := Cpu_Clock;
end Start;
--
procedure Comment (Descr : String) is
Elapsed, Elapsed_Cpu : Duration;
Elapsed_Image, Elapsed_Cpu_Image : String (1 .. 20);
begin
Elapsed_Cpu := Cpu_Clock - Start_Cpu;
Elapsed := Clock - Start_Time;
Put (Elapsed_Image, Elapsed);
Put (Elapsed_Cpu_Image, Elapsed_Cpu);
Add_String (" - " & Test_Name (1 .. Test_Name_Len) &
" " & Descr & ".");
Add_String (" - " & Test_Name (1 .. Test_Name_Len) & " TIME " &
Elapsed_Image & " CPU TIME " & Elapsed_Cpu_Image);
Add_Record ((Descr'Length, Test_Name (1 .. Unit_Name_Length),
Com_Rec, Elapsed, Elapsed_Cpu, Descr));
end Comment;
--
procedure Stop is
Elapsed, Elapsed_Cpu : Duration;
Elapsed_Image, Elapsed_Cpu_Image : String (1 .. 20);
begin
Elapsed_Cpu := Cpu_Clock - Start_Cpu;
Elapsed := Clock - Start_Time;
Put (Elapsed_Image, Elapsed);
Put (Elapsed_Cpu_Image, Elapsed_Cpu);
Add_String ("==== " & Test_Name (1 .. Test_Name_Len) & " TIME " &
Elapsed_Image & " CPU TIME " & Elapsed_Cpu_Image);
Add_Record ((0, Test_Name (1 .. Unit_Name_Length),
Stop_Rec, Elapsed, Elapsed_Cpu, ""));
Put_Buffers;
delay 10.0;
Test_Name_Len := No_Name'Length;
Test_Name (1 .. Test_Name_Len) := No_Name;
end Stop;
--
function Ident_Int (X : Integer) return Integer is
begin
if Equal (X, X) then
-- ALWAYS EQUAL.
return X; -- ALWAYS EXECUTED.
end if;
return 0; -- NEVER EXECUTED.
end Ident_Int;
--
function Ident_Char (X : Character) return Character is
begin
if Equal (Character'Pos (X), Character'Pos (X)) then
-- ALWAYS
-- EQUAL.
return X; -- ALWAYS EXECUTED.
end if;
return '0'; -- NEVER EXECUTED.
end Ident_Char;
--
function Ident_Bool (X : Boolean) return Boolean is
begin
if Equal (Boolean'Pos (X), Boolean'Pos (X)) then
-- ALWAYS
-- EQUAL.
return X; -- ALWAYS EXECUTED.
end if;
return False; -- NEVER EXECUTED.
end Ident_Bool;
--
function Ident_Str (X : String) return String is
begin
if Equal (X'Length, X'Length) then
-- ALWAYS EQUAL.
return X; -- ALWAYS EXECUTED.
end if;
return ""; -- NEVER EXECUTED.
end Ident_Str;
--
function Equal (X, Y : Integer) return Boolean is
Rec_Limit : constant Integer range 1 .. 100 := 3; -- RECURSION
-- LIMIT.
Z : Boolean; -- RESULT.
begin
if X < 0 then
if Y < 0 then
Z := Equal (-X, -Y);
else
Z := False;
end if;
elsif X > Rec_Limit then
Z := Equal (Rec_Limit, Y - X + Rec_Limit);
elsif X > 0 then
Z := Equal (X - 1, Y - 1);
else
Z := Y = 0;
end if;
return Z;
exception
when others =>
return X = Y;
end Equal;
--
package body Procs is
function Ident (X : in T) return T is
begin
return X;
end Ident;
procedure Let (X : in out T; Y : T) is
begin
X := Y;
end Let;
end Procs;
--
package body Arr_Procs is
function Ident (X : T) return T is
begin
return X;
end Ident;
procedure Let (X : in out T; Y : T) is
begin
X := Y;
end Let;
end Arr_Procs;
begin
Test_Name_Len := No_Name'Length;
Test_Name (1 .. Test_Name_Len) := No_Name;
end Instrument;