|
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: 10008 (0x2718)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦24d1ddd49⟧
└─⟦this⟧
separate (Shared_Code_Generic_Support)
package body Debug is
pragma Suppress_All;
function Hex_Image (Dat : Data) return String is
pragma Routine_Number (N => Runtime_Ids.Internal);
Hex : constant String (1 .. 16) := "0123456789ABCDEF";
Result : String (1 .. 2 * Dat'Length);
N : Standard.Natural := Result'Last;
begin
for I in reverse Dat'Range loop
Result (N) := Hex (Standard.Integer (Dat (I)) mod 16 + 1);
N := N - 1;
Result (N) := Hex (Standard.Integer (Dat (I)) / 16 + 1);
N := N - 1;
end loop;
return Result;
end Hex_Image;
function Hex_Image (Exp : Expression) return String is
pragma Routine_Number (N => Runtime_Ids.Internal);
begin
return Address_Image (System.Address (Exp));
end Hex_Image;
function Indirect_Hex_Image (Address : System.Address;
Length : Natural) return String is
pragma Routine_Number (N => Runtime_Ids.Internal);
package Data_Subtype is new Establish_Data_Subtype (Length);
Dat : Data_Subtype.Actual_Data renames Data_Subtype.Cnvt (Address).all;
begin
return Hex_Image (Dat);
end Indirect_Hex_Image;
function Indirect_String_Image (Address : System.Address;
Length : Natural) return String is
pragma Routine_Number (N => Runtime_Ids.Internal);
package Data_Subtype is new Establish_Data_Subtype (Length);
Dat : Data_Subtype.Actual_Data renames Data_Subtype.Cnvt (Address).all;
Result : String (Standard.Integer (Dat'First) ..
Standard.Integer (Dat'Last));
begin
for I in Dat'Range loop
-- The following assumes that the representation of
-- a character is a byte with the high order bit 0,
-- and the rest of them the 'Pos of the character
Result (Standard.Integer (I)) := Character'Val (Dat (I));
end loop;
return Result;
end Indirect_String_Image;
function Address_Image (Address : System.Address) return String is
pragma Routine_Number (N => Runtime_Ids.Internal);
package Data_Subtype is new Establish_Data_Subtype (4);
--[] Needed due to a middle pass bug. When middle pass is fixed,
-- change to:
-- package Data_Subtype is new Establish_Data_Subtype
-- (Target.Bytes_Per_Address);
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Data_Subtype.Actual_Data);
-- To convert a System.Address to point to Actual_Data
Dat : constant Data_Subtype.Actual_Data := Cnvt (Address);
begin
return Hex_Image (Dat);
end Address_Image;
function Expression_Image (Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind) return String is
pragma Routine_Number (Runtime_Ids.Internal);
type String_Node (Length : Standard.Positive);
type String_Node_Ref is access String_Node;
type String_Node (Length : Standard.Positive) is
record
Text : String (1 .. Length);
Next : String_Node_Ref;
end record;
First_Node : String_Node_Ref := null;
Last_Node : String_Node_Ref := null;
Total_Length : Standard.Natural := 0;
procedure Put (S : String) is
pragma Routine_Number (N => Runtime_Ids.Internal);
subtype Slider is String (1 .. S'Length);
Node : String_Node_Ref;
begin
Total_Length := Total_Length + S'Length;
Node := new String_Node'(Length => S'Length,
Text => Slider (S),
Next => null);
if First_Node = null then
First_Node := Node;
else
Last_Node.Next := Node;
end if;
Last_Node := Node;
end Put;
procedure Put_Line (S : String) is
pragma Routine_Number (N => Runtime_Ids.Internal);
begin
Put (S & Ascii.Lf);
end Put_Line;
function Some_Bytes (Address : System.Address) return String is
pragma Routine_Number (N => Runtime_Ids.Internal);
begin
if Address = System.Address_Zero then
return "null";
else
return Indirect_Hex_Image (Address, 4) & "...";
end if;
end Some_Bytes;
procedure Data_Op (Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
Put_Line (Hex_Image (Exp_Data));
end Data_Op;
procedure Value_Op (Exp_1 : Expression) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
Put_Line (Indirect_Hex_Image (Get_Scalar_Data_Address
(Exp_1'Address, Type_Desc.Size),
Type_Desc.Size));
end Value_Op;
procedure Unconstrained_Array_Op (Exp_Dope : Dope_Vector;
Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
Put (Integer'Image (Exp_Dope (1).First) & " .." &
Integer'Image (Exp_Dope (1).Last) & ", ");
Put_Line (Hex_Image (Exp_Data));
end Unconstrained_Array_Op;
procedure Unconstrained_Record_Op (Exp_Constrained : Boolean;
Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Exp_Constrained then
Put ("Constrained, ");
else
Put ("Unconstrained, ");
end if;
Put_Line (Hex_Image (Exp_Data));
end Unconstrained_Record_Op;
procedure Dispatch is new Unary_Dispatch
(Value_Op,
Data_Op,
Unconstrained_Array_Op,
Unconstrained_Record_Op,
Get_Value_Size);
-- Puts out the expression without interpreting its Data_Kind.
-- This does the following depending on the Data_Kind:
-- Undefined : ???
-- ???
--
-- Value :
-- Nothing
--
-- Data_Ptr:
-- <Exp contents in hex> --> few bytes of data in hex
--
-- Dv_Data_Ptr:
-- <Exp contents in hex> --> few bytes of (dv,data) in hex
--
-- Unconstrained_Array_Desc_Ptr :
-- <Exp contents in hex> -->
--- <Uncons_Desc_Word_1 in hex> --> few bytes of data in hex
-- <Uncons_Desc_Word_2 in hex> --> few bytes of dope in hex
--
-- Unconstrained_Record_Desc_Ptr :
-- <Exp contents in hex> -->
--- <Uncons_Desc_Word_1 in hex> --> few bytes of data in hex
-- <Uncons_Desc_Word_2 in hex>
--
procedure Put_Uninterpreted is
pragma Routine_Number (Runtime_Ids.Internal);
begin
case Data_Kind_Of (Type_Desc.Type_Kind, Exp_Kind) is
when Undefined =>
Put_Line ("???");
when Value =>
null;
when Data_Ptr =>
Put_Line (Hex_Image (Exp) & " --> " &
Some_Bytes (System.Address (Exp)));
when Dv_Data_Ptr =>
Put_Line (Hex_Image (Exp) & " --> " &
Some_Bytes (System.Address (Exp)));
when Unconstrained_Array_Desc_Ptr =>
Put_Line (Hex_Image (Exp) & " --> ");
Put_Line
(" " & Address_Image (Cnvt (Exp).Data) &
" --> " & Some_Bytes (Cnvt (Exp).Data));
Put_Line (" " & Address_Image (Cnvt (Exp).Constraint) &
" --> " &
Some_Bytes (Cnvt (Exp).Constraint));
when Unconstrained_Record_Desc_Ptr =>
Put_Line (Hex_Image (Exp) & " --> ");
Put_Line
(" " & Address_Image (Cnvt (Exp).Data) &
" --> " & Some_Bytes (Cnvt (Exp).Data));
Put_Line
(" " & Address_Image (Cnvt (Exp).Constraint));
end case;
end Put_Uninterpreted;
function Get_Text return String is
pragma Routine_Number (N => Runtime_Ids.Internal);
Text : String (1 .. Total_Length);
Last : Standard.Natural := 0;
Node : String_Node_Ref;
begin
Node := First_Node;
while Node /= null loop
Text (Last + 1 .. Last + Node.Length) := Node.Text;
Last := Last + Node.Length;
Node := Node.Next;
end loop;
return Text;
end Get_Text;
begin
Put_Line (Expression_Kind'Image (Exp_Kind) & ": ");
-- Put out the uninterpreted expression
Put_Uninterpreted;
-- Put out the interpreted expression
Dispatch (Type_Desc, Exp, Exp_Kind);
return Get_Text;
end Expression_Image;
end Debug;
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);