|
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: 8305 (0x2071)
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)
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
pragma Suppress_All;
pragma Routine_Number (Runtime_Ids.Internal);
procedure Value_Op (Source_Exp : Expression;
Dest_Exp : Expression) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
-- Note that when we have Value's, a short pointer is really
-- a long pointer, and hence we need not special case them.
if not Satisfies_Ops.Satisfies_Value
(Type_Desc => Type_Desc,
Exp => Source_Exp,
Constraints => Dest_Constraints,
Type_Kind => Type_Desc.Type_Kind,
Size => Type_Desc.Size,
Chk => Chk) then
raise Constraint_Error;
end if;
-- In case Type_Desc.Size < Bytes_Per_Integer, this will copy
-- some garbage bytes. Thats ok!
Cnvt (Dest_Address).all := Source_Exp;
end Value_Op;
-- pragma Inline (Value_Op);
procedure Data_Op (Source_Data : in out Data;
Dest_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Target.Supports_Segmented_Heaps and then
Type_Desc.Is_Short_Pointer then
if not Satisfies_Ops.Satisfies_Value
(Type_Desc => Type_Desc,
Exp => Short_Pointer_Ops.Short_To_Long
(Source_Data),
Constraints => Dest_Constraints,
Type_Kind => Type_Desc.Type_Kind,
Size => Type_Desc.Size,
Chk => Chk) then
raise Constraint_Error;
end if;
Short_Pointer_Ops.Copy_Data_To_Data (Source_Data, Dest_Address);
return;
end if;
if not Satisfies_Ops.Satisfies_Data
(Type_Desc => Type_Desc,
Exp_Data => Source_Data,
Constraints => Dest_Constraints,
Type_Kind => Type_Desc.Type_Kind,
Size => Type_Desc.Size,
Chk => Chk) then
raise Constraint_Error;
end if;
Dest_Data := Source_Data;
end Data_Op;
-- pragma Inline (Data_Op);
procedure Value_Data_Op (Source_Exp : Expression;
Dest_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Target.Supports_Segmented_Heaps and then
Type_Desc.Is_Short_Pointer then
if not Satisfies_Ops.Satisfies_Value
(Type_Desc => Type_Desc,
Exp => Source_Exp,
Constraints => Dest_Constraints,
Type_Kind => Type_Desc.Type_Kind,
Size => Type_Desc.Size,
Chk => Chk) then
raise Constraint_Error;
end if;
Short_Pointer_Ops.Copy_Value_To_Data (Source_Exp, Dest_Address);
return;
end if;
if not Satisfies_Ops.Satisfies_Value
(Type_Desc => Type_Desc,
Exp => Source_Exp,
Constraints => Dest_Constraints,
Type_Kind => Type_Desc.Type_Kind,
Size => Type_Desc.Size,
Chk => Chk) then
raise Constraint_Error;
end if;
Copy_Indirect (Dest => Dest_Data'Address,
Source => Get_Scalar_Data_Address
(Source_Exp'Address, Type_Desc.Size),
Size => Type_Desc.Size);
end Value_Data_Op;
-- pragma Inline (Value_Data_Op);
procedure Data_Value_Op (Source_Data : in out Data;
Dest_Exp : Expression) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if Target.Supports_Segmented_Heaps and then
Type_Desc.Is_Short_Pointer then
if not Satisfies_Ops.Satisfies_Value
(Type_Desc => Type_Desc,
Exp => Short_Pointer_Ops.Short_To_Long
(Source_Data),
Constraints => Dest_Constraints,
Type_Kind => Type_Desc.Type_Kind,
Size => Type_Desc.Size,
Chk => Chk) then
raise Constraint_Error;
end if;
Short_Pointer_Ops.Copy_Data_To_Value (Source_Data, Dest_Address);
return;
end if;
if not Satisfies_Ops.Satisfies_Data
(Type_Desc => Type_Desc,
Exp_Data => Source_Data,
Constraints => Dest_Constraints,
Type_Kind => Type_Desc.Type_Kind,
Size => Type_Desc.Size,
Chk => Chk) then
raise Constraint_Error;
end if;
-- Tricky! Note that Dest must be a Value. So we put the
-- result in the PROPER portion of the Dest_Address!
Copy_Indirect (Dest => Get_Scalar_Data_Address
(Dest_Address, Type_Desc.Size),
Source => Source_Data'Address,
Size => Type_Desc.Size);
end Data_Value_Op;
-- pragma Inline (Data_Value_Op);
procedure Unconstrained_Array_Op (Source_Dope : Dope_Vector;
Source_Data : in out Data;
Dest_Dope : Dope_Vector;
Dest_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
if not Satisfies_Ops.Satisfies_Unconstrained_Array
(Exp_Dope => Source_Dope,
Constraints => Dest_Constraints,
Chk => Chk) then
raise Constraint_Error;
end if;
Dest_Data := Source_Data;
end Unconstrained_Array_Op;
-- pragma Inline (Unconstrained_Array_Op);
procedure Unconstrained_Record_Op (Source_Constrained : Boolean;
Source_Data : in out Data;
Dest_Constrained : Boolean;
Dest_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
-- Note that if we got here, Type_Desc.Dscrmt_Record_Assign_
-- Subp must be nil.
Dest_Data := Source_Data;
end Unconstrained_Record_Op;
-- pragma Inline (Unconstrained_Record_Op);
procedure Dispatch is new Binary_Dispatch (Value_Op,
Data_Op,
Value_Data_Op,
Data_Value_Op,
Unconstrained_Array_Op,
Unconstrained_Record_Op,
Get_Value_Size);
-- pragma Inline (Dispatch);
begin
Dispatch (Type_Desc => Type_Desc,
Exp_1 => Source,
Exp_1_Kind => Source_Kind,
Exp_2 => Get_Expression (Dest_Address, Dest_Kind),
Exp_2_Kind => Dest_Kind);
end Copy_Expression_Generic;
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);