- begin
- -- Create a constrained subtype of Storage_Array whose size
- -- corresponds to the value being assigned.
-
- -- subtype G is Storage_Offset range
- -- 1 .. (Expr'Size + Storage_Unit - 1) / Storage_Unit
-
- Expr := Duplicate_Subexpr_No_Checks (Expression (N));
-
- if Nkind (Expr) = N_Qualified_Expression then
- Expr := Expression (Expr);
- end if;
-
- Source_Actual_Subtype := Etype (Expr);
-
- if Has_Discriminants (Source_Actual_Subtype)
- and then not Is_Constrained (Source_Actual_Subtype)
- then
- Append_To (Res,
- Build_Actual_Subtype (Source_Actual_Subtype, Expr));
- Source_Actual_Subtype := Defining_Identifier (Last (Res));
- end if;
-
- Source_Size :=
- Make_Op_Add (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Source_Actual_Subtype, Loc),
- Attribute_Name => Name_Size),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => System_Storage_Unit - 1));
-
- Source_Size :=
- Make_Op_Divide (Loc,
- Left_Opnd => Source_Size,
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => System_Storage_Unit));
-
- Range_Type := Make_Temporary (Loc, 'G');
-
- Append_To (Res,
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Range_Type,
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Storage_Offset), Loc),
- Constraint => Make_Range_Constraint (Loc,
- Range_Expression =>
- Make_Range (Loc,
- Low_Bound => Make_Integer_Literal (Loc, 1),
- High_Bound => Source_Size)))));
-
- -- subtype S is Storage_Array (G)
-
- Append_To (Res,
- Make_Subtype_Declaration (Loc,
- Defining_Identifier => Make_Temporary (Loc, 'S'),
- Subtype_Indication =>
- Make_Subtype_Indication (Loc,
- Subtype_Mark =>
- New_Reference_To (RTE (RE_Storage_Array), Loc),
- Constraint =>
- Make_Index_Or_Discriminant_Constraint (Loc,
- Constraints =>
- New_List (New_Reference_To (Range_Type, Loc))))));
-
- -- type A is access S
-
- Opaque_Type := Make_Temporary (Loc, 'A');
-
- Append_To (Res,
- Make_Full_Type_Declaration (Loc,
- Defining_Identifier => Opaque_Type,
- Type_Definition =>
- Make_Access_To_Object_Definition (Loc,
- Subtype_Indication =>
- New_Occurrence_Of (
- Defining_Identifier (Last (Res)), Loc))));
-
- -- Generate appropriate slice assignments
-
- First_After_Root := Make_Integer_Literal (Loc, 1);
-
- -- For controlled object, skip Root_Controlled part
-
- if Is_Controlled (T) then
- First_After_Root :=
- Make_Op_Add (Loc,
- First_After_Root,
- Make_Op_Divide (Loc,
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (RTE (RE_Root_Controlled), Loc),
- Attribute_Name => Name_Size),
- Make_Integer_Literal (Loc, System_Storage_Unit)));
- end if;
-
- -- For the case of a record with controlled components, skip
- -- record controller Prev/Next components. These components
- -- constitute a 'hole' in the middle of the data to be copied.
-
- if Has_Controlled_Component (T) then
- Prev_Ref :=
- Make_Selected_Component (Loc,
- Prefix =>
- Make_Selected_Component (Loc,
- Prefix => Duplicate_Subexpr_No_Checks (L),
- Selector_Name =>
- New_Reference_To (Controller_Component (T), Loc)),
- Selector_Name => Make_Identifier (Loc, Name_Prev));
-
- -- Last index before hole: determined by position of the
- -- _Controller.Prev component.
-
- Last_Before_Hole := Make_Temporary (Loc, 'L');
-
- Append_To (Res,
- Make_Object_Declaration (Loc,
- Defining_Identifier => Last_Before_Hole,
- Object_Definition => New_Occurrence_Of (
- RTE (RE_Storage_Offset), Loc),
- Constant_Present => True,
- Expression =>
- Make_Op_Add (Loc,
- Make_Attribute_Reference (Loc,
- Prefix => Prev_Ref,
- Attribute_Name => Name_Position),
- Make_Attribute_Reference (Loc,
- Prefix => New_Copy_Tree (Prefix (Prev_Ref)),
- Attribute_Name => Name_Position))));
-
- -- Hole length: size of the Prev and Next components
-
- Hole_Length :=
- Make_Op_Multiply (Loc,
- Left_Opnd => Make_Integer_Literal (Loc, Uint_2),
- Right_Opnd =>
- Make_Op_Divide (Loc,
- Left_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Copy_Tree (Prev_Ref),
- Attribute_Name => Name_Size),
- Right_Opnd =>
- Make_Integer_Literal (Loc,
- Intval => System_Storage_Unit)));
-
- -- First index after hole
-
- First_After_Hole := Make_Temporary (Loc, 'F');