-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2008, 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- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
--- Boston, MA 02110-1301, USA. --
+-- 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 Exp_Tss; use Exp_Tss;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
+with Opt; use Opt;
with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
-- 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 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.
+ -- 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;
Make_Identifier (Loc, Name_S),
Make_Identifier (Loc, Name_V))),
- Make_Return_Statement (Loc,
+ Make_Simple_Return_Statement (Loc,
Expression => Make_Identifier (Loc, Name_V)));
Fnam :=
-- 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.
+ -- generate any additional freezing actions in any case.
if Nam = Name_Read then
RW := TSS (Base_Type (Ctyp), TSS_Stream_Read);
-- 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 Is_Elementary_Type (FST) and then Has_Stream_Size_Clause (FST) then
+ if Has_Stream_Size_Clause (FST) then
P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
else
P_Size := Esize (FST);
-- Floating point types
elsif Is_Floating_Point_Type (U_Type) then
- if P_Size <= Standard_Short_Float_Size 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 then
+ 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
-- 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 (P_Type),
+ 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
-- 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 Is_Elementary_Type (FST) and then Has_Stream_Size_Clause (FST) then
+ if Has_Stream_Size_Clause (FST) then
P_Size := Static_Integer (Expression (Stream_Size_Clause (FST)));
else
P_Size := Esize (FST);
-- Floating point types
elsif Is_Floating_Point_Type (U_Type) then
- if P_Size <= Standard_Short_Float_Size 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 then
+
+ 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;
-- 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)
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,
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)))));
+ D_Ref)));
Next_Discriminant (Disc);
end loop;
-- 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)))
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;
+ Cn : Name_Id;
+ J : Pos;
+ Decls : List_Id;
+ Constr : List_Id;
+ Obj_Decl : Node_Id;
+ Stms : List_Id;
+ Discr : Entity_Id;
+ Odef : Node_Id;
begin
Decls := New_List;
while Present (Discr) loop
Cn := New_External_Name ('C', J);
- Append_To (Decls,
+ Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Cn),
Object_Definition =>
- New_Occurrence_Of (Etype (Discr), Loc)));
+ 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),
Odef := New_Occurrence_Of (Typ, Loc);
end if;
- Append_To (Decls,
+ -- For Ada 2005 we 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).
+
+ -- Perhaps we should just generate an extended return in all cases???
+
+ Obj_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_V),
- Object_Definition => Odef));
+ 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))),
+ -- 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.
- Make_Return_Statement (Loc,
- Expression => Make_Identifier (Loc, Name_V)));
+ if Is_Access_Type (Typ) then
+ Set_No_Initialization (Obj_Decl);
+ end if;
+
+ if Ada_Version >= Ada_05 then
+ Stms := New_List (
+ Make_Extended_Return_Statement (Loc,
+ Return_Object_Declarations => New_List (Obj_Decl),
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ 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)))))));
+
+ else
+ Append_To (Decls, Obj_Decl);
+
+ 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_Simple_Return_Statement (Loc,
+ Expression => Make_Identifier (Loc, Name_V)));
+ end if;
Fnam := Make_Stream_Subprogram_Name (Loc, Typ, TSS_Stream_Input);
Decl : out Node_Id;
Pnam : out Entity_Id)
is
- Stms : List_Id;
- Disc : Entity_Id;
+ Stms : List_Id;
+ Disc : Entity_Id;
+ Disc_Ref : Node_Id;
begin
Stms := New_List;
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 =>
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)))));
+ Disc_Ref)));
Next_Discriminant (Disc);
end loop;
V : Node_Id;
DC : Node_Id;
DCH : List_Id;
+ D_Ref : Node_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;
+ Alts := New_List;
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));
-- 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 =>
+ -- 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)),
- Alternatives => Alts));
+ 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;
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.
+ -- 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 (Stream_Base_Type (Etype (C)), Loc),
+ New_Occurrence_Of (Field_Typ, Loc),
Attribute_Name => Nam,
Expressions => New_List (
Make_Identifier (Loc, Name_S),
-- 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.
+ -- 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
+ ((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
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 Ada2005.
+
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_Reference_To (
Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))));
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 Ada2005.
+
Spec :=
Make_Function_Specification (Loc,
Defining_Unit_Name => Fnam,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
Parameter_Type =>
Make_Access_Definition (Loc,
+ Null_Exclusion_Present => True,
Subtype_Mark => New_Reference_To (
Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc)))),
- Subtype_Mark => New_Occurrence_Of (Typ, Loc));
+ Result_Definition => New_Occurrence_Of (Typ, Loc));
Decl :=
Make_Subprogram_Body (Loc,
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 Ada2005.
+
Spec :=
Make_Procedure_Specification (Loc,
Defining_Unit_Name => Pnam,
Defining_Identifier => Make_Defining_Identifier (Loc, Name_S),
Parameter_Type =>
Make_Access_Definition (Loc,
+ Null_Exclusion_Present => True,
Subtype_Mark => New_Reference_To (
Class_Wide_Type (RTE (RE_Root_Stream_Type)), Loc))),
-----------------------------
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
- return
- Esize (First_Subtype (U_Type)) = Esize (Root_Type (U_Type));
+ Siz := Esize (First_Subtype (U_Type));
end if;
+
+ return Siz = Esize (Root_Type (U_Type));
end Has_Stream_Standard_Rep;
---------------------------------
OSDN Git Service
