X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fexp_strm.adb;h=42c34a8487eafb83eb66719809e412e1ba31fa8e;hb=a34480d83b68142f300347d89d233f971438cf5d;hp=a48ae6f5a79da7882c6e386de31f32aa9b76974d;hpb=f27cea3abf8ded22456f5f46a812cc3915969815;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/exp_strm.adb b/gcc/ada/exp_strm.adb index a48ae6f5a79..42c34a8487e 100644 --- a/gcc/ada/exp_strm.adb +++ b/gcc/ada/exp_strm.adb @@ -6,18 +6,17 @@ -- -- -- 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. -- @@ -26,11 +25,12 @@ 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; @@ -81,11 +81,12 @@ package body Exp_Strm is -- 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; @@ -219,7 +220,7 @@ package body Exp_Strm is 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 := @@ -373,7 +374,7 @@ package body Exp_Strm is -- 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); @@ -457,7 +458,7 @@ package body Exp_Strm is -- 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); @@ -492,13 +493,37 @@ package body Exp_Strm is -- 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 @@ -594,19 +619,25 @@ package body Exp_Strm is -- 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 @@ -639,7 +670,7 @@ package body Exp_Strm is -- 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); @@ -676,12 +707,39 @@ package body Exp_Strm is -- 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; @@ -708,6 +766,8 @@ package body Exp_Strm is -- 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) @@ -949,14 +1009,26 @@ package body Exp_Strm is 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, @@ -964,9 +1036,7 @@ package body Exp_Strm is 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; @@ -981,15 +1051,6 @@ package body Exp_Strm is -- 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))) @@ -1032,13 +1093,14 @@ package body Exp_Strm is 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; @@ -1052,12 +1114,22 @@ package body Exp_Strm is 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), @@ -1085,21 +1157,53 @@ package body Exp_Strm is 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); @@ -1116,8 +1220,9 @@ package body Exp_Strm is 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; @@ -1129,6 +1234,21 @@ package body Exp_Strm is 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 => @@ -1136,9 +1256,7 @@ package body Exp_Strm is 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; @@ -1245,25 +1363,18 @@ package body Exp_Strm is 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)); @@ -1282,15 +1393,27 @@ package body Exp_Strm is -- 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; @@ -1318,8 +1441,8 @@ package body Exp_Strm is 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; @@ -1327,7 +1450,7 @@ package body Exp_Strm is 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), @@ -1353,12 +1476,15 @@ package body Exp_Strm is -- 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 @@ -1442,11 +1568,15 @@ package body Exp_Strm 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 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)))); @@ -1478,6 +1608,9 @@ package body Exp_Strm is 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, @@ -1487,10 +1620,11 @@ package body Exp_Strm is 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, @@ -1518,6 +1652,9 @@ package body Exp_Strm is 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, @@ -1527,6 +1664,7 @@ package body Exp_Strm is 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))), @@ -1549,13 +1687,20 @@ package body Exp_Strm is ----------------------------- 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; ---------------------------------