|
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: 43012 (0xa804)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─ ⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦24d1ddd49⟧
└─⟦this⟧
with Unchecked_Conversion;
package body Shared_Code_Generic_Support is
pragma Suppress_All;
function "=" (X, Y : System.Address) return Boolean renames System."=";
function "=" (X, Y : Integer) return Boolean renames Target."=";
function ">" (X, Y : Integer) return Boolean renames Target.">";
function "<" (X, Y : Integer) return Boolean renames Target."<";
function "+" (X, Y : Integer) return Integer renames Target."+";
function "-" (X, Y : Integer) return Integer renames Target."-";
function "*" (X, Y : Integer) return Integer renames Target."*";
function "/" (X, Y : Integer) return Integer renames Target."/";
type Byte is range 0 .. 2 ** Target.Bits_Per_Byte - 1;
for Byte'Size use Target.Bits_Per_Byte;
-- The basic unit of storage
Extension_Byte : constant array (Boolean) of Byte :=
(True => Byte'Last, False => 0);
-- This array is indexed by an Is_Negative boolean. It provides
-- the byte to be used for sign extension when a small integer is
-- to be widened.
High_Bit_Only : constant Byte := 2 ** (Target.Bits_Per_Byte - 1);
-- This is a byte with only the high bit turned on. It is used to
-- determine if an Exp is negative.
type Data is array (Positive range <>) of Byte;
pragma Pack (Data);
-- Data is after all a packed stream of bytes
subtype Word is Data (1 .. Target.Bytes_Per_Integer);
-- A word is the unit of storage that an integer or an address fits in.
type Dope_Vector_Element is
record
Size : Integer;
First : Integer;
Last : Integer;
end record;
for Dope_Vector_Element use
record at mod 4;
Size at 0 range 0 .. 31;
First at 4 range 0 .. 31;
Last at 8 range 0 .. 31;
end record;
-- Layout of a dope vector element. See type Dope_Vector for detailed
-- explanation of these fields.
Bytes_Per_Dope_Vector_Element : constant := Target.Bytes_Per_Integer * 3;
-- The size of a dope vector element
type Dope_Vector is array (Positive range <>) of Dope_Vector_Element;
-- A Dope_Vector is an array of dope vector elements, having tthe
-- format:
-- (Size_0 First_1, Last_1)
-- (Size_1, First_2, Last_2)
-- ...
-- (Size_n-1, First_n, Last_n)
-- where the array has n dimensions. Size_i, First_i, Last_i are
-- interpreted as follows:
-- Size_i : the size of the i'th dimension in bytes. i=0 means
-- the entire array.
-- First_i : the lower bound of the i'th dimension
-- Last_i : the upper bound of the i'th dimension
-- Note that Size_i = (Last_i - First_i + 1) * byte size of i'th dim
type Unconstrained_Descriptor_Ref is access Unconstrained_Descriptor;
for Unconstrained_Descriptor_Ref'Storage_Size use 0;
function Cnvt is new Unchecked_Conversion
(Source => Expression,
Target => Unconstrained_Descriptor_Ref);
-- To convert an Expression to point to an Unconstrained_Descriptor.
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Unconstrained_Descriptor_Ref);
-- To convert a System.Address to point to an Unconstrained_Descriptor.
type Integer_Ref is access Integer;
for Integer_Ref'Storage_Size use 0;
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Integer_Ref);
-- To convert a System.Address to point to an Integer
type Boolean_Ref is access Boolean;
for Boolean_Ref'Storage_Size use 0;
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Boolean_Ref);
-- To convert a System.Address to point to a Boolean
type Long_Float_Ref is access Long_Float;
for Long_Float_Ref'Storage_Size use 0;
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Long_Float_Ref);
-- To convert a System.Address to point to a Long_Float
type Subprogram_Variable_Ref is access Subprogram_Variable;
for Subprogram_Variable_Ref'Storage_Size use 0;
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Subprogram_Variable_Ref);
-- To convert a System.Address to point to a Subprogram_Variable
type Expression_Ref is access Expression;
for Expression_Ref'Storage_Size use 0;
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Expression_Ref);
-- To convert a System.Address to point to an Expression for assignment
function Cnvt is new Unchecked_Conversion (Source => Word,
Target => Expression);
-- To convert a Word into an Expression. Note that both have the
-- same size.
function Cnvt is new Unchecked_Conversion (Source => Expression,
Target => Word);
-- To convert an Expression into a Word. Note that both have the
-- same size.
function Cnvt is new Unchecked_Conversion (Source => Word,
Target => Integer);
-- To convert an Word into an Integer. Note that both have the
-- same size.
type Data_Kind is (Undefined, Value, Data_Ptr, Dv_Data_Ptr,
Unconstrained_Array_Desc_Ptr,
Unconstrained_Record_Desc_Ptr);
-- Data_Kind identifies three different kinds of data in an Expression.
-- It refers to the table entries in the table in the spec for the po-
-- ssible layouts of a value of a formal private type. Meanings are:
--
-- Undefined:
-- Expression is meaningless.
-- Table entry is "Illegal".
--
-- Value:
-- Expression is the value in 1 word.
-- Table entry is "1 word".
--
-- Data_Ptr:
-- Expression points to the data.
-- Table entry is "@data".
--
-- Dv_Data_Ptr:
-- Expression points to a contiguous areay having (dope vector, data).
-- Table entry is "@(dv,data)".
--
-- Unconstrained_Array_Desc_Ptr:
-- Expression points to an Unconstrained_Descriptor for an array.
-- Table entry is "@(@data,@dv)".
--
-- Unconstrained_Record_Desc_Ptr:
-- Expression points to an Unconstrained_Descriptor for a record.
-- Table entry is "@(@data,cnstrnd?)
--
-- The Data_Kind_Of array implements the Data Kind Table in the spec
Data_Kind_Of :
constant array (Formal_Type_Kind, Expression_Kind) of Data_Kind :=
(Scalars | Accesses | Tasks =>
(Nil_Kind => Undefined,
Local_Object => Value,
Formal_Object => Value,
Formal_Object_Ref => Data_Ptr,
Component => Data_Ptr,
Allocator => Data_Ptr,
Formal_Homogeneous_Allocator => Data_Ptr,
Formal_Heterogeneous_Allocator => Undefined),
Long_Scalars | Simple_Records =>
(Nil_Kind => Undefined,
Local_Object => Data_Ptr,
Formal_Object => Data_Ptr,
Formal_Object_Ref => Data_Ptr,
Component => Data_Ptr,
Allocator => Data_Ptr,
Formal_Homogeneous_Allocator => Data_Ptr,
Formal_Heterogeneous_Allocator => Undefined),
Constrained_Records =>
(Nil_Kind => Undefined,
Local_Object => Data_Ptr,
Formal_Object => Unconstrained_Record_Desc_Ptr,
Formal_Object_Ref => Unconstrained_Record_Desc_Ptr,
Component => Data_Ptr,
Allocator => Data_Ptr,
Formal_Homogeneous_Allocator => Data_Ptr,
Formal_Heterogeneous_Allocator => Data_Ptr),
Constrained_Arrays =>
(Nil_Kind => Undefined,
Local_Object => Data_Ptr,
Formal_Object => Unconstrained_Array_Desc_Ptr,
Formal_Object_Ref => Unconstrained_Array_Desc_Ptr,
Component => Data_Ptr,
Allocator => Data_Ptr,
Formal_Homogeneous_Allocator => Data_Ptr,
Formal_Heterogeneous_Allocator => Dv_Data_Ptr),
Unconstrained_Arrays =>
(Nil_Kind => Undefined,
Local_Object => Unconstrained_Array_Desc_Ptr,
Formal_Object => Unconstrained_Array_Desc_Ptr,
Formal_Object_Ref => Unconstrained_Array_Desc_Ptr,
Component => Undefined,
Allocator => Dv_Data_Ptr,
Formal_Homogeneous_Allocator => Undefined,
Formal_Heterogeneous_Allocator => Dv_Data_Ptr),
Unconstrained_Records =>
(Nil_Kind => Undefined,
Local_Object => Unconstrained_Record_Desc_Ptr,
Formal_Object => Unconstrained_Record_Desc_Ptr,
Formal_Object_Ref => Unconstrained_Record_Desc_Ptr,
Component => Data_Ptr,
Allocator => Data_Ptr,
Formal_Homogeneous_Allocator => Undefined,
Formal_Heterogeneous_Allocator => Data_Ptr));
Can_Be_Trusted : constant array (Expression_Kind) of Boolean :=
(Local_Object => True,
Component => True,
Allocator => True,
Nil_Kind => False,
Formal_Object => False,
Formal_Object_Ref => False,
Formal_Homogeneous_Allocator => True,
Formal_Heterogeneous_Allocator => False);
-- Certain Expression_Kind's can be trusted to satisfy the constraints
-- of the private type. However, Formal_Object, and Formal_Allocator's
-- cannot.
-- Instantiating this generic establishes the dope vector subtype
-- for a type descriptor
generic
Dope_Vector_Size : Integer;
package Establish_Dope_Vector_Subtype is
subtype Actual_Dope is
Dope_Vector (1 .. Positive (Dope_Vector_Size /
Bytes_Per_Dope_Vector_Element));
type Dope_Ref is access Actual_Dope;
for Dope_Ref'Storage_Size use 0;
function Cnvt is new Unchecked_Conversion
(Source => Expression,
Target => Dope_Ref);
-- To convert an Expression to point to Actual_Dope
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Dope_Ref);
-- To convert a System.Address to point to Actual_Dope
end Establish_Dope_Vector_Subtype;
pragma Generic_Policy (Establish_Dope_Vector_Subtype, Replicated);
pragma Suppress (Elaboration_Check, On => Establish_Dope_Vector_Subtype);
-- Instantiating this generic establishes a Data subtype
generic
Data_Size : Integer;
package Establish_Data_Subtype is
subtype Actual_Data is Data (1 .. Data_Size);
-- Data is after all a stream of bytes
type Data_Ref is access Actual_Data;
for Data_Ref'Storage_Size use 0;
function Cnvt is new Unchecked_Conversion
(Source => Expression,
Target => Data_Ref);
-- To convert an Expression to point to Actual_Data
function Cnvt is new Unchecked_Conversion
(Source => System.Address,
Target => Data_Ref);
-- To convert a System.Address to point to Actual_Data
end Establish_Data_Subtype;
pragma Generic_Policy (Establish_Data_Subtype, Replicated);
pragma Suppress (Elaboration_Check, On => Establish_Data_Subtype);
-- This generic is designed to be instantiated in a procedure frame,
-- with actuals to deal with expressions in the various formats. See
-- the exported function Satisfies for a canonical use.
generic
with procedure Unary_Value_Op (Exp : Expression);
with procedure Unary_Data_Op (Exp_Data : in out Data);
with procedure Unary_Unconstrained_Array_Op
(Exp_Dope : Dope_Vector;
Exp_Data : in out Data);
with procedure Unary_Unconstrained_Record_Op
(Exp_Constrained : Boolean;
Exp_Data : in out Data);
with function Get_Value_Size
(Type_Desc : Type_Descriptor;
Value : Expression;
Value_Kind : Expression_Kind) return Integer;
procedure Unary_Dispatch (Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind);
pragma Generic_Policy (Unary_Dispatch, Replicated);
pragma Suppress (Elaboration_Check, On => Unary_Dispatch);
-- pragma Inline (Unary_Dispatch);
-- This generic is designed to be instantiated in a procedure frame,
-- with actuals to deal with expressions in the various formats. See
-- the exported function Equal for a canonical use.
generic
with procedure Binary_Value_Op (Exp_1 : Expression;
Exp_2 : Expression);
with procedure Binary_Data_Op (Exp_1_Data : in out Data;
Exp_2_Data : in out Data);
with procedure Binary_Value_Data_Op (Exp_1 : Expression;
Exp_2_Data : in out Data);
with procedure Binary_Data_Value_Op (Exp_1_Data : in out Data;
Exp_2 : Expression);
with procedure Binary_Unconstrained_Array_Op
(Exp_1_Dope : Dope_Vector;
Exp_1_Data : in out Data;
Exp_2_Dope : Dope_Vector;
Exp_2_Data : in out Data);
with procedure Binary_Unconstrained_Record_Op
(Exp_1_Constrained : Boolean;
Exp_1_Data : in out Data;
Exp_2_Constrained : Boolean;
Exp_2_Data : in out Data);
with function Get_Value_Size
(Type_Desc : Type_Descriptor;
Value : Expression;
Value_Kind : Expression_Kind) return Integer;
procedure Binary_Dispatch (Type_Desc : Type_Descriptor;
Exp_1 : Expression;
Exp_1_Kind : Expression_Kind;
Exp_2 : Expression;
Exp_2_Kind : Expression_Kind);
pragma Generic_Policy (Binary_Dispatch, Replicated);
pragma Suppress (Elaboration_Check, On => Binary_Dispatch);
-- This generic is designed to be instantiated in a procedure frame,
-- with actuals to deal with expressions in the various formats. See
-- the exported function Equal for a canonical use.
generic
with procedure Binary_Value_Op (Exp_1 : Expression; Exp_2 : Expression);
with procedure Binary_Data_Op
(Exp_1_Data : in out Data; Exp_2_Data : in out Data);
with procedure Binary_Value_Data_Op
(Exp_1 : Expression; Exp_2_Data : in out Data);
with procedure Binary_Data_Value_Op
(Exp_1_Data : in out Data; Exp_2 : Expression);
with procedure Binary_Unconstrained_Array_Op (Exp_1_Dope : Dope_Vector;
Exp_1_Data : in out Data;
Exp_2_Dope : Dope_Vector;
Exp_2_Data : in out Data);
with procedure Binary_Unconstrained_Record_Op
(Exp_1_Constrained : Boolean;
Exp_1_Data : in out Data;
Exp_2_Constrained : Boolean;
Exp_2_Data : in out Data);
with function Get_Value_Size
(Type_Desc : Type_Descriptor;
Value : Expression;
Value_Kind : Expression_Kind) return Integer;
procedure Two_Kind_Binary_Dispatch (Type_Desc_1 : Type_Descriptor;
Exp_1 : Expression;
Exp_1_Kind : Expression_Kind;
Type_Desc_2 : Type_Descriptor;
Exp_2 : Expression;
Exp_2_Kind : Expression_Kind);
pragma Generic_Policy (Two_Kind_Binary_Dispatch, Replicated);
pragma Suppress (Elaboration_Check, On => Two_Kind_Binary_Dispatch);
-- pragma Inline (Two_Kind_Binary_Dispatch);
-- pragma Inline (Binary_Dispatch);
-- Actual code to copy an Expression from Source to Dest_Address, which
-- is the address of an Expression. Chk is only used in the case of
-- an Unconstrained_Arrays. This is a generic to deal with the Return_
-- Value function that already has a Value_Size in the case of the No
-- Copy Down model.
generic
with function Get_Value_Size
(Type_Desc : Type_Descriptor;
Value : Expression;
Value_Kind : Expression_Kind) return Integer;
procedure Copy_Expression_Generic (Type_Desc : Type_Descriptor;
Source : Expression;
Source_Kind : Expression_Kind;
Dest_Address : System.Address;
Dest_Kind : Expression_Kind;
Dest_Constraints : Constraint_Descriptor;
Chk : Copy_Check_Kind);
pragma Generic_Policy (Copy_Expression_Generic, Replicated);
pragma Suppress (Elaboration_Check, On => Copy_Expression_Generic);
-- pragma Inline (Copy_Expression_Generic);
package Asm_Interface is
function Value_Size (Subp : Subprogram_Variable;
Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind) return Integer;
-- To call Value_Size_Subp in the Type_Descriptor
procedure Init (Subp : Subprogram_Variable;
Type_Desc : Type_Descriptor;
Dest_Address : System.Address);
-- To call Init_Subp in the Type_Descriptor
procedure Init_With_Tasks (Subp : Subprogram_Variable;
Type_Desc : Type_Descriptor;
Dest_Address : System.Address;
Master_Layer : System.Address;
Activation_Group : System.Address);
-- To call Init_Subp in the Type_Descriptor, passing a Master_
-- Layer and an Activation_Group when the type has tasks.
function Allocate (Subp : Subprogram_Variable;
Type_Desc : Type_Descriptor;
Collection_Or_Heap : System.Address;
Is_Collection : Boolean;
Is_Homogeneous : Boolean) return System.Address;
-- To call Allocate_Subp in the Type_Descriptor
function Allocate_With_Tasks
(Subp : Subprogram_Variable;
Type_Desc : Type_Descriptor;
Collection_Or_Heap : System.Address;
Is_Collection : Boolean;
Is_Homogeneous : Boolean;
Master_Layer : System.Address;
Activation_Group : System.Address) return System.Address;
-- To call Allocate_Subp in the Type_Descriptor, passing a Master_
-- Layer and an Activation_Group when the type has tasks.
procedure Dscrmt_Record_Assign
(Subp : Subprogram_Variable;
Type_Desc : Type_Descriptor;
Source : Expression;
Source_Kind : Expression_Kind;
Dest : Expression;
Dest_Kind : Expression_Kind);
-- To call Dscrmt_Record_Assign_Subp in the Type_Descriptor
function Dscrmt_Record_Satisfies
(Subp : Subprogram_Variable;
Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind) return Boolean;
-- To call Dscrmt_Record_Satisfies_Subp in the Type_Descriptor.
-- Does ONLY a subtype check.
private
pragma Suppress (Elaboration_Check, On => Value_Size);
pragma Suppress (Elaboration_Check, On => Allocate);
pragma Suppress (Elaboration_Check, On => Allocate_With_Tasks);
pragma Suppress (Elaboration_Check, On => Dscrmt_Record_Assign);
pragma Suppress (Elaboration_Check, On => Dscrmt_Record_Satisfies);
pragma Interface (Asm, Init);
pragma Import_Procedure (Internal => Init,
External => "__CALL_INIT",
Mechanism => (Reference, Reference, Value));
pragma Interface (Asm, Init_With_Tasks);
pragma Import_Procedure
(Internal => Init_With_Tasks,
External => "__CALL_INIT_WITH_TASKS",
Mechanism => (Reference, Reference, Value, Value, Value));
end Asm_Interface;
package Satisfies_Ops is
function Satisfies_Value
(Type_Desc : Type_Descriptor;
Exp : Expression;
Constraints : Constraint_Descriptor;
Type_Kind : Formal_Type_Kind;
Size : Integer;
Chk : Check_Kind) return Boolean;
function Satisfies_Data
(Type_Desc : Type_Descriptor;
Exp_Data : Data;
Constraints : Constraint_Descriptor;
Type_Kind : Formal_Type_Kind;
Size : Integer;
Chk : Check_Kind) return Boolean;
function Satisfies_Unconstrained_Array
(Exp_Dope : Dope_Vector;
Constraints : Constraint_Descriptor;
Chk : Check_Kind) return Boolean;
private
pragma Suppress (Elaboration_Check, On => Satisfies_Value);
pragma Suppress (Elaboration_Check, On => Satisfies_Data);
pragma Suppress (Elaboration_Check,
On => Satisfies_Unconstrained_Array);
end Satisfies_Ops;
package Short_Pointer_Ops is
function Short_To_Long (Dat : Data) return Expression;
procedure Copy_Value_To_Data (Source_Exp : Expression;
Dest_Address : System.Address);
procedure Copy_Data_To_Value (Source_Data : Data;
Dest_Address : System.Address);
procedure Copy_Data_To_Data (Source_Data : Data;
Dest_Address : System.Address);
private
pragma Suppress (Elaboration_Check, On => Short_To_Long);
pragma Suppress (Elaboration_Check, On => Copy_Value_To_Data);
pragma Suppress (Elaboration_Check, On => Copy_Data_To_Value);
pragma Suppress (Elaboration_Check, On => Copy_Data_To_Data);
end Short_Pointer_Ops;
-- Debug utilities
package Debug is
function Hex_Image (Dat : Data) return String;
-- Return the image of Dat in hex.
function Hex_Image (Exp : Expression) return String;
-- Return the image of Exp in hex.
function Indirect_Hex_Image (Address : System.Address;
Length : Natural) return String;
-- Return the image of Length bytes starting at the address
-- pointed to by Address.
function Indirect_String_Image (Address : System.Address;
Length : Natural) return String;
-- Return the image of Length bytes starting at the address
-- pointed to by Address interpreted as a String.
function Address_Image (Address : System.Address) return String;
-- Return the image of Address in hex.
function Expression_Image (Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind) return String;
-- Returns a string for Exp both with and without interpretation.
private
pragma Suppress (Elaboration_Check, On => Hex_Image); -- Does both
pragma Suppress (Elaboration_Check, On => Indirect_Hex_Image);
pragma Suppress (Elaboration_Check, On => Indirect_String_Image);
pragma Suppress (Elaboration_Check, On => Address_Image);
pragma Suppress (Elaboration_Check, On => Expression_Image);
end Debug;
-- Following are a collection of useful utility subprograms
function "+" (Left : System.Address;
Right : Integer) return System.Address is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return System."+" (Left, Standard.Integer (Right));
end "+";
-- pragma Inline ("+");
function To_Address (Int : Integer) return System.Address is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return System.To_Address (Standard.Integer (Int));
end To_Address;
-- pragma Inline (To_Address);
function Get_Scalar_Lower_Bound
(Constraints : Constraint_Descriptor) return Integer is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return Constraints.Constraint_1;
end Get_Scalar_Lower_Bound;
-- pragma Inline (Get_Scalar_Lower_Bound);
function Get_Scalar_Upper_Bound
(Constraints : Constraint_Descriptor) return Integer is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return Constraints.Constraint_2;
end Get_Scalar_Upper_Bound;
-- pragma Inline (Get_Scalar_Upper_Bound);
function Get_Long_Scalar_Lower_Bound
(Constraints : Constraint_Descriptor) return Long_Float is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return Cnvt (Constraints.Constraint_1'Address).all;
end Get_Long_Scalar_Lower_Bound;
-- pragma Inline (Get_Long_Scalar_Lower_Bound);
function Get_Long_Scalar_Upper_Bound
(Constraints : Constraint_Descriptor) return Long_Float is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return Cnvt (Constraints.Constraint_3'Address).all;
end Get_Long_Scalar_Upper_Bound;
-- pragma Inline (Get_Long_Scalar_Upper_Bound);
function Get_Dope_Vector_Address
(Constraints : Constraint_Descriptor) return System.Address is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return To_Address (Constraints.Constraint_1);
end Get_Dope_Vector_Address;
-- pragma Inline (Get_Dope_Vector_Address);
function Get_Dope_Vector_Size
(Constraints : Constraint_Descriptor) return Integer is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return Constraints.Constraint_2;
end Get_Dope_Vector_Size;
-- pragma Inline (Get_Dope_Vector_Size);
function Get_Dscrmt_Record_Satisfies_Subp
(Constraints : Constraint_Descriptor)
return Subprogram_Variable is
pragma Routine_Number (Runtime_Ids.Internal);
begin
return Cnvt (Constraints.Constraint_2'Address).all;
end Get_Dscrmt_Record_Satisfies_Subp;
-- pragma Inline (Get_Dscrmt_Record_Satisfies_Subp);
function Get_Dscrmt_Record_Satisfies_Subp
(Type_Desc : Type_Descriptor) return Subprogram_Variable is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Type_Desc.Type_Kind = Constrained_Records then
return Get_Dscrmt_Record_Satisfies_Subp (Type_Desc.Constraints);
else
return Nil_Subprogram_Variable;
end if;
end Get_Dscrmt_Record_Satisfies_Subp;
-- pragma Inline (Get_Dscrmt_Record_Satisfies_Subp);
procedure Bogus_Value_Op (Exp : Expression) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
pragma Assert (False);
null;
end Bogus_Value_Op;
procedure Bogus_Data_Op (Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
pragma Assert (False);
null;
end Bogus_Data_Op;
procedure Bogus_Unconstrained_Array_Op (Exp_Dope : Dope_Vector;
Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
pragma Assert (False);
null;
end Bogus_Unconstrained_Array_Op;
procedure Bogus_Unconstrained_Record_Op (Exp_Constrained : Boolean;
Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
pragma Assert (False);
null;
end Bogus_Unconstrained_Record_Op;
function Get_Value_Size (Type_Desc : Type_Descriptor;
Value : Expression;
Value_Kind : Expression_Kind) return Integer is
pragma Routine_Number (N => Runtime_Ids.Internal);
begin
case Type_Desc.Type_Kind is
when Unconstrained_Arrays | Unconstrained_Records =>
null;
when Constrained_Arrays | Constrained_Records =>
case Value_Kind is
when Formal_Object | Formal_Object_Ref |
Formal_Heterogeneous_Allocator =>
null;
when others =>
return Type_Desc.Size;
end case;
when others =>
return Type_Desc.Size;
end case;
return Asm_Interface.Value_Size
(Subp => Type_Desc.Value_Size_Subp,
Type_Desc => Type_Desc,
Exp => Value,
Exp_Kind => Value_Kind);
end Get_Value_Size;
-- This routine packs Dat into an Expression at the proper bytes
-- appropriate for this target.
function Data_To_Expression (Dat : Data;
Constraints : Constraint_Descriptor)
return Expression is
pragma Routine_Number (Runtime_Ids.Internal);
Is_Signed : Boolean;
Is_Negative : Boolean;
Result : Word;
begin
-- A scalar type is signed iff the lower bound of the constraint
-- is negative. The value is negative iff the type is signed and
-- the first byte has the high bit turned on. We can check for
-- this by checking that the first byte is greater than or equal
-- to the value of the byte High_Bit_Only which has only the high
-- bit turned on.
Is_Signed := Get_Scalar_Lower_Bound (Constraints) < 0;
Is_Negative := Is_Signed and then Dat (Dat'First) >= High_Bit_Only;
if Target.Bytes_Are_Backwards then
Result (Result'First .. Result'First + Dat'Length - 1) := Dat;
for I in Result'First + Dat'Length .. Result'Last loop
Result (I) := Extension_Byte (Is_Negative);
end loop;
else
for I in Result'First .. Result'Last - Dat'Length loop
Result (I) := Extension_Byte (Is_Negative);
end loop;
Result (Result'Last - Dat'Length + 1 .. Result'Last) := Dat;
end if;
return Cnvt (Result);
end Data_To_Expression;
-- This function is used to compute the address of the data portion
-- of a scalar that is stored in an expression. Note that the scalar
-- may be stored in the low bytes or high bytes depending on whether
-- Target.Bytes_Are_Backwards is False or True (respectively).
--
-- Note that this function must be given the ADDRESS of an expression,
-- and not its value as its first parameter. You may ask why we cannot
-- implement it by giving a value. Well, taking the 'Address of the
-- expression refers to the address of a parameter passed by value (YUK!),
-- and hence the computation refers to bogus stuff for the caller when
-- this function has returned. So, we REQUIRE the caller to call this
-- function with the 'Address of the value.
function Get_Scalar_Data_Address
(Scalar_Value_Address : System.Address;
Scalar_Size : Positive) return System.Address is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Target.Bytes_Are_Backwards then
return Scalar_Value_Address;
else
-- Note that the parenthesis is important to ensure that we ONLY do
-- addition of an integer to a System.Address
return Scalar_Value_Address +
(Target.Bytes_Per_Address - Scalar_Size);
end if;
end Get_Scalar_Data_Address;
-- pragma Inline (Get_Scalar_Data_Address);
-- Compare Size bytes from Left and Right
function Equal_Indirect (Left : System.Address;
Right : System.Address;
Size : Integer) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
package Data_Subtype is new Establish_Data_Subtype (Size);
Left_Data_Ref : constant Data_Subtype.Data_Ref :=
Data_Subtype.Cnvt (Left);
Left_Data : Data_Subtype.Actual_Data
renames Left_Data_Ref.all;
Right_Data_Ref : constant Data_Subtype.Data_Ref :=
Data_Subtype.Cnvt (Right);
Right_Data : Data_Subtype.Actual_Data
renames Right_Data_Ref.all;
begin
return Left_Data = Right_Data;
end Equal_Indirect;
--[] Currently not used
procedure Clear_Indirect (Dest : System.Address;
Size : Integer) is
pragma Routine_Number (Runtime_Ids.Internal);
package Data_Subtype is new Establish_Data_Subtype (Size);
Dest_Data_Ref : constant Data_Subtype.Data_Ref :=
Data_Subtype.Cnvt (Dest);
Dest_Data : Data_Subtype.Actual_Data
renames Dest_Data_Ref.all;
begin
-- Faster to assign elements one by one rather than building
-- an aggregate and copying it.
for I in Dest_Data'Range loop
Dest_Data (I) := 0;
end loop;
end Clear_Indirect;
-- Copy Size bytes from Source to Dest
procedure Copy_Indirect (Dest : System.Address;
Source : System.Address;
Size : Integer) is
pragma Routine_Number (Runtime_Ids.Internal);
package Data_Subtype is new Establish_Data_Subtype (Size);
Dest_Data_Ref : constant Data_Subtype.Data_Ref :=
Data_Subtype.Cnvt (Dest);
Dest_Data : Data_Subtype.Actual_Data
renames Dest_Data_Ref.all;
Source_Data_Ref : constant Data_Subtype.Data_Ref :=
Data_Subtype.Cnvt (Source);
Source_Data : Data_Subtype.Actual_Data
renames Source_Data_Ref.all;
begin
Dest_Data := Source_Data;
end Copy_Indirect;
function Get_Expression (Exp_Address : System.Address;
Exp_Kind : Expression_Kind)
return Expression is
pragma Routine_Number (Runtime_Ids.Internal);
begin
case Exp_Kind is
when Nil_Kind =>
return Nil_Expression;
when Local_Object | Formal_Object =>
-- The Expression to dispatch on is referenced by
-- Exp_Address
return Cnvt (Exp_Address).all;
when others =>
-- Exp_Address is to be interpreted as the address of the
-- data or the (dv,data) pair.
return Expression (Exp_Address);
end case;
end Get_Expression;
-- Internal stubs
package body Asm_Interface is separate;
procedure Unary_Dispatch (Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind) is separate;
procedure Binary_Dispatch (Type_Desc : Type_Descriptor;
Exp_1 : Expression;
Exp_1_Kind : Expression_Kind;
Exp_2 : Expression;
Exp_2_Kind : Expression_Kind) is separate;
procedure Two_Kind_Binary_Dispatch
(Type_Desc_1 : Type_Descriptor;
Exp_1 : Expression;
Exp_1_Kind : Expression_Kind;
Type_Desc_2 : Type_Descriptor;
Exp_2 : Expression;
Exp_2_Kind : Expression_Kind) is separate;
package body Debug is separate;
package body Satisfies_Ops is separate;
package body Short_Pointer_Ops is separate;
procedure Copy_Expression_Generic
(Type_Desc : Type_Descriptor;
Source : Expression;
Source_Kind : Expression_Kind;
Dest_Address : System.Address;
Dest_Kind : Expression_Kind;
Dest_Constraints : Constraint_Descriptor;
Chk : Copy_Check_Kind) is separate;
-- Exported subprograms follow
procedure Copy (Type_Desc : Type_Descriptor;
Source : Expression;
Source_Kind : Expression_Kind;
Dest_Address : System.Address;
Dest_Kind : Expression_Kind;
Dest_Constraints : Constraint_Descriptor;
Chk : Copy_Check_Kind) is separate;
function Convert (Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind;
Target_Kind : Conversion_Kind;
Uncons_Desc_Address : System.Address;
Chk : Check_Kind) return Expression is separate;
function Satisfies (Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind;
Chk : Check_Kind) return Boolean is separate;
function Equal (Type_Desc : Type_Descriptor;
Left : Expression;
Left_Kind : Expression_Kind;
Right : Expression;
Right_Kind : Expression_Kind) return Boolean is separate;
function Allocate (Type_Desc : Type_Descriptor;
Collection_Or_Heap : System.Address;
Is_Collection : Boolean;
Is_Homogenous : Boolean;
Initial_Value : Expression;
Initial_Value_Kind : Expression_Kind;
Master_Layer : System.Address;
Activation_Group : System.Address)
return System.Address is separate;
function Return_Value (Type_Desc : Type_Descriptor;
Exp : Expression;
Exp_Kind : Expression_Kind;
Size_Address : System.Address;
Result_Address : System.Address;
Result_Kind : Conversion_Kind)
return System.Address is separate;
procedure Unchecked_Convert (Source : Expression;
Source_Desc : Type_Descriptor;
Source_Kind : Expression_Kind;
Source_Size : Integer;
Target_Address : System.Address;
Target_Desc : Type_Descriptor;
Target_Kind : Expression_Kind;
Target_Size : Integer) is separate;
procedure Unchecked_Deallocate (Collection : System.Address;
Cell : Storage_Management.Address_Ref;
Desc : Type_Descriptor;
Kind : Expression_Kind) is separate;
end Shared_Code_Generic_Support;
pragma Export_Elaboration_Procedure ("__SCG_BODY");
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);