blob: 78f62a89d304c090092530c321c675e776e21b34 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ S T R M --
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Rtsfind; use Rtsfind;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Uintp; use Uintp;
package body Exp_Strm is
-----------------------
-- Local Subprograms --
-----------------------
procedure Build_Array_Read_Write_Procedure
(Nod : Node_Id;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Nam : Name_Id);
-- Common routine shared to build either an array Read procedure or an
-- array Write procedure, Nam is Name_Read or Name_Write to select which.
-- Pnam is the defining identifier for the constructed procedure. The
-- other parameters are as for Build_Array_Read_Procedure except that
-- the first parameter Nod supplies the Sloc to be used to generate code.
procedure Build_Record_Read_Write_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Nam : Name_Id);
-- Common routine shared to build a record Read Write procedure, Nam
-- is Name_Read or Name_Write to select which. Pnam is the defining
-- identifier for the constructed procedure. The other parameters are
-- as for Build_Record_Read_Procedure.
procedure Build_Stream_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : Entity_Id;
Decls : List_Id;
Stms : List_Id);
-- Called to build an array or record stream function. The first three
-- arguments are the same as Build_Record_Or_Elementary_Input_Function.
-- Decls and Stms are the declarations and statements for the body and
-- The parameter Fnam is the name of the constructed function.
function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
-- This function is used to test the type U_Type, to determine if it has
-- a standard representation from a streaming point of view. Standard means
-- that it has a standard representation (e.g. no enumeration rep clause),
-- and the size of the root type is the same as the streaming size (which
-- is defined as value specified by a Stream_Size clause if present, or
-- the Esize of U_Type if not).
function Make_Stream_Subprogram_Name
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id;
-- Return the entity that identifies the stream subprogram for type Typ
-- that is identified by the given Nam. This procedure deals with the
-- difference between tagged types (where a single subprogram associated
-- with the type is generated) and all other cases (where a subprogram
-- is generated at the point of the stream attribute reference). The
-- Loc parameter is used as the Sloc of the created entity.
function Stream_Base_Type (E : Entity_Id) return Entity_Id;
-- Stream attributes work on the basis of the base type except for the
-- array case. For the array case, we do not go to the base type, but
-- to the first subtype if it is constrained. This avoids problems with
-- incorrect conversions in the packed array case. Stream_Base_Type is
-- exactly this function (returns the base type, unless we have an array
-- type whose first subtype is constrained, in which case it returns the
-- first subtype).
--------------------------------
-- Build_Array_Input_Function --
--------------------------------
-- The function we build looks like
-- function typSI[_nnn] (S : access RST) return Typ is
-- L1 : constant Index_Type_1 := Index_Type_1'Input (S);
-- H1 : constant Index_Type_1 := Index_Type_1'Input (S);
-- L2 : constant Index_Type_2 := Index_Type_2'Input (S);
-- H2 : constant Index_Type_2 := Index_Type_2'Input (S);
-- ..
-- Ln : constant Index_Type_n := Index_Type_n'Input (S);
-- Hn : constant Index_Type_n := Index_Type_n'Input (S);
--
-- V : Typ'Base (L1 .. H1, L2 .. H2, ... Ln .. Hn)
-- begin
-- Typ'Read (S, V);
-- return V;
-- end typSI[_nnn]
-- Note: the suffix [_nnn] is present for untagged types, where we generate
-- a local subprogram at the point of the occurrence of the attribute
-- reference, so the name must be unique.
procedure Build_Array_Input_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id)
is
Dim : constant Pos := Number_Dimensions (Typ);
Lnam : Name_Id;
Hnam : Name_Id;
Decls : List_Id;
Ranges : List_Id;
Stms : List_Id;
Rstmt : Node_Id;
Indx : Node_Id;
Odecl : Node_Id;
begin
Decls := New_List;
Ranges := New_List;
Indx := First_Index (Typ);
for J in 1 .. Dim loop
Lnam := New_External_Name ('L', J);
Hnam := New_External_Name ('H', J);
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Lnam),
Constant_Present => True,
Object_Definition => New_Occurrence_Of (Etype (Indx), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
Attribute_Name => Name_Input,
Expressions => New_List (Make_Identifier (Loc, Name_S)))));
Append_To (Decls,
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Hnam),
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
Attribute_Name => Name_Input,
Expressions => New_List (Make_Identifier (Loc, Name_S)))));
Append_To (Ranges,
Make_Range (Loc,
Low_Bound => Make_Identifier (Loc, Lnam),
High_Bound => Make_Identifier (Loc, Hnam)));
Next_Index (Indx);
end loop;
-- If the type is constrained, use it directly. Otherwise build a
-- subtype indication with the proper bounds.
if Is_Constrained (Typ) then
Odecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
Object_Definition => New_Occurrence_Of (Typ, Loc));
else
Odecl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of (Stream_Base_Type (Typ), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc, Ranges)));
end if;
Rstmt :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V)));
Stms := New_List (
Make_Extended_Return_Statement (Loc,
Return_Object_Declarations => New_List (Odecl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc, New_List (Rstmt))));
Fnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input));
Build_Stream_Function (Loc, Typ, Decl, Fnam, Decls, Stms);
end Build_Array_Input_Function;
----------------------------------
-- Build_Array_Output_Procedure --
----------------------------------
procedure Build_Array_Output_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Stms : List_Id;
Indx : Node_Id;
begin
-- Build series of statements to output bounds
Indx := First_Index (Typ);
Stms := New_List;
for J in 1 .. Number_Dimensions (Typ) loop
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Attribute_Name => Name_First,
Expressions => New_List (
Make_Integer_Literal (Loc, J))))));
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Base_Type (Etype (Indx)), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Attribute_Name => Name_Last,
Expressions => New_List (
Make_Integer_Literal (Loc, J))))));
Next_Index (Indx);
end loop;
-- Append Write attribute to write array elements
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))));
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Output));
Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
end Build_Array_Output_Procedure;
--------------------------------
-- Build_Array_Read_Procedure --
--------------------------------
procedure Build_Array_Read_Procedure
(Nod : Node_Id;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
begin
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Read);
end Build_Array_Read_Procedure;
--------------------------------------
-- Build_Array_Read_Write_Procedure --
--------------------------------------
-- The form of the array read/write procedure is as follows:
-- procedure pnam (S : access RST, V : [out] Typ) is
-- begin
-- for L1 in V'Range (1) loop
-- for L2 in V'Range (2) loop
-- ...
-- for Ln in V'Range (n) loop
-- Component_Type'Read/Write (S, V (L1, L2, .. Ln));
-- end loop;
-- ..
-- end loop;
-- end loop
-- end pnam;
-- The out keyword for V is supplied in the Read case
procedure Build_Array_Read_Write_Procedure
(Nod : Node_Id;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Nam : Name_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
Ndim : constant Pos := Number_Dimensions (Typ);
Ctyp : constant Entity_Id := Component_Type (Typ);
Stm : Node_Id;
Exl : List_Id;
RW : Entity_Id;
begin
-- First build the inner attribute call
Exl := New_List;
for J in 1 .. Ndim loop
Append_To (Exl, Make_Identifier (Loc, New_External_Name ('L', J)));
end loop;
Stm :=
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Stream_Base_Type (Ctyp), Loc),
Attribute_Name => Nam,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Indexed_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Expressions => Exl)));
-- The corresponding stream attribute for the component type of the
-- array may be user-defined, and be frozen after the type for which
-- we are generating the stream subprogram. In that case, freeze the
-- stream attribute of the component type, whose declaration could not
-- generate any additional freezing actions in any case.
if Nam = Name_Read then
RW := TSS (Base_Type (Ctyp), TSS_Stream_Read);
else
RW := TSS (Base_Type (Ctyp), TSS_Stream_Write);
end if;
if Present (RW)
and then not Is_Frozen (RW)
then
Set_Is_Frozen (RW);
end if;
-- Now this is the big loop to wrap that statement up in a sequence
-- of loops. The first time around, Stm is the attribute call. The
-- second and subsequent times, Stm is an inner loop.
for J in 1 .. Ndim loop
Stm :=
Make_Implicit_Loop_Statement (Nod,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier =>
Make_Defining_Identifier (Loc,
Chars => New_External_Name ('L', Ndim - J + 1)),
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, Ndim - J + 1))))),
Statements => New_List (Stm));
end loop;
Build_Stream_Procedure
(Loc, Typ, Decl, Pnam, New_List (Stm), Nam = Name_Read);
end Build_Array_Read_Write_Procedure;
---------------------------------
-- Build_Array_Write_Procedure --
---------------------------------
procedure Build_Array_Write_Procedure
(Nod : Node_Id;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Loc : constant Source_Ptr := Sloc (Nod);
begin
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
Build_Array_Read_Write_Procedure (Nod, Typ, Decl, Pnam, Name_Write);
end Build_Array_Write_Procedure;
---------------------------------
-- Build_Elementary_Input_Call --
---------------------------------
function Build_Elementary_Input_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
P_Type : constant Entity_Id := Entity (Prefix (N));
U_Type : constant Entity_Id := Underlying_Type (P_Type);
Rt_Type : constant Entity_Id := Root_Type (U_Type);
FST : constant Entity_Id := First_Subtype (U_Type);
Strm : constant Node_Id := First (Expressions (N));
Targ : constant Node_Id := Next (Strm);
P_Size : constant Uint := Get_Stream_Size (FST);
Res : Node_Id;
Lib_RE : RE_Id;
begin
-- Check first for Boolean and Character. These are enumeration types,
-- but we treat them specially, since they may require special handling
-- in the transfer protocol. However, this special handling only applies
-- if they have standard representation, otherwise they are treated like
-- any other enumeration type.
if Rt_Type = Standard_Boolean
and then Has_Stream_Standard_Rep (U_Type)
then
Lib_RE := RE_I_B;
elsif Rt_Type = Standard_Character
and then Has_Stream_Standard_Rep (U_Type)
then
Lib_RE := RE_I_C;
elsif Rt_Type = Standard_Wide_Character
and then Has_Stream_Standard_Rep (U_Type)
then
Lib_RE := RE_I_WC;
elsif Rt_Type = Standard_Wide_Wide_Character
and then Has_Stream_Standard_Rep (U_Type)
then
Lib_RE := RE_I_WWC;
-- Floating point types
elsif Is_Floating_Point_Type (U_Type) then
-- Question: should we use P_Size or Rt_Type to distinguish between
-- possible floating point types? If a non-standard size or a stream
-- size is specified, then we should certainly use the size. But if
-- we have two types the same (notably Short_Float_Size = Float_Size
-- which is close to universally true, and Long_Long_Float_Size =
-- Long_Float_Size, true on most targets except the x86), then we
-- would really rather use the root type, so that if people want to
-- fiddle with System.Stream_Attributes to get inter-target portable
-- streams, they get the size they expect. Consider in particular the
-- case of a stream written on an x86, with 96-bit Long_Long_Float
-- being read into a non-x86 target with 64 bit Long_Long_Float. A
-- special version of System.Stream_Attributes can deal with this
-- provided the proper type is always used.
-- To deal with these two requirements we add the special checks
-- on equal sizes and use the root type to distinguish.
if P_Size <= Standard_Short_Float_Size
and then (Standard_Short_Float_Size /= Standard_Float_Size
or else Rt_Type = Standard_Short_Float)
then
Lib_RE := RE_I_SF;
elsif P_Size <= Standard_Float_Size then
Lib_RE := RE_I_F;
elsif P_Size <= Standard_Long_Float_Size
and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size
or else Rt_Type = Standard_Long_Float)
then
Lib_RE := RE_I_LF;
else
Lib_RE := RE_I_LLF;
end if;
-- Signed integer types. Also includes signed fixed-point types and
-- enumeration types with a signed representation.
-- Note on signed integer types. We do not consider types as signed for
-- this purpose if they have no negative numbers, or if they have biased
-- representation. The reason is that the value in either case basically
-- represents an unsigned value.
-- For example, consider:
-- type W is range 0 .. 2**32 - 1;
-- for W'Size use 32;
-- This is a signed type, but the representation is unsigned, and may
-- be outside the range of a 32-bit signed integer, so this must be
-- treated as 32-bit unsigned.
-- Similarly, if we have
-- type W is range -1 .. +254;
-- for W'Size use 8;
-- then the representation is unsigned
elsif not Is_Unsigned_Type (FST)
-- The following set of tests gets repeated many times, we should
-- have an abstraction defined ???
and then
(Is_Fixed_Point_Type (U_Type)
or else
Is_Enumeration_Type (U_Type)
or else
(Is_Signed_Integer_Type (U_Type)
and then not Has_Biased_Representation (FST)))
then
if P_Size <= Standard_Short_Short_Integer_Size then
Lib_RE := RE_I_SSI;
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_I_SI;
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_I_I;
elsif P_Size <= Standard_Long_Integer_Size then
Lib_RE := RE_I_LI;
else
Lib_RE := RE_I_LLI;
end if;
-- Unsigned integer types, also includes unsigned fixed-point types
-- and enumeration types with an unsigned representation (note that
-- we know they are unsigned because we already tested for signed).
-- Also includes signed integer types that are unsigned in the sense
-- that they do not include negative numbers. See above for details.
elsif Is_Modular_Integer_Type (U_Type)
or else Is_Fixed_Point_Type (U_Type)
or else Is_Enumeration_Type (U_Type)
or else Is_Signed_Integer_Type (U_Type)
then
if P_Size <= Standard_Short_Short_Integer_Size then
Lib_RE := RE_I_SSU;
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_I_SU;
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_I_U;
elsif P_Size <= Standard_Long_Integer_Size then
Lib_RE := RE_I_LU;
else
Lib_RE := RE_I_LLU;
end if;
else pragma Assert (Is_Access_Type (U_Type));
if P_Size > System_Address_Size then
Lib_RE := RE_I_AD;
else
Lib_RE := RE_I_AS;
end if;
end if;
-- Call the function, and do an unchecked conversion of the result
-- to the actual type of the prefix. If the target is a discriminant,
-- and we are in the body of the default implementation of a 'Read
-- attribute, set target type to force a constraint check (13.13.2(35)).
-- If the type of the discriminant is currently private, add another
-- unchecked conversion from the full view.
if Nkind (Targ) = N_Identifier
and then Is_Internal_Name (Chars (Targ))
and then Is_TSS (Scope (Entity (Targ)), TSS_Stream_Read)
then
Res :=
Unchecked_Convert_To (Base_Type (U_Type),
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
Parameter_Associations => New_List (
Relocate_Node (Strm))));
Set_Do_Range_Check (Res);
if Base_Type (P_Type) /= Base_Type (U_Type) then
Res := Unchecked_Convert_To (Base_Type (P_Type), Res);
end if;
return Res;
else
Res :=
Make_Function_Call (Loc,
Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
Parameter_Associations => New_List (
Relocate_Node (Strm)));
-- Now convert to the base type if we do not have a biased type. Note
-- that we did not do this in some older versions, and the result was
-- losing a required range check in the case where 'Input is being
-- called from 'Read.
if not Has_Biased_Representation (P_Type) then
return Unchecked_Convert_To (Base_Type (P_Type), Res);
-- For the biased case, the conversion to the base type loses the
-- biasing, so just convert to Ptype. This is not quite right, and
-- for example may lose a corner case CE test, but it is such a
-- rare case that for now we ignore it ???
else
return Unchecked_Convert_To (P_Type, Res);
end if;
end if;
end Build_Elementary_Input_Call;
---------------------------------
-- Build_Elementary_Write_Call --
---------------------------------
function Build_Elementary_Write_Call (N : Node_Id) return Node_Id is
Loc : constant Source_Ptr := Sloc (N);
P_Type : constant Entity_Id := Entity (Prefix (N));
U_Type : constant Entity_Id := Underlying_Type (P_Type);
Rt_Type : constant Entity_Id := Root_Type (U_Type);
FST : constant Entity_Id := First_Subtype (U_Type);
Strm : constant Node_Id := First (Expressions (N));
Item : constant Node_Id := Next (Strm);
P_Size : Uint;
Lib_RE : RE_Id;
Libent : Entity_Id;
begin
-- Compute the size of the stream element. This is either the size of
-- the first subtype or if given the size of the Stream_Size attribute.
if Has_Stream_Size_Clause (FST) then
P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
else
P_Size := Esize (FST);
end if;
-- Find the routine to be called
-- Check for First Boolean and Character. These are enumeration types,
-- but we treat them specially, since they may require special handling
-- in the transfer protocol. However, this special handling only applies
-- if they have standard representation, otherwise they are treated like
-- any other enumeration type.
if Rt_Type = Standard_Boolean
and then Has_Stream_Standard_Rep (U_Type)
then
Lib_RE := RE_W_B;
elsif Rt_Type = Standard_Character
and then Has_Stream_Standard_Rep (U_Type)
then
Lib_RE := RE_W_C;
elsif Rt_Type = Standard_Wide_Character
and then Has_Stream_Standard_Rep (U_Type)
then
Lib_RE := RE_W_WC;
elsif Rt_Type = Standard_Wide_Wide_Character
and then Has_Stream_Standard_Rep (U_Type)
then
Lib_RE := RE_W_WWC;
-- Floating point types
elsif Is_Floating_Point_Type (U_Type) then
-- Question: should we use P_Size or Rt_Type to distinguish between
-- possible floating point types? If a non-standard size or a stream
-- size is specified, then we should certainly use the size. But if
-- we have two types the same (notably Short_Float_Size = Float_Size
-- which is close to universally true, and Long_Long_Float_Size =
-- Long_Float_Size, true on most targets except the x86), then we
-- would really rather use the root type, so that if people want to
-- fiddle with System.Stream_Attributes to get inter-target portable
-- streams, they get the size they expect. Consider in particular the
-- case of a stream written on an x86, with 96-bit Long_Long_Float
-- being read into a non-x86 target with 64 bit Long_Long_Float. A
-- special version of System.Stream_Attributes can deal with this
-- provided the proper type is always used.
-- To deal with these two requirements we add the special checks
-- on equal sizes and use the root type to distinguish.
if P_Size <= Standard_Short_Float_Size
and then (Standard_Short_Float_Size /= Standard_Float_Size
or else Rt_Type = Standard_Short_Float)
then
Lib_RE := RE_W_SF;
elsif P_Size <= Standard_Float_Size then
Lib_RE := RE_W_F;
elsif P_Size <= Standard_Long_Float_Size
and then (Standard_Long_Float_Size /= Standard_Long_Long_Float_Size
or else Rt_Type = Standard_Long_Float)
then
Lib_RE := RE_W_LF;
else
Lib_RE := RE_W_LLF;
end if;
-- Signed integer types. Also includes signed fixed-point types and
-- signed enumeration types share this circuitry.
-- Note on signed integer types. We do not consider types as signed for
-- this purpose if they have no negative numbers, or if they have biased
-- representation. The reason is that the value in either case basically
-- represents an unsigned value.
-- For example, consider:
-- type W is range 0 .. 2**32 - 1;
-- for W'Size use 32;
-- This is a signed type, but the representation is unsigned, and may
-- be outside the range of a 32-bit signed integer, so this must be
-- treated as 32-bit unsigned.
-- Similarly, the representation is also unsigned if we have:
-- type W is range -1 .. +254;
-- for W'Size use 8;
-- forcing a biased and unsigned representation
elsif not Is_Unsigned_Type (FST)
and then
(Is_Fixed_Point_Type (U_Type)
or else
Is_Enumeration_Type (U_Type)
or else
(Is_Signed_Integer_Type (U_Type)
and then not Has_Biased_Representation (FST)))
then
if P_Size <= Standard_Short_Short_Integer_Size then
Lib_RE := RE_W_SSI;
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_W_SI;
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_W_I;
elsif P_Size <= Standard_Long_Integer_Size then
Lib_RE := RE_W_LI;
else
Lib_RE := RE_W_LLI;
end if;
-- Unsigned integer types, also includes unsigned fixed-point types
-- and unsigned enumeration types (note we know they are unsigned
-- because we already tested for signed above).
-- Also includes signed integer types that are unsigned in the sense
-- that they do not include negative numbers. See above for details.
elsif Is_Modular_Integer_Type (U_Type)
or else Is_Fixed_Point_Type (U_Type)
or else Is_Enumeration_Type (U_Type)
or else Is_Signed_Integer_Type (U_Type)
then
if P_Size <= Standard_Short_Short_Integer_Size then
Lib_RE := RE_W_SSU;
elsif P_Size <= Standard_Short_Integer_Size then
Lib_RE := RE_W_SU;
elsif P_Size <= Standard_Integer_Size then
Lib_RE := RE_W_U;
elsif P_Size <= Standard_Long_Integer_Size then
Lib_RE := RE_W_LU;
else
Lib_RE := RE_W_LLU;
end if;
else pragma Assert (Is_Access_Type (U_Type));
if P_Size > System_Address_Size then
Lib_RE := RE_W_AD;
else
Lib_RE := RE_W_AS;
end if;
end if;
-- Unchecked-convert parameter to the required type (i.e. the type of
-- the corresponding parameter, and call the appropriate routine.
Libent := RTE (Lib_RE);
return
Make_Procedure_Call_Statement (Loc,
Name => New_Occurrence_Of (Libent, Loc),
Parameter_Associations => New_List (
Relocate_Node (Strm),
Unchecked_Convert_To (Etype (Next_Formal (First_Formal (Libent))),
Relocate_Node (Item))));
end Build_Elementary_Write_Call;
-----------------------------------------
-- Build_Mutable_Record_Read_Procedure --
-----------------------------------------
procedure Build_Mutable_Record_Read_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Out_Formal : Node_Id;
-- Expression denoting the out formal parameter
Dcls : constant List_Id := New_List;
-- Declarations for the 'Read body
Stms : constant List_Id := New_List;
-- Statements for the 'Read body
Disc : Entity_Id;
-- Entity of the discriminant being processed
Tmp_For_Disc : Entity_Id;
-- Temporary object used to read the value of Disc
Tmps_For_Discs : constant List_Id := New_List;
-- List of object declarations for temporaries holding the read values
-- for the discriminants.
Cstr : constant List_Id := New_List;
-- List of constraints to be applied on temporary record
Discriminant_Checks : constant List_Id := New_List;
-- List of discriminant checks to be performed if the actual object
-- is constrained.
Tmp : constant Entity_Id := Make_Defining_Identifier (Loc, Name_V);
-- Temporary record must hide formal (assignments to components of the
-- record are always generated with V as the identifier for the record).
Constrained_Stms : List_Id := New_List;
-- Statements within the block where we have the constrained temporary
begin
-- A mutable type cannot be a tagged type, so we generate a new name
-- for the stream procedure.
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Read));
if Is_Unchecked_Union (Typ) then
-- If this is an unchecked union, the stream procedure is erroneous,
-- because there are no discriminants to read.
-- This should generate a warning ???
Append_To (Stms,
Make_Raise_Program_Error (Loc,
Reason => PE_Unchecked_Union_Restriction));
Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, Outp => True);
return;
end if;
Disc := First_Discriminant (Typ);
Out_Formal :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Pnam, Loc),
Selector_Name => Make_Identifier (Loc, Name_V));
-- Generate Reads for the discriminants of the type. The discriminants
-- need to be read before the rest of the components, so that variants
-- are initialized correctly. The discriminants must be read into temp
-- variables so an incomplete Read (interrupted by an exception, for
-- example) does not alter the passed object.
while Present (Disc) loop
Tmp_For_Disc := Make_Defining_Identifier (Loc,
New_External_Name (Chars (Disc), "D"));
Append_To (Tmps_For_Discs,
Make_Object_Declaration (Loc,
Defining_Identifier => Tmp_For_Disc,
Object_Definition => New_Occurrence_Of (Etype (Disc), Loc)));
Set_No_Initialization (Last (Tmps_For_Discs));
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etype (Disc), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
New_Occurrence_Of (Tmp_For_Disc, Loc))));
Append_To (Cstr,
Make_Discriminant_Association (Loc,
Selector_Names => New_List (New_Occurrence_Of (Disc, Loc)),
Expression => New_Occurrence_Of (Tmp_For_Disc, Loc)));
Append_To (Discriminant_Checks,
Make_Raise_Constraint_Error (Loc,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Occurrence_Of (Tmp_For_Disc, Loc),
Right_Opnd =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Out_Formal),
Selector_Name => New_Occurrence_Of (Disc, Loc))),
Reason => CE_Discriminant_Check_Failed));
Next_Discriminant (Disc);
end loop;
-- Generate reads for the components of the record (including those
-- that depend on discriminants).
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
-- Save original statement sequence for component assignments, and
-- replace it with Stms.
Constrained_Stms := Statements (Handled_Statement_Sequence (Decl));
Set_Handled_Statement_Sequence (Decl,
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
-- If Typ has controlled components (i.e. if it is classwide or
-- Has_Controlled), or components constrained using the discriminants
-- of Typ, then we need to ensure that all component assignments are
-- performed on an object that has been appropriately constrained
-- prior to being initialized. To this effect, we wrap the component
-- assignments in a block where V is a constrained temporary.
Append_To (Dcls,
Make_Object_Declaration (Loc,
Defining_Identifier => Tmp,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (Base_Type (Typ), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Cstr))));
-- AI05-023-1: Insert discriminant check prior to initialization of the
-- constrained temporary.
Append_To (Stms,
Make_Implicit_If_Statement (Pnam,
Condition =>
Make_Attribute_Reference (Loc,
Prefix => New_Copy_Tree (Out_Formal),
Attribute_Name => Name_Constrained),
Then_Statements => Discriminant_Checks));
-- Now insert back original component assignments, wrapped in a block
-- in which V is the constrained temporary.
Append_To (Stms,
Make_Block_Statement (Loc,
Declarations => Dcls,
Handled_Statement_Sequence => Parent (Constrained_Stms)));
Append_To (Constrained_Stms,
Make_Assignment_Statement (Loc,
Name => Out_Formal,
Expression => Make_Identifier (Loc, Name_V)));
Set_Declarations (Decl, Tmps_For_Discs);
end Build_Mutable_Record_Read_Procedure;
------------------------------------------
-- Build_Mutable_Record_Write_Procedure --
------------------------------------------
procedure Build_Mutable_Record_Write_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Stms : List_Id;
Disc : Entity_Id;
D_Ref : Node_Id;
begin
Stms := New_List;
Disc := First_Discriminant (Typ);
-- Generate Writes for the discriminants of the type
-- If the type is an unchecked union, use the default values of
-- the discriminants, because they are not stored.
while Present (Disc) loop
if Is_Unchecked_Union (Typ) then
D_Ref :=
New_Copy_Tree (Discriminant_Default_Value (Disc));
else
D_Ref :=
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Selector_Name => New_Occurrence_Of (Disc, Loc));
end if;
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etype (Disc), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
D_Ref)));
Next_Discriminant (Disc);
end loop;
-- A mutable type cannot be a tagged type, so we generate a new name
-- for the stream procedure.
Pnam :=
Make_Defining_Identifier (Loc,
Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Write));
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
-- Write the discriminants before the rest of the components, so
-- that discriminant values are properly set of variants, etc.
if Is_Non_Empty_List (
Statements (Handled_Statement_Sequence (Decl)))
then
Insert_List_Before
(First (Statements (Handled_Statement_Sequence (Decl))), Stms);
else
Set_Statements (Handled_Statement_Sequence (Decl), Stms);
end if;
end Build_Mutable_Record_Write_Procedure;
-----------------------------------------------
-- Build_Record_Or_Elementary_Input_Function --
-----------------------------------------------
-- The function we build looks like
-- function InputN (S : access RST) return Typ is
-- C1 : constant Disc_Type_1;
-- Discr_Type_1'Read (S, C1);
-- C2 : constant Disc_Type_2;
-- Discr_Type_2'Read (S, C2);
-- ...
-- Cn : constant Disc_Type_n;
-- Discr_Type_n'Read (S, Cn);
-- V : Typ (C1, C2, .. Cn)
-- begin
-- Typ'Read (S, V);
-- return V;
-- end InputN
-- The discriminants are of course only present in the case of a record
-- with discriminants. In the case of a record with no discriminants, or
-- an elementary type, then no Cn constants are defined.
procedure Build_Record_Or_Elementary_Input_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : out Entity_Id;
Use_Underlying : Boolean := True)
is
B_Typ : Entity_Id := Base_Type (Typ);
Cn : Name_Id;
Constr : List_Id;
Decls : List_Id;
Discr : Entity_Id;
Discr_Elmt : Elmt_Id := No_Elmt;
J : Pos;
Obj_Decl : Node_Id;
Odef : Node_Id;
Stms : List_Id;
begin
if Use_Underlying then
B_Typ := Underlying_Type (B_Typ);
end if;
Decls := New_List;
Constr := New_List;
J := 1;
-- In the presence of multiple instantiations (as in uses of the Booch
-- components) the base type may be private, and the underlying type
-- already constrained, in which case there's no discriminant constraint
-- to construct.
if Has_Discriminants (Typ)
and then No (Discriminant_Default_Value (First_Discriminant (Typ)))
and then not Is_Constrained (Underlying_Type (B_Typ))
then
Discr := First_Discriminant (B_Typ);
-- If the prefix subtype is constrained, then retrieve the first
-- element of its constraint.
if Is_Constrained (Typ) then
Discr_Elmt := First_Elmt (Discriminant_Constraint (Typ));
end if;
while Present (Discr) loop
Cn := New_External_Name ('C', J);
Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
Object_Definition =>
New_Occurrence_Of (Etype (Discr), Loc));
-- If this is an access discriminant, do not perform default
-- initialization. The discriminant is about to get its value
-- from Read, and if the type is null excluding we do not want
-- spurious warnings on an initial null value.
if Is_Access_Type (Etype (Discr)) then
Set_No_Initialization (Decl);
end if;
Append_To (Decls, Decl);
Append_To (Decls,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Etype (Discr), Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Cn))));
Append_To (Constr, Make_Identifier (Loc, Cn));
-- If the prefix subtype imposes a discriminant constraint, then
-- check that each discriminant value equals the value read.
if Present (Discr_Elmt) then
Append_To (Decls,
Make_Raise_Constraint_Error (Loc,
Condition => Make_Op_Ne (Loc,
Left_Opnd =>
New_Occurrence_Of
(Defining_Identifier (Decl), Loc),
Right_Opnd =>
New_Copy_Tree (Node (Discr_Elmt))),
Reason => CE_Discriminant_Check_Failed));
Next_Elmt (Discr_Elmt);
end if;
Next_Discriminant (Discr);
J := J + 1;
end loop;
Odef :=
Make_Subtype_Indication (Loc,
Subtype_Mark => New_Occurrence_Of (B_Typ, Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => Constr));
-- If no discriminants, then just use the type with no constraint
else
Odef := New_Occurrence_Of (B_Typ, Loc);
end if;
-- Create an extended return statement encapsulating the result object
-- and 'Read call, which is needed in general for proper handling of
-- build-in-place results (such as when the result type is inherently
-- limited).
Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
Object_Definition => Odef);
-- If the type is an access type, do not perform default initialization.
-- The object is about to get its value from Read, and if the type is
-- null excluding we do not want spurious warnings on an initial null.
if Is_Access_Type (B_Typ) then
Set_No_Initialization (Obj_Decl);
end if;
Stms := New_List (
Make_Extended_Return_Statement (Loc,
Return_Object_Declarations => New_List (Obj_Decl),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (B_Typ, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V)))))));
Fnam := Make_Stream_Subprogram_Name (Loc, B_Typ, TSS_Stream_Input);
Build_Stream_Function (Loc, B_Typ, Decl, Fnam, Decls, Stms);
end Build_Record_Or_Elementary_Input_Function;
-------------------------------------------------
-- Build_Record_Or_Elementary_Output_Procedure --
-------------------------------------------------
procedure Build_Record_Or_Elementary_Output_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
Stms : List_Id;
Disc : Entity_Id;
Disc_Ref : Node_Id;
begin
Stms := New_List;
-- Note that of course there will be no discriminants for the elementary
-- type case, so Has_Discriminants will be False. Note that the language
-- rules do not allow writing the discriminants in the defaulted case,
-- because those are written by 'Write.
if Has_Discriminants (Typ)
and then No (Discriminant_Default_Value (First_Discriminant (Typ)))
then
Disc := First_Discriminant (Typ);
while Present (Disc) loop
-- If the type is an unchecked union, it must have default
-- discriminants (this is checked earlier), and those defaults
-- are written out to the stream.
if Is_Unchecked_Union (Typ) then
Disc_Ref := New_Copy_Tree (Discriminant_Default_Value (Disc));
else
Disc_Ref :=
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Selector_Name => New_Occurrence_Of (Disc, Loc));
end if;
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Stream_Base_Type (Etype (Disc)), Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Disc_Ref)));
Next_Discriminant (Disc);
end loop;
end if;
Append_To (Stms,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Write,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))));
Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Output);
Build_Stream_Procedure (Loc, Typ, Decl, Pnam, Stms, False);
end Build_Record_Or_Elementary_Output_Procedure;
---------------------------------
-- Build_Record_Read_Procedure --
---------------------------------
procedure Build_Record_Read_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
begin
Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Read);
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
end Build_Record_Read_Procedure;
---------------------------------------
-- Build_Record_Read_Write_Procedure --
---------------------------------------
-- The form of the record read/write procedure is as shown by the
-- following example for a case with one discriminant case variant:
-- procedure pnam (S : access RST, V : [out] Typ) is
-- begin
-- Component_Type'Read/Write (S, V.component);
-- Component_Type'Read/Write (S, V.component);
-- ...
-- Component_Type'Read/Write (S, V.component);
--
-- case V.discriminant is
-- when choices =>
-- Component_Type'Read/Write (S, V.component);
-- Component_Type'Read/Write (S, V.component);
-- ...
-- Component_Type'Read/Write (S, V.component);
--
-- when choices =>
-- Component_Type'Read/Write (S, V.component);
-- Component_Type'Read/Write (S, V.component);
-- ...
-- Component_Type'Read/Write (S, V.component);
-- ...
-- end case;
-- end pnam;
-- The out keyword for V is supplied in the Read case
procedure Build_Record_Read_Write_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Nam : Name_Id)
is
Rdef : Node_Id;
Stms : List_Id;
Typt : Entity_Id;
In_Limited_Extension : Boolean := False;
-- Set to True while processing the record extension definition
-- for an extension of a limited type (for which an ancestor type
-- has an explicit Nam attribute definition).
function Make_Component_List_Attributes (CL : Node_Id) return List_Id;
-- Returns a sequence of attributes to process the components that
-- are referenced in the given component list.
function Make_Field_Attribute (C : Entity_Id) return Node_Id;
-- Given C, the entity for a discriminant or component, build
-- an attribute for the corresponding field values.
function Make_Field_Attributes (Clist : List_Id) return List_Id;
-- Given Clist, a component items list, construct series of attributes
-- for fieldwise processing of the corresponding components.
------------------------------------
-- Make_Component_List_Attributes --
------------------------------------
function Make_Component_List_Attributes (CL : Node_Id) return List_Id is
CI : constant List_Id := Component_Items (CL);
VP : constant Node_Id := Variant_Part (CL);
Result : List_Id;
Alts : List_Id;
V : Node_Id;
DC : Node_Id;
DCH : List_Id;
D_Ref : Node_Id;
begin
Result := Make_Field_Attributes (CI);
if Present (VP) then
Alts := New_List;
V := First_Non_Pragma (Variants (VP));
while Present (V) loop
DCH := New_List;
DC := First (Discrete_Choices (V));
while Present (DC) loop
Append_To (DCH, New_Copy_Tree (DC));
Next (DC);
end loop;
Append_To (Alts,
Make_Case_Statement_Alternative (Loc,
Discrete_Choices => DCH,
Statements =>
Make_Component_List_Attributes (Component_List (V))));
Next_Non_Pragma (V);
end loop;
-- Note: in the following, we make sure that we use new occurrence
-- of for the selector, since there are cases in which we make a
-- reference to a hidden discriminant that is not visible.
-- If the enclosing record is an unchecked_union, we use the
-- default expressions for the discriminant (it must exist)
-- because we cannot generate a reference to it, given that
-- it is not stored.
if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
D_Ref :=
New_Copy_Tree
(Discriminant_Default_Value (Entity (Name (VP))));
else
D_Ref :=
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Selector_Name =>
New_Occurrence_Of (Entity (Name (VP)), Loc));
end if;
Append_To (Result,
Make_Case_Statement (Loc,
Expression => D_Ref,
Alternatives => Alts));
end if;
return Result;
end Make_Component_List_Attributes;
--------------------------
-- Make_Field_Attribute --
--------------------------
function Make_Field_Attribute (C : Entity_Id) return Node_Id is
Field_Typ : constant Entity_Id := Stream_Base_Type (Etype (C));
TSS_Names : constant array (Name_Input .. Name_Write) of
TSS_Name_Type :=
(Name_Read => TSS_Stream_Read,
Name_Write => TSS_Stream_Write,
Name_Input => TSS_Stream_Input,
Name_Output => TSS_Stream_Output,
others => TSS_Null);
pragma Assert (TSS_Names (Nam) /= TSS_Null);
begin
if In_Limited_Extension
and then Is_Limited_Type (Field_Typ)
and then No (Find_Inherited_TSS (Field_Typ, TSS_Names (Nam)))
then
-- The declaration is illegal per 13.13.2(9/1), and this is
-- enforced in Exp_Ch3.Check_Stream_Attributes. Keep the caller
-- happy by returning a null statement.
return Make_Null_Statement (Loc);
end if;
return
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Field_Typ, Loc),
Attribute_Name => Nam,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
Make_Selected_Component (Loc,
Prefix => Make_Identifier (Loc, Name_V),
Selector_Name => New_Occurrence_Of (C, Loc))));
end Make_Field_Attribute;
---------------------------
-- Make_Field_Attributes --
---------------------------
function Make_Field_Attributes (Clist : List_Id) return List_Id is
Item : Node_Id;
Result : List_Id;
begin
Result := New_List;
if Present (Clist) then
Item := First (Clist);
-- Loop through components, skipping all internal components,
-- which are not part of the value (e.g. _Tag), except that we
-- don't skip the _Parent, since we do want to process that
-- recursively. If _Parent is an interface type, being abstract
-- with no components there is no need to handle it.
while Present (Item) loop
if Nkind (Item) = N_Component_Declaration
and then
((Chars (Defining_Identifier (Item)) = Name_uParent
and then not Is_Interface
(Etype (Defining_Identifier (Item))))
or else
not Is_Internal_Name (Chars (Defining_Identifier (Item))))
then
Append_To
(Result,
Make_Field_Attribute (Defining_Identifier (Item)));
end if;
Next (Item);
end loop;
end if;
return Result;
end Make_Field_Attributes;
-- Start of processing for Build_Record_Read_Write_Procedure
begin
-- For the protected type case, use corresponding record
if Is_Protected_Type (Typ) then
Typt := Corresponding_Record_Type (Typ);
else
Typt := Typ;
end if;
-- Note that we do nothing with the discriminants, since Read and
-- Write do not read or write the discriminant values. All handling
-- of discriminants occurs in the Input and Output subprograms.
Rdef := Type_Definition
(Declaration_Node (Base_Type (Underlying_Type (Typt))));
Stms := Empty_List;
-- In record extension case, the fields we want, including the _Parent
-- field representing the parent type, are to be found in the extension.
-- Note that we will naturally process the _Parent field using the type
-- of the parent, and hence its stream attributes, which is appropriate.
if Nkind (Rdef) = N_Derived_Type_Definition then
Rdef := Record_Extension_Part (Rdef);
if Is_Limited_Type (Typt) then
In_Limited_Extension := True;
end if;
end if;
if Present (Component_List (Rdef)) then
Append_List_To (Stms,
Make_Component_List_Attributes (Component_List (Rdef)));
end if;
Build_Stream_Procedure
(Loc, Typ, Decl, Pnam, Stms, Nam = Name_Read);
end Build_Record_Read_Write_Procedure;
----------------------------------
-- Build_Record_Write_Procedure --
----------------------------------
procedure Build_Record_Write_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : out Entity_Id)
is
begin
Pnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Write);
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Write);
end Build_Record_Write_Procedure;
-------------------------------
-- Build_Stream_Attr_Profile --
-------------------------------
function Build_Stream_Attr_Profile
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : TSS_Name_Type) return List_Id
is
Profile : List_Id;
begin
-- (Ada 2005: AI-441): Set the null-excluding attribute because it has
-- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
Profile := New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
Parameter_Type =>
Make_Access_Definition (Loc,
Null_Exclusion_Present => True,
Subtype_Mark => New_Occurrence_Of (
Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
if Nam /= TSS_Stream_Input then
Append_To (Profile,
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
Out_Present => (Nam = TSS_Stream_Read),
Parameter_Type => New_Occurrence_Of (Typ, Loc)));
end if;
return Profile;
end Build_Stream_Attr_Profile;
---------------------------
-- Build_Stream_Function --
---------------------------
procedure Build_Stream_Function
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Fnam : Entity_Id;
Decls : List_Id;
Stms : List_Id)
is
Spec : Node_Id;
begin
-- Construct function specification
-- (Ada 2005: AI-441): Set the null-excluding attribute because it has
-- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
Parameter_Type =>
Make_Access_Definition (Loc,
Null_Exclusion_Present => True,
Subtype_Mark =>
New_Occurrence_Of
(Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
Result_Definition => New_Occurrence_Of (Typ, Loc));
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Decls,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_Stream_Function;
----------------------------
-- Build_Stream_Procedure --
----------------------------
procedure Build_Stream_Procedure
(Loc : Source_Ptr;
Typ : Entity_Id;
Decl : out Node_Id;
Pnam : Entity_Id;
Stms : List_Id;
Outp : Boolean)
is
Spec : Node_Id;
begin
-- Construct procedure specification
-- (Ada 2005: AI-441): Set the null-excluding attribute because it has
-- no semantic meaning in Ada 95 but it is a requirement in Ada 2005.
Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Pnam,
Parameter_Specifications => New_List (
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
Parameter_Type =>
Make_Access_Definition (Loc,
Null_Exclusion_Present => True,
Subtype_Mark =>
New_Occurrence_Of
(Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
Make_Parameter_Specification (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
Out_Present => Outp,
Parameter_Type => New_Occurrence_Of (Typ, Loc))));
Decl :=
Make_Subprogram_Body (Loc,
Specification => Spec,
Declarations => Empty_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => Stms));
end Build_Stream_Procedure;
-----------------------------
-- Has_Stream_Standard_Rep --
-----------------------------
function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean is
Siz : Uint;
begin
if Has_Non_Standard_Rep (U_Type) then
return False;
end if;
if Has_Stream_Size_Clause (U_Type) then
Siz := Static_Integer (Expression (Stream_Size_Clause (U_Type)));
else
Siz := Esize (First_Subtype (U_Type));
end if;
return Siz = Esize (Root_Type (U_Type));
end Has_Stream_Standard_Rep;
---------------------------------
-- Make_Stream_Subprogram_Name --
---------------------------------
function Make_Stream_Subprogram_Name
(Loc : Source_Ptr;
Typ : Entity_Id;
Nam : TSS_Name_Type) return Entity_Id
is
Sname : Name_Id;
begin
-- For tagged types, we are dealing with a TSS associated with the
-- declaration, so we use the standard primitive function name. For
-- other types, generate a local TSS name since we are generating
-- the subprogram at the point of use.
if Is_Tagged_Type (Typ) then
Sname := Make_TSS_Name (Typ, Nam);
else
Sname := Make_TSS_Name_Local (Typ, Nam);
end if;
return Make_Defining_Identifier (Loc, Sname);
end Make_Stream_Subprogram_Name;
----------------------
-- Stream_Base_Type --
----------------------
function Stream_Base_Type (E : Entity_Id) return Entity_Id is
begin
if Is_Array_Type (E)
and then Is_First_Subtype (E)
then
return E;
else
return Base_Type (E);
end if;
end Stream_Base_Type;
end Exp_Strm;