|
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: 12628 (0x3154)
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 Satisfies_Ops is
pragma Suppress_All;
-- Check that the two dope vectors satisfy the given check. Note that
-- Dope_1 and Dope_2 will always have the same bounds
function Dopes_Satisfy_Check (Dope_1 : Dope_Vector;
Dope_2 : Dope_Vector;
Chk : Check_Kind) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
begin
case Chk is
when Nil_Check =>
return True;
when Length_Check =>
for I in Dope_1'Range loop
if Dope_1 (I).Size /= Dope_2 (I).Size then
return False;
end if;
end loop;
return True;
when Subtype_Check =>
return Dope_1 = Dope_2;
end case;
end Dopes_Satisfy_Check;
function Dopes_Satisfy_Check (Dope : Dope_Vector;
Constraints : Constraint_Descriptor;
Chk : Check_Kind) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
package Dv_Subtype is new Establish_Dope_Vector_Subtype
(Get_Dope_Vector_Size (Constraints));
Constraints_Dope_Ref : constant Dv_Subtype.Dope_Ref :=
Dv_Subtype.Cnvt (Get_Dope_Vector_Address (Constraints));
Constraints_Dope : Dv_Subtype.Actual_Dope
renames Constraints_Dope_Ref.all;
begin
return Dopes_Satisfy_Check (Dope_1 => Dope,
Dope_2 => Constraints_Dope,
Chk => Chk);
end Dopes_Satisfy_Check;
function Dopes_Satisfy_Check (Dope_Vector_Address : System.Address;
Constraints : Constraint_Descriptor;
Chk : Check_Kind) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
package Dv_Subtype is new Establish_Dope_Vector_Subtype
(Get_Dope_Vector_Size (Constraints));
Dope_Ref : constant Dv_Subtype.Dope_Ref :=
Dv_Subtype.Cnvt (Dope_Vector_Address);
Dope : Dv_Subtype.Actual_Dope
renames Dope_Ref.all;
Constraints_Dope_Ref : constant Dv_Subtype.Dope_Ref :=
Dv_Subtype.Cnvt (Get_Dope_Vector_Address (Constraints));
Constraints_Dope : Dv_Subtype.Actual_Dope
renames Constraints_Dope_Ref.all;
begin
return Dopes_Satisfy_Check (Dope_1 => Dope,
Dope_2 => Constraints_Dope,
Chk => Chk);
end Dopes_Satisfy_Check;
-- Normalize Exp by sign extension (thus the unused bytes in the
-- Expression get sign extended, and we can convert it to an
-- integer).
function Normalize (Exp : Expression;
Constraints : Constraint_Descriptor;
Size : Integer) return Expression is
pragma Routine_Number (Runtime_Ids.Internal);
begin
-- Special case an Exp that does not need sign extension.
if Size = Target.Bytes_Per_Integer then
return Exp;
end if;
declare
package Data_Subtype is new Establish_Data_Subtype (Size);
Data_Ref : constant Data_Subtype.Data_Ref :=
Data_Subtype.Cnvt (Get_Scalar_Data_Address
(Exp'Address, Size));
begin
return Data_To_Expression (Data_Ref.all, Constraints);
end;
end Normalize;
-- Since access types may be constrained, we have the following
-- three situations to consider:
--
-- type Array_Type is array (Integer range <>) of Integer;
-- type Record_Type (D : Boolean) is
-- record
-- X : Integer;
-- end record;
--
-- type Access_Array is access Array_Type;
-- subtype Constrained_Access_Array is Access_Array (1 .. 5);
-- type Access_Record is access Record_Type;
-- subtype Constrained_Access_Record is Access_Record (False);
--
-- We distinguish between "Normal" access types, and "Constrained"
-- access types which get their constraints by applying a const-
-- raint to an access type. Thus, in the above, we have:
--
-- Normal access : Access_Array, Access_Record
-- Constrained access to array : Constrained_Access_Array
-- Constrained access to record : Constrained_Access_Record
--
-- In the case of the two "Constrained" access types, we need to
-- do constraint checks.
--
-- When the Type_Kind is Accesses, we can distinguish between
-- the above cases as follows:
--
-- Dope_Vector_Address (i.e. Constraint_1) is 0 and
-- Dscrmt_Record_Satisfies_Subp (i.e. Constraint_2) is nil =>
-- Normal access
--
-- Dope_Vector_Address /= 0 =>
-- Constrained access to array
--
-- Dscrmt_Record_Satisfies_Subp is non-nil =>
-- Constrained access to record
--
-- Now for the constraint information:
--
-- Normal access : no constraint information
-- Constrained access to array : Constraints as in Constrained_
-- Arrays.
-- Constrained access to record : Constraints as in Constrained_
-- Records.
function Satisfies_Accesses (Type_Desc : Type_Descriptor;
Exp : Expression;
Constraints : Constraint_Descriptor;
Chk : Check_Kind) return Boolean is
pragma Routine_Number (N => Runtime_Ids.Internal);
begin
if Get_Dope_Vector_Address (Constraints) /= System.Address_Zero then
-- Designated type is an array type and the collection is
-- heterogeneous. Hence, Exp points at a (Dv,Data) pair.
-- So the address of the dope vector for Exp is pointed to
-- by Exp.
return Dopes_Satisfy_Check
(Dope_Vector_Address => System.Address (Exp),
Constraints => Constraints,
Chk => Chk);
else
declare
Satisfies_Subp : constant Subprogram_Variable :=
Get_Dscrmt_Record_Satisfies_Subp (Constraints);
begin
if Satisfies_Subp.Code /= Nil_Code then
-- Designated type is a discriminated record. We will
-- pretend that the Exp_Kind is Allocator so that the
-- Satisfies_Subp will know that Exp points to the data.
return Asm_Interface.Dscrmt_Record_Satisfies
(Subp => Satisfies_Subp,
Type_Desc => Type_Desc,
Exp => Exp,
Exp_Kind => Allocator);
else
-- Collection is homogeneous
return True;
end if;
end;
end if;
end Satisfies_Accesses;
-- Exported subprograms follow
function Satisfies_Value (Type_Desc : Type_Descriptor;
Exp : Expression;
Constraints : Constraint_Descriptor;
Type_Kind : Formal_Type_Kind;
Size : Integer;
Chk : Check_Kind) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Chk = Nil_Check then
return True;
end if;
if Type_Kind = Accesses then
return Satisfies_Accesses (Type_Desc, Exp, Constraints, Chk);
end if;
-- Must be Scalars
declare
Normalized_Exp : Expression;
begin
Normalized_Exp := Normalize (Exp, Constraints, Size);
return Integer (System.To_Integer
(System.Address (Normalized_Exp))) in
Get_Scalar_Lower_Bound (Constraints) ..
Get_Scalar_Upper_Bound (Constraints);
end;
end Satisfies_Value;
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 is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Chk = Nil_Check then
return True;
end if;
case Type_Kind is
when Scalars | Accesses =>
return Satisfies_Value (Type_Desc, Data_To_Expression
(Exp_Data, Constraints),
Constraints, Type_Kind, Size, Chk);
when Long_Scalars =>
return Cnvt (Exp_Data'Address).all in
Get_Long_Scalar_Lower_Bound (Constraints) ..
Get_Long_Scalar_Upper_Bound (Constraints);
when Constrained_Arrays =>
-- Can only do a length check
return Exp_Data'Length = Size;
when Unconstrained_Arrays =>
-- Impossible
raise Program_Error;
when Simple_Records =>
-- Trivially true
return True;
when Constrained_Records |
Unconstrained_Records =>
declare
Satisfies_Subp : constant Subprogram_Variable :=
Get_Dscrmt_Record_Satisfies_Subp (Constraints);
Exp_Data_Address : constant System.Address :=
Exp_Data'Address;
begin
if Satisfies_Subp.Code /= Nil_Code then
-- Designated type is a discriminated record. We
-- will pretend that the Exp_Kind is Allocator so
-- that the Satisfies_Subp will know that Exp points
-- to the data.
--[] Does not code with the following
-- return Asm_Interface.Dscrmt_Record_Satisfies
-- (Subp => Satisfies_Subp,
-- Exp => Expression (Exp_Data'Address),
-- Exp_Kind => Allocator);
return Asm_Interface.Dscrmt_Record_Satisfies
(Subp => Satisfies_Subp,
Type_Desc => Type_Desc,
Exp => Expression (Exp_Data_Address),
Exp_Kind => Allocator);
end if;
-- The satisfies subprogram did not exist. This can
-- happen for Unconstrained_Records when the Constr-
-- aints are from the type descriptor.
return True;
end;
when Tasks =>
-- Trivially True
return True;
end case;
end Satisfies_Data;
function Satisfies_Unconstrained_Array
(Exp_Dope : Dope_Vector;
Constraints : Constraint_Descriptor;
Chk : Check_Kind) return Boolean is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Chk = Nil_Check then
return True;
end if;
if Get_Dope_Vector_Address (Constraints) /= System.Address_Zero then
return Dopes_Satisfy_Check (Dope => Exp_Dope,
Constraints => Constraints,
Chk => Chk);
else
return True;
end if;
end Satisfies_Unconstrained_Array;
end Satisfies_Ops;
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);