|
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: 7418 (0x1cfa)
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)
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
pragma Suppress_All;
pragma Routine_Number (Runtime_Ids.Internal);
Result : Expression;
procedure Value_Op (Exp_1 : Expression) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
-- Local_Object and Formal_Object are identical
Result := Exp_1;
end Value_Op;
-- pragma Inline (Value_Op);
procedure Unconstrained_Array_Op (Exp_Dope_Address : System.Address;
Exp_Data_Address : System.Address) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
case Data_Kind_Of (Type_Desc.Type_Kind, Target_Kind) is
when Unconstrained_Array_Desc_Ptr =>
declare
Uncons_Desc_Ref : constant Unconstrained_Descriptor_Ref :=
Cnvt (Uncons_Desc_Address);
begin
Uncons_Desc_Ref.all.Data := Exp_Data_Address;
Uncons_Desc_Ref.all.Constraint := Exp_Dope_Address;
-- The result is the address of the unconstrained descriptor
Result := Expression (Uncons_Desc_Address);
end;
when Data_Ptr =>
Result := Expression (Exp_Data_Address);
when others =>
pragma Assert (False);
null;
end case;
end Unconstrained_Array_Op;
-- pragma Inline (Unconstrained_Array_Op);
procedure Unconstrained_Array_Op (Exp_Dope : Dope_Vector;
Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
-- Local_Object and Formal_Object are identical
Unconstrained_Array_Op (Exp_Dope_Address => Exp_Dope'Address,
Exp_Data_Address => Exp_Data'Address);
end Unconstrained_Array_Op;
-- pragma Inline (Unconstrained_Array_Op);
procedure Unconstrained_Record_Op (Exp_Constrained : Boolean;
Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
case Data_Kind_Of (Type_Desc.Type_Kind, Target_Kind) is
when Unconstrained_Record_Desc_Ptr =>
declare
Uncons_Desc_Ref : constant Unconstrained_Descriptor_Ref :=
Cnvt (Uncons_Desc_Address);
Constrained_Ref : constant Boolean_Ref :=
Cnvt (Uncons_Desc_Ref.all.Constraint'Address);
begin
-- Local_Object and Formal_Object are identical
Uncons_Desc_Ref.all.Data := Exp_Data'Address;
Constrained_Ref.all := Exp_Constrained;
-- The result is the address of the unconstrained descriptor
Result := Expression (Uncons_Desc_Address);
end;
when Data_Ptr =>
Result := Expression (Exp_Data'Address);
when others =>
pragma Assert (False);
null;
end case;
end Unconstrained_Record_Op;
-- pragma Inline (Unconstrained_Record_Op);
procedure Data_Op (Exp_Data : in out Data) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
case Type_Desc.Type_Kind is
when Scalars =>
Result := Data_To_Expression (Exp_Data, Type_Desc.Constraints);
when Accesses =>
Result := Data_To_Expression (Exp_Data, Type_Desc.Constraints);
if Target.Supports_Segmented_Heaps and then
Type_Desc.Is_Short_Pointer then
Result := Short_Pointer_Ops.Short_To_Long (Exp_Data);
else
Result := Data_To_Expression
(Exp_Data, Type_Desc.Constraints);
end if;
when Long_Scalars =>
-- The Uncons_Desc_Address is regarded as a location into
-- which the value of this long scalar is to be copied for
-- value result semantics. The result is the address of
-- the destination.
Copy_Indirect (Dest => Uncons_Desc_Address,
Source => Exp_Data'Address,
Size => Type_Desc.Size);
Result := Expression (Uncons_Desc_Address);
when Simple_Records =>
Result := Expression (Exp_Data'Address);
when Constrained_Records =>
case Target_Kind is
when Local_Object =>
Result := Expression (Exp_Data'Address);
when Formal_Object =>
Unconstrained_Record_Op
(Exp_Constrained => True,
Exp_Data => Exp_Data);
end case;
when Constrained_Arrays =>
case Target_Kind is
when Local_Object =>
Result := Expression (Exp_Data'Address);
when Formal_Object =>
Unconstrained_Array_Op
(Exp_Dope_Address => Get_Dope_Vector_Address
(Type_Desc.Constraints),
Exp_Data_Address => Exp_Data'Address);
end case;
when Unconstrained_Records =>
Unconstrained_Record_Op
(Exp_Constrained => True,
Exp_Data => Exp_Data);
when Unconstrained_Arrays =>
Unconstrained_Array_Op
(Exp_Dope_Address => Get_Dope_Vector_Address
(Type_Desc.Constraints),
Exp_Data_Address => Exp_Data'Address);
when Tasks =>
Result := Data_To_Expression (Exp_Data, Type_Desc.Constraints);
end case;
end Data_Op;
-- pragma Inline (Data_Op);
procedure Dispatch is new Unary_Dispatch (Value_Op,
Data_Op,
Unconstrained_Array_Op,
Unconstrained_Record_Op,
Get_Value_Size);
-- pragma Inline (Dispatch);
begin
if not Satisfies (Type_Desc, Exp, Exp_Kind, Chk) then
raise Constraint_Error;
end if;
-- Except in the case of Long_Scalars, this operation is
-- a noop when Target_Kind = Exp_Kind.
if Type_Desc.Type_Kind /= Long_Scalars and then
Target_Kind = Exp_Kind then
return Exp;
end if;
Dispatch (Type_Desc, Exp, Exp_Kind);
return Result;
end Convert;
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);