From: charlet Date: Mon, 5 Sep 2005 07:54:48 +0000 (+0000) Subject: 2005-09-01 Javier Miranda X-Git-Tag: upstream/4.9.2~58841 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=166ee026cdc41c3bf1b5a1379ddce8c6253b8d3b;p=platform%2Fupstream%2Flinaro-gcc.git 2005-09-01 Javier Miranda * itypes.ads, itypes.adb (Create_Null_Excluding_Itype): New subprogram that given an entity T creates and returns an Itype that duplicates the contents of T. The returned Itype has the null-exclusion attribute set to True, and its Etype attribute references T to keep the association between the two entities. Update copyright notice * sem_aggr.adb (Check_Can_Never_Be_Null, Aggregate_Constraint_Checks, Resolve_Aggregate, Resolve_Array_Aggregate, Resolve_Record_Aggregate): Code cleanup. * sem_ch5.adb (Analyze_Assignment): Code cleanup. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@103868 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/itypes.adb b/gcc/ada/itypes.adb index dd06bd7..f9f86d5 100644 --- a/gcc/ada/itypes.adb +++ b/gcc/ada/itypes.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -25,10 +25,8 @@ ------------------------------------------------------------------------------ with Atree; use Atree; -with Einfo; use Einfo; with Opt; use Opt; with Sem; use Sem; -with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Stand; use Stand; @@ -74,4 +72,40 @@ package body Itypes is return Typ; end Create_Itype; + --------------------------------- + -- Create_Null_Excluding_Itype -- + --------------------------------- + + function Create_Null_Excluding_Itype + (T : Entity_Id; + Related_Nod : Node_Id; + Scope_Id : Entity_Id := Current_Scope) return Entity_Id + is + I_Typ : Entity_Id; + + begin + pragma Assert (Is_Access_Type (T)); + + I_Typ := Create_Itype (Ekind => E_Access_Subtype, + Related_Nod => Related_Nod, + Scope_Id => Scope_Id); + + Set_Directly_Designated_Type (I_Typ, + Directly_Designated_Type (T)); + Set_Etype (I_Typ, T); + Init_Size_Align (I_Typ); + Set_Depends_On_Private (I_Typ, Depends_On_Private (T)); + Set_Is_Public (I_Typ, Is_Public (T)); + Set_From_With_Type (I_Typ, From_With_Type (T)); + Set_Is_Access_Constant (I_Typ, Is_Access_Constant (T)); + Set_Is_Generic_Type (I_Typ, Is_Generic_Type (T)); + Set_Is_Volatile (I_Typ, Is_Volatile (T)); + Set_Treat_As_Volatile (I_Typ, Treat_As_Volatile (T)); + Set_Is_Atomic (I_Typ, Is_Atomic (T)); + Set_Is_Ada_2005 (I_Typ, Is_Ada_2005 (T)); + Set_Can_Never_Be_Null (I_Typ); + + return I_Typ; + end Create_Null_Excluding_Itype; + end Itypes; diff --git a/gcc/ada/itypes.ads b/gcc/ada/itypes.ads index dc49e65..e4dcffc 100644 --- a/gcc/ada/itypes.ads +++ b/gcc/ada/itypes.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2003 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005 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- -- @@ -110,4 +110,32 @@ package Itypes is -- The Scope_Id parameter specifies the scope of the created type, and -- is normally the Current_Scope as shown, but can be set otherwise. + --------------------------------- + -- Create_Null_Excluding_Itype -- + --------------------------------- + + function Create_Null_Excluding_Itype + (T : Entity_Id; + Related_Nod : Node_Id; + Scope_Id : Entity_Id := Current_Scope) return Entity_Id; + -- Ada 2005 (AI-231): T is an access type and this subprogram creates and + -- returns an internal access-subtype declaration of T that has the null + -- exclusion attribute set to True. + -- + -- Usage of null-excluding itypes + -- ------------------------------ + -- + -- type T1 is access ... + -- type T2 is not null T1; + -- + -- type Rec is record + -- Comp : not null T1; + -- end record; + -- + -- type Arr is array (...) of not null T1; + -- + -- Instead of associating the not-null attribute with the defining ids of + -- these declarations, we generate an internal subtype declaration of T1 + -- that has the null exclusion attribute set to true. + end Itypes; diff --git a/gcc/ada/sem_aggr.adb b/gcc/ada/sem_aggr.adb index 1772588..b8fc284 100644 --- a/gcc/ada/sem_aggr.adb +++ b/gcc/ada/sem_aggr.adb @@ -77,7 +77,7 @@ package body Sem_Aggr is -- statement of variant part will usually be small and probably in near -- sorted order. - procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id); + procedure Check_Can_Never_Be_Null (Typ : Node_Id; Expr : Node_Id); -- Ada 2005 (AI-231): Check bad usage of the null-exclusion issue ------------------------------------------------------ @@ -477,7 +477,7 @@ package body Sem_Aggr is elsif Is_Access_Type (Check_Typ) and then ((Is_Local_Anonymous_Access (Check_Typ)) or else (Can_Never_Be_Null (Check_Typ) - and then not Can_Never_Be_Null (Exp_Typ))) + and then not Can_Never_Be_Null (Exp_Typ))) then Rewrite (Exp, Convert_To (Check_Typ, Relocate_Node (Exp))); Analyze_And_Resolve (Exp, Check_Typ); @@ -495,14 +495,14 @@ package body Sem_Aggr is return Entity_Id is Aggr_Dimension : constant Pos := Number_Dimensions (Typ); - -- Number of aggregate index dimensions. + -- Number of aggregate index dimensions Aggr_Range : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); - -- Constrained N_Range of each index dimension in our aggregate itype. + -- Constrained N_Range of each index dimension in our aggregate itype Aggr_Low : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); Aggr_High : array (1 .. Aggr_Dimension) of Node_Id := (others => Empty); - -- Low and High bounds for each index dimension in our aggregate itype. + -- Low and High bounds for each index dimension in our aggregate itype Is_Fully_Positional : Boolean := True; @@ -511,6 +511,7 @@ package body Sem_Aggr is -- (sub-)aggregate N. This procedure collects the constrained N_Range -- nodes corresponding to each index dimension of our aggregate itype. -- These N_Range nodes are collected in Aggr_Range above. + -- -- Likewise collect in Aggr_Low & Aggr_High above the low and high -- bounds of each index dimension. If, when collecting, two bounds -- corresponding to the same dimension are static and found to differ, @@ -522,11 +523,11 @@ package body Sem_Aggr is procedure Collect_Aggr_Bounds (N : Node_Id; Dim : Pos) is This_Range : constant Node_Id := Aggregate_Bounds (N); - -- The aggregate range node of this specific sub-aggregate. + -- The aggregate range node of this specific sub-aggregate This_Low : constant Node_Id := Low_Bound (Aggregate_Bounds (N)); This_High : constant Node_Id := High_Bound (Aggregate_Bounds (N)); - -- The aggregate bounds of this specific sub-aggregate. + -- The aggregate bounds of this specific sub-aggregate Assoc : Node_Id; Expr : Node_Id; @@ -601,7 +602,7 @@ package body Sem_Aggr is -- the final itype of the overall aggregate Index_Constraints : constant List_Id := New_List; - -- The list of index constraints of the aggregate itype. + -- The list of index constraints of the aggregate itype -- Start of processing for Array_Aggr_Subtype @@ -612,7 +613,7 @@ package body Sem_Aggr is Set_Parent (Index_Constraints, N); Collect_Aggr_Bounds (N, 1); - -- Build the list of constrained indices of our aggregate itype. + -- Build the list of constrained indices of our aggregate itype for J in 1 .. Aggr_Dimension loop Create_Index : declare @@ -816,7 +817,7 @@ package body Sem_Aggr is Next_Component (Comp); end loop; - -- On exit, all components have statically known sizes. + -- On exit, all components have statically known sizes Set_Size_Known_At_Compile_Time (T); end Check_Static_Discriminated_Subtype; @@ -987,13 +988,6 @@ package body Sem_Aggr is Set_Etype (N, Aggr_Typ); -- may be overridden later on - -- Ada 2005 (AI-231): Propagate the null_exclusion attribute to - -- the components of the array aggregate - - if Ada_Version >= Ada_05 then - Set_Can_Never_Be_Null (Aggr_Typ, Can_Never_Be_Null (Typ)); - end if; - if Is_Constrained (Typ) and then (Pkind = N_Assignment_Statement or else Pkind = N_Parameter_Association or else @@ -1106,7 +1100,7 @@ package body Sem_Aggr is -- warning if not and sets the Raises_Constraint_Error Flag in N. function Dynamic_Or_Null_Range (L, H : Node_Id) return Boolean; - -- Returns True if range L .. H is dynamic or null. + -- Returns True if range L .. H is dynamic or null procedure Get (Value : out Uint; From : Node_Id; OK : out Boolean); -- Given expression node From, this routine sets OK to False if it @@ -1368,10 +1362,10 @@ package body Sem_Aggr is is Nxt_Ind : constant Node_Id := Next_Index (Index); Nxt_Ind_Constr : constant Node_Id := Next_Index (Index_Constr); - -- Index is the current index corresponding to the expresion. + -- Index is the current index corresponding to the expresion Resolution_OK : Boolean := True; - -- Set to False if resolution of the expression failed. + -- Set to False if resolution of the expression failed begin -- If the array type against which we are resolving the aggregate @@ -1584,7 +1578,7 @@ package body Sem_Aggr is -- in the current association. begin - -- STEP 2 (A): Check discrete choices validity. + -- STEP 2 (A): Check discrete choices validity Assoc := First (Component_Associations (N)); while Present (Assoc) loop @@ -1637,7 +1631,7 @@ package body Sem_Aggr is if Etype (Choice) = Any_Type then return Failure; - -- If the discrete choice raises CE get its original bounds. + -- If the discrete choice raises CE get its original bounds elsif Nkind (Choice) = N_Raise_Constraint_Error then Set_Raises_Constraint_Error (N); @@ -1681,7 +1675,9 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) - if Ada_Version >= Ada_05 then + if Ada_Version >= Ada_05 + and then Nkind (Expression (Assoc)) = N_Null + then Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); end if; @@ -1811,7 +1807,9 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) - if Ada_Version >= Ada_05 then + if Ada_Version >= Ada_05 + and then Nkind (Expr) = N_Null + then Check_Can_Never_Be_Null (Etype (N), Expr); end if; @@ -1827,7 +1825,9 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) - if Ada_Version >= Ada_05 then + if Ada_Version >= Ada_05 + and then Nkind (Expression (Assoc)) = N_Null + then Check_Can_Never_Be_Null (Etype (N), Expression (Assoc)); end if; @@ -2231,18 +2231,19 @@ package body Sem_Aggr is return True; end if; - -- Now look to see if Discr was specified in the ancestor part. - - Orig_Discr := Original_Record_Component (Discr); - D := First_Discriminant (Ancestor_Typ); + -- Now look to see if Discr was specified in the ancestor part if Ancestor_Is_Subtyp then D_Val := First_Elmt (Discriminant_Constraint (Entity (Ancestor))); end if; + Orig_Discr := Original_Record_Component (Discr); + + D := First_Discriminant (Ancestor_Typ); while Present (D) loop - -- If Ancestor has already specified Disc value than - -- insert its value in the final aggregate. + + -- If Ancestor has already specified Disc value than insert its + -- value in the final aggregate. if Original_Record_Component (D) = Orig_Discr then if Ancestor_Is_Subtyp then @@ -2506,16 +2507,16 @@ package body Sem_Aggr is -- For each range in an array type where a discriminant has been -- replaced with the constraint, check that this range is within - -- the range of the base type. This checks is done in the - -- init proc for regular objects, but has to be done here for + -- the range of the base type. This checks is done in the init + -- proc for regular objects, but has to be done here for -- aggregates since no init proc is called for them. if Is_Array_Type (Expr_Type) then declare - Index : Node_Id := First_Index (Expr_Type); - -- Range of the current constrained index in the array. + Index : Node_Id := First_Index (Expr_Type); + -- Range of the current constrained index in the array - Orig_Index : Node_Id := First_Index (Etype (Component)); + Orig_Index : Node_Id := First_Index (Etype (Component)); -- Range corresponding to the range Index above in the -- original unconstrained record type. The bounds of this -- range may be governed by discriminants. @@ -2697,7 +2698,9 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) - if Ada_Version >= Ada_05 then + if Ada_Version >= Ada_05 + and then Nkind (Positional_Expr) = N_Null + then Check_Can_Never_Be_Null (Discrim, Positional_Expr); end if; @@ -2790,7 +2793,7 @@ package body Sem_Aggr is Subtype_Indication => Indic); Set_Parent (Subtyp_Decl, Parent (N)); - -- Itypes must be analyzed with checks off (see itypes.ads). + -- Itypes must be analyzed with checks off (see itypes.ads) Analyze (Subtyp_Decl, Suppress => All_Checks); @@ -2884,7 +2887,7 @@ package body Sem_Aggr is end if; end loop; - -- Now collect components from all other ancestors. + -- Now collect components from all other ancestors Parent_Elmt := First_Elmt (Parent_Typ_List); while Present (Parent_Elmt) loop @@ -2934,7 +2937,9 @@ package body Sem_Aggr is -- Ada 2005 (AI-231) - if Ada_Version >= Ada_05 then + if Ada_Version >= Ada_05 + and then Nkind (Positional_Expr) = N_Null + then Check_Can_Never_Be_Null (Component, Positional_Expr); end if; @@ -3087,19 +3092,38 @@ package body Sem_Aggr is -- Check_Can_Never_Be_Null -- ----------------------------- - procedure Check_Can_Never_Be_Null (N : Node_Id; Expr : Node_Id) is + procedure Check_Can_Never_Be_Null (Typ : Node_Id; Expr : Node_Id) is + Comp_Typ : Entity_Id; + begin - pragma Assert (Ada_Version >= Ada_05); + pragma Assert (Ada_Version >= Ada_05 + and then Present (Expr) + and then Nkind (Expr) = N_Null); - if Nkind (Expr) = N_Null - and then Can_Never_Be_Null (N) + case Ekind (Typ) is + when E_Array_Type => + Comp_Typ := Component_Type (Typ); + + when E_Component | + E_Discriminant => + Comp_Typ := Etype (Typ); + + when others => + return; + end case; + + if Present (Expr) + and then Can_Never_Be_Null (Comp_Typ) then - Apply_Compile_Time_Constraint_Error - (N => Expr, - Msg => "(Ada 2005) NULL not allowed in" - & " null-excluding components?", - Reason => CE_Null_Not_Allowed, - Rep => False); + Error_Msg_N + ("(Ada 2005) NULL not allowed in null-excluding components?", Expr); + Error_Msg_NEL + ("\& will be raised at run time!?", + Expr, Standard_Constraint_Error, Sloc (Expr)); + + Set_Etype (Expr, Comp_Typ); + Set_Analyzed (Expr); + Install_Null_Excluding_Check (Expr); end if; end Check_Can_Never_Be_Null; diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index b07389a..2c5e064 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -375,9 +375,7 @@ package body Sem_Ch5 is T2 := Etype (Rhs); - if Covers (T1, T2) then - null; - else + if not Covers (T1, T2) then Wrong_Type (Rhs, Etype (Lhs)); return; end if; @@ -448,17 +446,21 @@ package body Sem_Ch5 is -- Ada 2005 (AI-231) if Ada_Version >= Ada_05 - and then Nkind (Rhs) = N_Null - and then Is_Access_Type (T1) + and then Can_Never_Be_Null (T1) and then not Assignment_OK (Lhs) - and then ((Is_Entity_Name (Lhs) - and then Can_Never_Be_Null (Entity (Lhs))) - or else Can_Never_Be_Null (Etype (Lhs))) then - Apply_Compile_Time_Constraint_Error - (N => Lhs, - Msg => "(Ada 2005) NULL not allowed in null-excluding objects?", - Reason => CE_Null_Not_Allowed); + if Nkind (Rhs) = N_Null then + Apply_Compile_Time_Constraint_Error + (N => Rhs, + Msg => "(Ada 2005) NULL not allowed in null-excluding objects?", + Reason => CE_Null_Not_Allowed); + return; + + elsif not Can_Never_Be_Null (T2) then + Rewrite (Rhs, + Convert_To (T1, Relocate_Node (Rhs))); + Analyze_And_Resolve (Rhs, T1); + end if; end if; if Is_Scalar_Type (T1) then @@ -550,7 +552,7 @@ package body Sem_Ch5 is Ent := Entity (Lhs); - -- Capture value if save to do so + -- Capture value if safe to do so if Safe_To_Capture_Value (N, Ent) then Set_Current_Value (Ent, Rhs); @@ -1274,7 +1276,7 @@ package body Sem_Ch5 is -- Start of processing for Process_Bounds begin - -- Determine expected type of range by analyzing separate copy. + -- Determine expected type of range by analyzing separate copy Set_Parent (R_Copy, Parent (R)); Pre_Analyze_And_Resolve (R_Copy);