1485 lines
49 KiB
Ada
1485 lines
49 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- E X P _ S T R M --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- --
|
|
-- Copyright (C) 1992-2002, 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 2, 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 COPYING. If not, write --
|
|
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
|
|
-- MA 02111-1307, USA. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Atree; use Atree;
|
|
with Einfo; use Einfo;
|
|
with Lib; use Lib;
|
|
with Namet; use Namet;
|
|
with Nlists; use Nlists;
|
|
with Nmake; use Nmake;
|
|
with Rtsfind; use Rtsfind;
|
|
with Sinfo; use Sinfo;
|
|
with Snames; use Snames;
|
|
with Stand; use Stand;
|
|
with Tbuild; use Tbuild;
|
|
with Ttypes; use Ttypes;
|
|
with Exp_Tss; use Exp_Tss;
|
|
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.
|
|
|
|
procedure Build_Stream_Procedure
|
|
(Loc : Source_Ptr;
|
|
Typ : Entity_Id;
|
|
Decl : out Node_Id;
|
|
Pnam : Entity_Id;
|
|
Stms : List_Id;
|
|
Outp : Boolean);
|
|
-- Called to build an array or record stream procedure. The first three
|
|
-- arguments are the same as Build_Record_Or_Elementary_Output_Procedure.
|
|
-- Stms is the list of statements for the body (the declaration list is
|
|
-- always null), and Pnam is the name of the constructed procedure.
|
|
|
|
function Has_Stream_Standard_Rep (U_Type : Entity_Id) return Boolean;
|
|
-- This function is used to test U_Type, which is a type
|
|
-- Returns True if U_Type has a standard representation for stream
|
|
-- purposes, i.e. there is no non-standard enumeration representation
|
|
-- clause, and the size of the first subtype is the same as the size
|
|
-- of the root type.
|
|
|
|
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 InputN (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 InputN
|
|
|
|
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;
|
|
Indx : 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 first subtype is constrained, use it directly. Otherwise
|
|
-- build a subtype indication with the proper bounds.
|
|
|
|
if Is_Constrained (Stream_Base_Type (Typ)) then
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
|
|
Object_Definition =>
|
|
New_Occurrence_Of (Stream_Base_Type (Typ), Loc)));
|
|
else
|
|
Append_To (Decls,
|
|
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,
|
|
Constraints => Ranges))));
|
|
end if;
|
|
|
|
Stms := New_List (
|
|
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))),
|
|
|
|
Make_Return_Statement (Loc,
|
|
Expression => Make_Identifier (Loc, Name_V)));
|
|
|
|
Fnam :=
|
|
Make_Defining_Identifier (Loc,
|
|
Chars =>
|
|
New_External_Name (Name_uInput, ' ', Increment_Serial_Number));
|
|
|
|
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 =>
|
|
New_External_Name (Name_uOutput, ' ', Increment_Serial_Number));
|
|
|
|
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,
|
|
New_External_Name
|
|
(Name_uRead, ' ', Increment_Serial_Number));
|
|
|
|
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. See 5509-003.
|
|
|
|
if Nam = Name_Read then
|
|
RW := TSS (Base_Type (Ctyp), Name_uRead);
|
|
else
|
|
RW := TSS (Base_Type (Ctyp), Name_uWrite);
|
|
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 =>
|
|
New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
|
|
|
|
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);
|
|
P_Size : constant Uint := Esize (FST);
|
|
Strm : constant Node_Id := First (Expressions (N));
|
|
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;
|
|
|
|
-- Floating point types
|
|
|
|
elsif Is_Floating_Point_Type (U_Type) then
|
|
|
|
if Rt_Type = Standard_Short_Float then
|
|
Lib_RE := RE_I_SF;
|
|
|
|
elsif Rt_Type = Standard_Float then
|
|
Lib_RE := RE_I_F;
|
|
|
|
elsif Rt_Type = Standard_Long_Float then
|
|
Lib_RE := RE_I_LF;
|
|
|
|
else pragma Assert (Rt_Type = Standard_Long_Long_Float);
|
|
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)
|
|
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.
|
|
|
|
return
|
|
Unchecked_Convert_To (P_Type,
|
|
Make_Function_Call (Loc,
|
|
Name => New_Occurrence_Of (RTE (Lib_RE), Loc),
|
|
Parameter_Associations => New_List (
|
|
Relocate_Node (Strm))));
|
|
|
|
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);
|
|
P_Size : constant Uint := Esize (FST);
|
|
Strm : constant Node_Id := First (Expressions (N));
|
|
Item : constant Node_Id := Next (Strm);
|
|
Lib_RE : RE_Id;
|
|
Libent : Entity_Id;
|
|
|
|
begin
|
|
-- 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;
|
|
|
|
-- Floating point types
|
|
|
|
elsif Is_Floating_Point_Type (U_Type) then
|
|
|
|
if Rt_Type = Standard_Short_Float then
|
|
Lib_RE := RE_W_SF;
|
|
|
|
elsif Rt_Type = Standard_Float then
|
|
Lib_RE := RE_W_F;
|
|
|
|
elsif Rt_Type = Standard_Long_Float then
|
|
Lib_RE := RE_W_LF;
|
|
|
|
else pragma Assert (Rt_Type = Standard_Long_Long_Float);
|
|
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, if we have
|
|
|
|
-- type W is range -1 .. +254;
|
|
-- for W'Size use 8;
|
|
|
|
-- then the representation is also unsigned.
|
|
|
|
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
|
|
Stms : List_Id;
|
|
Disc : Entity_Id;
|
|
Comp : Node_Id;
|
|
|
|
begin
|
|
Stms := New_List;
|
|
Disc := First_Discriminant (Typ);
|
|
|
|
-- Generate Reads for the discriminants of the type.
|
|
|
|
while Present (Disc) loop
|
|
Comp :=
|
|
Make_Selected_Component (Loc,
|
|
Prefix => Make_Identifier (Loc, Name_V),
|
|
Selector_Name => New_Occurrence_Of (Disc, Loc));
|
|
|
|
Set_Assignment_OK (Comp);
|
|
|
|
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),
|
|
Comp)));
|
|
|
|
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 =>
|
|
New_External_Name (Name_uRead, ' ', Increment_Serial_Number));
|
|
|
|
Build_Record_Read_Write_Procedure (Loc, Typ, Decl, Pnam, Name_Read);
|
|
|
|
-- Read the discriminants before the rest of the components, so
|
|
-- that discriminant values are properly set of variants, etc.
|
|
-- If this is an empty record with discriminants, there are no
|
|
-- previous statements. If this is an unchecked union, the stream
|
|
-- procedure is erroneous, because there are no discriminants to read.
|
|
|
|
if Is_Unchecked_Union (Typ) then
|
|
Stms :=
|
|
New_List (
|
|
Make_Raise_Program_Error (Loc,
|
|
Reason => PE_Unchecked_Union_Restriction));
|
|
end if;
|
|
|
|
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_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;
|
|
|
|
begin
|
|
Stms := New_List;
|
|
Disc := First_Discriminant (Typ);
|
|
|
|
-- Generate Writes for the discriminants of the type.
|
|
|
|
while Present (Disc) loop
|
|
|
|
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),
|
|
Make_Selected_Component (Loc,
|
|
Prefix => Make_Identifier (Loc, Name_V),
|
|
Selector_Name => New_Occurrence_Of (Disc, Loc)))));
|
|
|
|
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 =>
|
|
New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
|
|
|
|
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 this is an unchecked union, the stream procedure is erroneous
|
|
-- because there are no discriminants to write.
|
|
|
|
if Is_Unchecked_Union (Typ) then
|
|
Stms :=
|
|
New_List (
|
|
Make_Raise_Program_Error (Loc,
|
|
Reason => PE_Unchecked_Union_Restriction));
|
|
end if;
|
|
|
|
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)
|
|
is
|
|
Cn : Name_Id;
|
|
J : Pos;
|
|
Decls : List_Id;
|
|
Constr : List_Id;
|
|
Stms : List_Id;
|
|
Discr : Entity_Id;
|
|
Odef : Node_Id;
|
|
|
|
begin
|
|
Decls := New_List;
|
|
Constr := New_List;
|
|
|
|
J := 1;
|
|
|
|
if Has_Discriminants (Typ) then
|
|
Discr := First_Discriminant (Typ);
|
|
|
|
while Present (Discr) loop
|
|
Cn := New_External_Name ('C', J);
|
|
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
|
|
Object_Definition =>
|
|
New_Occurrence_Of (Etype (Discr), Loc)));
|
|
|
|
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));
|
|
|
|
Next_Discriminant (Discr);
|
|
J := J + 1;
|
|
end loop;
|
|
|
|
Odef :=
|
|
Make_Subtype_Indication (Loc,
|
|
Subtype_Mark => New_Occurrence_Of (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 (Typ, Loc);
|
|
end if;
|
|
|
|
Append_To (Decls,
|
|
Make_Object_Declaration (Loc,
|
|
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
|
|
Object_Definition => Odef));
|
|
|
|
Stms := New_List (
|
|
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))),
|
|
|
|
Make_Return_Statement (Loc,
|
|
Expression => Make_Identifier (Loc, Name_V)));
|
|
|
|
-- For tagged types, we use a canonical name so that it matches the
|
|
-- primitive spec. For all other cases, we use a serialized name so
|
|
-- that multiple generations of the same procedure do not clash.
|
|
|
|
if Is_Tagged_Type (Typ) then
|
|
Fnam := Make_Defining_Identifier (Loc, Name_uInput);
|
|
else
|
|
Fnam :=
|
|
Make_Defining_Identifier (Loc,
|
|
Chars =>
|
|
New_External_Name (Name_uInput, ' ', Increment_Serial_Number));
|
|
end if;
|
|
|
|
Build_Stream_Function (Loc, 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;
|
|
|
|
begin
|
|
Stms := New_List;
|
|
|
|
-- Note that of course there will be no discriminants for the
|
|
-- elementary type case, so Has_Discriminants will be False.
|
|
|
|
if Has_Discriminants (Typ) then
|
|
Disc := First_Discriminant (Typ);
|
|
|
|
while Present (Disc) loop
|
|
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),
|
|
Make_Selected_Component (Loc,
|
|
Prefix => Make_Identifier (Loc, Name_V),
|
|
Selector_Name => New_Occurrence_Of (Disc, Loc)))));
|
|
|
|
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))));
|
|
|
|
-- For tagged types, we use a canonical name so that it matches the
|
|
-- primitive spec. For all other cases, we use a serialized name so
|
|
-- that multiple generations of the same procedure do not clash.
|
|
|
|
if Is_Tagged_Type (Typ) then
|
|
Pnam := Make_Defining_Identifier (Loc, Name_uOutput);
|
|
else
|
|
Pnam :=
|
|
Make_Defining_Identifier (Loc,
|
|
Chars =>
|
|
New_External_Name
|
|
(Name_uOutput, ' ', Increment_Serial_Number));
|
|
end if;
|
|
|
|
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
|
|
-- For tagged types, we use a canonical name so that it matches the
|
|
-- primitive spec. For all other cases, we use a serialized name so
|
|
-- that multiple generations of the same procedure do not clash.
|
|
|
|
if Is_Tagged_Type (Typ) then
|
|
Pnam := Make_Defining_Identifier (Loc, Name_uRead);
|
|
else
|
|
Pnam :=
|
|
Make_Defining_Identifier (Loc,
|
|
Chars =>
|
|
New_External_Name (Name_uRead, ' ', Increment_Serial_Number));
|
|
end if;
|
|
|
|
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;
|
|
|
|
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;
|
|
|
|
begin
|
|
Result := Make_Field_Attributes (CI);
|
|
|
|
-- If a component is an unchecked union, there is no discriminant
|
|
-- and we cannot generate a read/write procedure for it.
|
|
|
|
if Present (VP) then
|
|
if Is_Unchecked_Union (Scope (Entity (Name (VP)))) then
|
|
return New_List (
|
|
Make_Raise_Program_Error (Sloc (VP),
|
|
Reason => PE_Unchecked_Union_Restriction));
|
|
end if;
|
|
|
|
V := First_Non_Pragma (Variants (VP));
|
|
Alts := New_List;
|
|
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.
|
|
|
|
Append_To (Result,
|
|
Make_Case_Statement (Loc,
|
|
Expression =>
|
|
Make_Selected_Component (Loc,
|
|
Prefix => Make_Identifier (Loc, Name_V),
|
|
Selector_Name =>
|
|
New_Occurrence_Of (Entity (Name (VP)), Loc)),
|
|
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
|
|
begin
|
|
return
|
|
Make_Attribute_Reference (Loc,
|
|
Prefix =>
|
|
New_Occurrence_Of (Stream_Base_Type (Etype (C)), 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.
|
|
|
|
while Present (Item) loop
|
|
if Nkind (Item) = N_Component_Declaration
|
|
and then
|
|
(Chars (Defining_Identifier (Item)) = Name_uParent
|
|
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 (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);
|
|
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
|
|
-- For tagged types, we use a canonical name so that it matches the
|
|
-- primitive spec. For all other cases, we use a serialized name so
|
|
-- that multiple generations of the same procedure do not clash.
|
|
|
|
if Is_Tagged_Type (Typ) then
|
|
Pnam := Make_Defining_Identifier (Loc, Name_uWrite);
|
|
else
|
|
Pnam :=
|
|
Make_Defining_Identifier (Loc,
|
|
Chars =>
|
|
New_External_Name (Name_uWrite, ' ', Increment_Serial_Number));
|
|
end if;
|
|
|
|
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 : Name_Id)
|
|
return List_Id
|
|
is
|
|
Profile : List_Id;
|
|
|
|
begin
|
|
Profile := New_List (
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
|
|
Parameter_Type =>
|
|
Make_Access_Definition (Loc,
|
|
Subtype_Mark => New_Reference_To (
|
|
Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
|
|
|
|
if Nam /= Name_uInput then
|
|
Append_To (Profile,
|
|
Make_Parameter_Specification (Loc,
|
|
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
|
|
Out_Present => (Nam = Name_uRead),
|
|
Parameter_Type => New_Reference_To (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
|
|
|
|
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,
|
|
Subtype_Mark => New_Reference_To (
|
|
Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
|
|
|
|
Subtype_Mark => 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
|
|
|
|
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,
|
|
Subtype_Mark => New_Reference_To (
|
|
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
|
|
begin
|
|
if Has_Non_Standard_Rep (U_Type) then
|
|
return False;
|
|
|
|
else
|
|
return
|
|
Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type));
|
|
end if;
|
|
end Has_Stream_Standard_Rep;
|
|
|
|
----------------------
|
|
-- 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;
|