From: Arnaud Charlet Date: Tue, 7 Apr 2009 16:45:30 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0ac73189d6da2eccda3b1ffb4bbe89981b4879f4;p=gcc.git [multiple changes] 2009-04-07 Robert Dewar * sem_warn.adb (Check_Infinite_Loop_Warning.Test_Ref): Add defence against missing parent. 2009-04-07 Thomas Quinot * xoscons.adb: Minor reformatting 2009-04-07 Robert Dewar * rtsfind.ads: Remove obsolete string concatenation entries 2009-04-07 Robert Dewar * exp_ch4.adb (Expand_Concatenate): Redo handling of bounds 2009-04-07 Ed Schonberg * sem_ch10.adb (Check_Body_Required): Handle properly imported subprograms. 2009-04-07 Gary Dismukes * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case Attribute_Address): When Init_Or_Norm_Scalars is True and the object is of a scalar or string type then suppress the setting of the expression to Empty. * freeze.adb (Warn_Overlay): Also emit the warnings about default initialization for the cases of scalar and string objects when Init_Or_Norm_Scalars is True. From-SVN: r145694 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index e5fbcbaf494..9211323337b 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,36 @@ +2009-04-07 Robert Dewar + + * sem_warn.adb (Check_Infinite_Loop_Warning.Test_Ref): Add defence + against missing parent. + +2009-04-07 Thomas Quinot + + * xoscons.adb: Minor reformatting + +2009-04-07 Robert Dewar + + * rtsfind.ads: Remove obsolete string concatenation entries + +2009-04-07 Robert Dewar + + * exp_ch4.adb (Expand_Concatenate): Redo handling of bounds + +2009-04-07 Ed Schonberg + + * sem_ch10.adb (Check_Body_Required): Handle properly imported + subprograms. + +2009-04-07 Gary Dismukes + + * exp_ch13.adb (Expand_N_Attribute_Definition_Clause, case + Attribute_Address): When Init_Or_Norm_Scalars is True and the object + is of a scalar or string type then suppress the setting of the + expression to Empty. + + * freeze.adb (Warn_Overlay): Also emit the warnings about default + initialization for the cases of scalar and string objects when + Init_Or_Norm_Scalars is True. + 2009-04-07 Bob Duff * s-secsta.ads, g-pehage.ads, s-fileio.ads: Minor comment fixes diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb index af94e1d8f92..ebfd212f491 100644 --- a/gcc/ada/exp_ch13.adb +++ b/gcc/ada/exp_ch13.adb @@ -34,6 +34,7 @@ with Exp_Util; use Exp_Util; with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; +with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Ch7; use Sem_Ch7; @@ -91,6 +92,14 @@ package body Exp_Ch13 is -- call to the init proc, and must be respected. Note that for -- packed types we do not build equivalent aggregates. + -- Also, if Init_Or_Norm_Scalars applies, then we need to retain + -- any default initialization for objects of scalar types and + -- types with scalar components. Normally a composite type will + -- have an init_proc in the presence of Init_Or_Norm_Scalars, + -- so when that flag is set we have just have to do a test for + -- scalar and string types (the predefined string types such as + -- String and Wide_String don't have an init_proc). + declare Decl : constant Node_Id := Declaration_Node (Ent); Typ : constant Entity_Id := Etype (Ent); @@ -106,6 +115,13 @@ package body Exp_Ch13 is Present (Static_Initialization (Base_Init_Proc (Typ))) then null; + + elsif Init_Or_Norm_Scalars + and then + (Is_Scalar_Type (Typ) or else Is_String_Type (Typ)) + then + null; + else Set_Expression (Decl, Empty); end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index fb116444de1..df1d2bb26a9 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2158,6 +2158,12 @@ package body Exp_Ch4 is Concatenation_Error : exception; -- Raised if concatenation is sure to raise a CE + Result_May_Be_Null : Boolean := True; + -- Reset to False if at least one operand is encountered which is known + -- at compile time to be non-null. Used for handling the special case + -- of setting the high bound to the last operand high bound for a null + -- result, thus ensuring a proper high bound in the super-flat case. + N : constant Nat := List_Length (Opnds); -- Number of concatenation operands including possibly null operands @@ -2177,38 +2183,47 @@ package body Exp_Ch4 is -- Set to length of operand. Entries in this array are set only if the -- corresponding entry in Is_Fixed_Length is True. - Fixed_Low_Bound : array (1 .. N) of Uint; - -- Set to lower bound of operand. Entries in this array are set only - -- if the corresponding entry in Is_Fixed_Length is True. + Opnd_Low_Bound : array (1 .. N) of Node_Id; + -- Set to lower bound of operand. Either an integer literal in the case + -- where the bound is known at compile time, else actual lower bound. + -- The operand low bound is of type Ityp. + + Opnd_High_Bound : array (1 .. N) of Node_Id; + -- Set to upper bound of operand. Either an integer literal in the case + -- where the bound is known at compile time, else actual upper bound. + -- The operand bound is of type Ityp. Var_Length : array (1 .. N) of Entity_Id; -- Set to an entity of type Natural that contains the length of an -- operand whose length is not known at compile time. Entries in this -- array are set only if the corresponding entry in Is_Fixed_Length - -- is False. + -- is False. The entity is of type Intyp. Aggr_Length : array (0 .. N) of Node_Id; -- The J'th entry in an expression node that represents the total length -- of operands 1 through J. It is either an integer literal node, or a -- reference to a constant entity with the right value, so it is fine -- to just do a Copy_Node to get an appropriate copy. The extra zero'th - -- entry always is set to zero. + -- entry always is set to zero. The length is of type Intyp. Low_Bound : Node_Id; - -- An tree node representing the low bound of the result. This is either - -- an integer literal node, or an identifier reference to a constant - -- entity initialized to the appropriate value. + -- A tree node representing the low bound of the result (of type Ityp). + -- This is either an integer literal node, or an identifier reference to + -- a constant entity initialized to the appropriate value. + + High_Bound : Node_Id; + -- A tree node representing the high bound of the result (of type Ityp) Result : Node_Id; - -- Result of the concatenation + -- Result of the concatenation (of type Ityp) function To_Intyp (X : Node_Id) return Node_Id; -- Given a node of type Ityp, returns the corresponding value of type -- Intyp. For non-enumeration types, this is the identity. For enum - -- types. the Pos of the value is returned. + -- types, the Pos of the value is returned. function To_Ityp (X : Node_Id) return Node_Id; - -- The inverse function (uses Val in the case of enumeration types + -- The inverse function (uses Val in the case of enumeration types) -------------- -- To_Intyp -- @@ -2247,9 +2262,9 @@ package body Exp_Ch4 is -- Case where we will do a type conversion else - -- If the value is known at compile time, and known to be out - -- of range of the index type or the base type, we can signal - -- that we are sure to have a constraint error at run time. + -- If the value is known at compile time, and known to be out of + -- range of the index type or the base type, we can signal that + -- we are sure to have a constraint error at run time. -- There are two reasons for doing this. First of all, it is of -- course nice to detect situations of certain exceptions, and @@ -2287,12 +2302,13 @@ package body Exp_Ch4 is -- Local Declarations - Opnd : Node_Id; - Ent : Entity_Id; - Len : Uint; - J : Nat; - Clen : Node_Id; - Set : Boolean; + Opnd : Node_Id; + Opnd_Typ : Entity_Id; + Ent : Entity_Id; + Len : Uint; + J : Nat; + Clen : Node_Id; + Set : Boolean; begin Aggr_Length (0) := Make_Integer_Literal (Loc, 0); @@ -2312,7 +2328,7 @@ package body Exp_Ch4 is -- For enumeration types, we can simply use Standard_Integer, this is -- sufficient since the actual number of enumeration literals cannot -- possibly exceed the range of integer (remember we will be doing the - -- arithmetic with POS values, not represaentation values). + -- arithmetic with POS values, not representation values). if Is_Enumeration_Type (Ityp) then Intyp := Standard_Integer; @@ -2347,6 +2363,7 @@ package body Exp_Ch4 is J := 1; while J <= N loop Opnd := Remove_Head (Opnds); + Opnd_Typ := Etype (Opnd); -- The parent got messed up when we put the operands in a list, -- so now put back the proper parent for the saved operand. @@ -2359,52 +2376,71 @@ package body Exp_Ch4 is -- Singleton element (or character literal) case - if Base_Type (Etype (Opnd)) = Ctyp then + if Base_Type (Opnd_Typ) = Ctyp then NN := NN + 1; Operands (NN) := Opnd; Is_Fixed_Length (NN) := True; Fixed_Length (NN) := Uint_1; + Result_May_Be_Null := False; - -- Set lower bound to lower bound of index subtype. This is not - -- right where the index subtype bound is dynamic ??? + -- Set bounds of operand - if Compile_Time_Known_Value (Type_Low_Bound (Ityp)) then - Fixed_Low_Bound (NN) := - Expr_Value (Type_Low_Bound (Ityp)); - else - Fixed_Low_Bound (NN) := - Expr_Value (Type_Low_Bound (Base_Type (Ityp))); - end if; + Opnd_Low_Bound (NN) := + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ityp, Loc), + Attribute_Name => Name_First); + + -- ??? The addition below is dubious, what if Ityp is an enum + -- type, shouldn't this be Ityp'Succ (Ityp'First)? + + Opnd_High_Bound (NN) := + Make_Op_Add (Loc, + Left_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Reference_To (Ityp, Loc), + Attribute_Name => Name_First), + Right_Opnd => Make_Integer_Literal (Loc, 1)); Set := True; -- String literal case (can only occur for strings of course) elsif Nkind (Opnd) = N_String_Literal then - Len := UI_From_Int (String_Length (Strval (Opnd))); + Len := String_Literal_Length (Opnd_Typ); - -- We can safely skip null string literals, since they are - -- considered to have a lower bound of 1. + -- Skip null string literal unless last operand - if Len = 0 then + if J < N and then Len = 0 then goto Continue; end if; NN := NN + 1; Operands (NN) := Opnd; Is_Fixed_Length (NN) := True; + + -- Set length and bounds + Fixed_Length (NN) := Len; - Fixed_Low_Bound (NN) := Uint_1; + + Opnd_Low_Bound (NN) := + New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)); + + Opnd_High_Bound (NN) := + Make_Op_Add (Loc, + Left_Opnd => + New_Copy_Tree (String_Literal_Low_Bound (Opnd_Typ)), + Right_Opnd => Make_Integer_Literal (Loc, 1)); + Set := True; + Result_May_Be_Null := False; -- All other cases else -- Check constrained case with known bounds - if Is_Constrained (Etype (Opnd)) then + if Is_Constrained (Opnd_Typ) then declare - Opnd_Typ : constant Entity_Id := Etype (Opnd); Index : constant Node_Id := First_Index (Opnd_Typ); Indx_Typ : constant Entity_Id := Etype (Index); Lo : constant Node_Id := Type_Low_Bound (Indx_Typ); @@ -2425,40 +2461,61 @@ package body Exp_Ch4 is UI_Max (Hival - Loval + 1, Uint_0); begin - -- Exclude the null length case where the lower bound - -- is other than 1 or the type is other than string, - -- because annoyingly we need to keep such an operand - -- around in case it is the one that supplies a lower - -- bound to the result. - - if (Loval = 1 and then Atyp = Standard_String) - or Len > 0 - then - -- Skip null string case (lower bound = 1) - - if Len = 0 then - goto Continue; - end if; - - NN := NN + 1; - Operands (NN) := Opnd; - Is_Fixed_Length (NN) := True; - Fixed_Length (NN) := Len; - Fixed_Low_Bound (NN) := Expr_Value (Lo); - Set := True; + if Len > 0 then + Result_May_Be_Null := False; + end if; + + -- Exclude null length case except for last operand + -- (where we may need it to get proper bounds). + + if Len = 0 and then J < N then + goto Continue; end if; + + NN := NN + 1; + Operands (NN) := Opnd; + Is_Fixed_Length (NN) := True; + Fixed_Length (NN) := Len; + + -- ??? case where Ityp is an enum type? + + Opnd_Low_Bound (NN) := + Make_Integer_Literal (Loc, + Intval => Expr_Value (Lo)); + + Opnd_High_Bound (NN) := + Make_Integer_Literal (Loc, + Intval => Expr_Value (Hi)); + + Set := True; end; end if; end; end if; - -- All cases where the length is not known at compile time, or - -- the special case of an operand which is known to be null but - -- has a lower bound other than 1 or is other than a string type. - -- Capture length of operand in entity. + -- All cases where the length is not known at compile time, or the + -- special case of an operand which is known to be null but has a + -- lower bound other than 1 or is other than a string type. if not Set then NN := NN + 1; + + -- Capture operand bounds + + Opnd_Low_Bound (NN) := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Opnd, Name_Req => True), + Attribute_Name => Name_First); + + Opnd_High_Bound (NN) := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Opnd, Name_Req => True), + Attribute_Name => Name_Last); + + -- Capture length of operand in entity + Operands (NN) := Opnd; Is_Fixed_Length (NN) := False; @@ -2487,7 +2544,7 @@ package body Exp_Ch4 is -- Set next entry in aggregate length array -- For first entry, make either integer literal for fixed length - -- or a reference to the saved length for variable length + -- or a reference to the saved length for variable length. if NN = 1 then if Is_Fixed_Length (1) then @@ -2554,9 +2611,7 @@ package body Exp_Ch4 is if NN = 0 then Start_String; - Result := - Make_String_Literal (Loc, - Strval => End_String); + Result := Make_String_Literal (Loc, Strval => End_String); goto Done; end if; @@ -2586,28 +2641,26 @@ package body Exp_Ch4 is -- ancestor is the first subtype of this root type. if Is_Constrained (First_Subtype (Root_Type (Atyp))) then - Low_Bound := To_Intyp ( + Low_Bound := Make_Attribute_Reference (Loc, Prefix => New_Occurrence_Of (First_Subtype (Root_Type (Atyp)), Loc), - Attribute_Name => Name_First)); + Attribute_Name => Name_First); -- If the first operand in the list has known length we know that -- the lower bound of the result is the lower bound of this operand. elsif Is_Fixed_Length (1) then - Low_Bound := - Make_Integer_Literal (Loc, - Intval => Fixed_Low_Bound (1)); + Low_Bound := Opnd_Low_Bound (1); -- OK, we don't know the lower bound, we have to build a horrible -- expression actions node of the form -- if Cond1'Length /= 0 then - -- Opnd1'First + -- Opnd1 low bound -- else -- if Opnd2'Length /= 0 then - -- Opnd2'First + -- Opnd2 low bound -- else -- ... @@ -2626,23 +2679,9 @@ package body Exp_Ch4 is --------------------- function Get_Known_Bound (J : Nat) return Node_Id is - Lo : Node_Id; - begin - if Is_Fixed_Length (J) then - return - Make_Integer_Literal (Loc, - Intval => Fixed_Low_Bound (J)); - end if; - - Lo := To_Intyp ( - Make_Attribute_Reference (Loc, - Prefix => - Duplicate_Subexpr (Operands (J), Name_Req => True), - Attribute_Name => Name_First)); - - if J = NN then - return Lo; + if Is_Fixed_Length (J) or else J = NN then + return New_Copy (Opnd_Low_Bound (J)); else return @@ -2653,7 +2692,7 @@ package body Exp_Ch4 is Left_Opnd => New_Reference_To (Var_Length (J), Loc), Right_Opnd => Make_Integer_Literal (Loc, 0)), - Lo, + New_Copy (Opnd_Low_Bound (J)), Get_Known_Bound (J + 1))); end if; end Get_Known_Bound; @@ -2667,8 +2706,7 @@ package body Exp_Ch4 is Make_Object_Declaration (Loc, Defining_Identifier => Ent, Constant_Present => True, - Object_Definition => - New_Occurrence_Of (Intyp, Loc), + Object_Definition => New_Occurrence_Of (Ityp, Loc), Expression => Get_Known_Bound (1)), Suppress => All_Checks); @@ -2676,8 +2714,32 @@ package body Exp_Ch4 is end; end if; - -- Now we build the result, which is a reference to the array entity - -- we will construct with appropriate bounds. + -- Now find the upper bound. This is normally the Low_Bound + Length - 1 + -- but there is one exception, namely when the result is null in which + -- case the bounds come from the last operand (so that we get the proper + -- bounds if the last operand is super-flat). + + High_Bound := + To_Ityp ( + Make_Op_Add (Loc, + Left_Opnd => To_Intyp (New_Copy (Low_Bound)), + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => New_Copy (Aggr_Length (NN)), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + if Result_May_Be_Null then + High_Bound := + Make_Conditional_Expression (Loc, + Expressions => New_List ( + Make_Op_Eq (Loc, + Left_Opnd => New_Copy (Aggr_Length (NN)), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + Opnd_High_Bound (NN), + High_Bound)); + end if; + + -- Now we construct an array object with appropriate bounds Ent := Make_Defining_Identifier (Loc, @@ -2686,7 +2748,6 @@ package body Exp_Ch4 is Insert_Action (Cnode, Make_Object_Declaration (Loc, Defining_Identifier => Ent, - Object_Definition => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Atyp, Loc), @@ -2694,16 +2755,8 @@ package body Exp_Ch4 is Make_Index_Or_Discriminant_Constraint (Loc, Constraints => New_List ( Make_Range (Loc, - Low_Bound => To_Ityp (New_Copy (Low_Bound)), - High_Bound => To_Ityp ( - Make_Op_Add (Loc, - Left_Opnd => New_Copy (Low_Bound), - Right_Opnd => - Make_Op_Subtract (Loc, - Left_Opnd => New_Copy (Aggr_Length (NN)), - Right_Opnd => - Make_Integer_Literal (Loc, - Intval => Uint_1))))))))), + Low_Bound => Low_Bound, + High_Bound => High_Bound))))), Suppress => All_Checks); @@ -2713,18 +2766,16 @@ package body Exp_Ch4 is declare Lo : constant Node_Id := Make_Op_Add (Loc, - Left_Opnd => New_Copy (Low_Bound), + Left_Opnd => To_Intyp (New_Copy (Low_Bound)), Right_Opnd => Aggr_Length (J - 1)); Hi : constant Node_Id := Make_Op_Add (Loc, - Left_Opnd => New_Copy (Low_Bound), + Left_Opnd => To_Intyp (New_Copy (Low_Bound)), Right_Opnd => Make_Op_Subtract (Loc, Left_Opnd => Aggr_Length (J), - Right_Opnd => - Make_Integer_Literal (Loc, - Intval => 1))); + Right_Opnd => Make_Integer_Literal (Loc, 1))); begin -- Singleton case, simple assignment @@ -2757,6 +2808,8 @@ package body Exp_Ch4 is end; end loop; + -- Finally we build the result, which is a reference to the array object + Result := New_Reference_To (Ent, Loc); <> diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index f77e1e70960..9a2372efe1a 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -5509,13 +5509,19 @@ package body Freeze is end if; -- We only give the warning for non-imported entities of a type for - -- which a non-null base init proc is defined (or for access types which - -- have implicit null initialization). + -- which a non-null base init proc is defined, or for objects of access + -- types with implicit null initialization, or when Initialize_Scalars + -- applies and the type is scalar or a string type (the latter being + -- tested for because predefined String types are initialized by inline + -- code rather than by an init_proc). if Present (Expr) - and then (Has_Non_Null_Base_Init_Proc (Typ) - or else Is_Access_Type (Typ)) and then not Is_Imported (Ent) + and then (Has_Non_Null_Base_Init_Proc (Typ) + or else Is_Access_Type (Typ) + or else (Init_Or_Norm_Scalars + and then (Is_Scalar_Type (Typ) + or else Is_String_Type (Typ)))) then if Nkind (Expr) = N_Attribute_Reference and then Is_Entity_Name (Prefix (Expr)) diff --git a/gcc/ada/rtsfind.ads b/gcc/ada/rtsfind.ads index 5404fcdcd2b..314dc83c8a4 100644 --- a/gcc/ada/rtsfind.ads +++ b/gcc/ada/rtsfind.ads @@ -322,10 +322,6 @@ package Rtsfind is System_Storage_Elements, System_Storage_Pools, System_Stream_Attributes, - System_String_Ops, - System_String_Ops_Concat_3, - System_String_Ops_Concat_4, - System_String_Ops_Concat_5, System_Task_Info, System_Tasking, System_Threads, @@ -1320,17 +1316,6 @@ package Rtsfind is RE_W_WC, -- System.Stream_Attributes RE_W_WWC, -- System.Stream_Attributes - RE_Str_Concat, -- System.String_Ops - RE_Str_Concat_CC, -- System.String_Ops - RE_Str_Concat_CS, -- System.String_Ops - RE_Str_Concat_SC, -- System.String_Ops - - RE_Str_Concat_3, -- System.String_Ops_Concat_3 - - RE_Str_Concat_4, -- System.String_Ops_Concat_4 - - RE_Str_Concat_5, -- System.String_Ops_Concat_5 - RE_String_Input, -- System.Strings.Stream_Ops RE_String_Input_Blk_IO, -- System.Strings.Stream_Ops RE_String_Output, -- System.Strings.Stream_Ops @@ -2474,17 +2459,6 @@ package Rtsfind is RE_W_WC => System_Stream_Attributes, RE_W_WWC => System_Stream_Attributes, - RE_Str_Concat => System_String_Ops, - RE_Str_Concat_CC => System_String_Ops, - RE_Str_Concat_CS => System_String_Ops, - RE_Str_Concat_SC => System_String_Ops, - - RE_Str_Concat_3 => System_String_Ops_Concat_3, - - RE_Str_Concat_4 => System_String_Ops_Concat_4, - - RE_Str_Concat_5 => System_String_Ops_Concat_5, - RE_String_Input => System_Strings_Stream_Ops, RE_String_Input_Blk_IO => System_Strings_Stream_Ops, RE_String_Output => System_Strings_Stream_Ops, diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index cbdda92aa17..a135cd9f2cc 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -3905,9 +3905,6 @@ package body Sem_Ch10 is -- Check_Body_Required -- ------------------------- - -- ??? misses pragma Import on subprograms - -- ??? misses pragma Import on renamed subprograms - procedure Check_Body_Required is PA : constant List_Id := Pragmas_After (Aux_Decls_Node (Parent (P_Unit))); @@ -3923,6 +3920,97 @@ package body Sem_Ch10 is Decl : Node_Id; Incomplete_Decls : constant Elist_Id := New_Elmt_List; + Subp_List : constant Elist_Id := New_Elmt_List; + + procedure Check_Pragma_Import (P : Node_Id); + -- If a pragma import applies to a previous subprogram, the + -- enclosing unit may not need a body. The processing is + -- syntactic and does not require a declaration to be analyzed, + -- The code below also handles pragma import when applied to + -- a subprogram that renames another. In this case the pragma + -- applies to the renamed entity + -- Chains of multiple renames are not handled by the code below. + -- It is probably impossible to handle all cases without proper + -- name resolution. In such cases the algorithm is conservative + -- and will indicate that a body is needed??? + + ------------------------- + -- Check_Pragma_Import -- + ------------------------- + + procedure Check_Pragma_Import (P : Node_Id) is + Arg : Node_Id; + Prev_Id : Elmt_Id; + Subp_Id : Elmt_Id; + Imported : Node_Id; + + procedure Remove_Homonyms (E : Node_Id); + -- Make one pass over list of subprograms, Called again if + -- subprogram is a renaming. E is known to be an identifier. + + --------------------- + -- Remove_Homonyms -- + --------------------- + + procedure Remove_Homonyms (E : Entity_Id) is + R : Entity_Id := Empty; + -- Name of renamed entity, if any. + + begin + Subp_Id := First_Elmt (Subp_List); + + while Present (Subp_Id) loop + if Chars (Node (Subp_Id)) = Chars (E) then + if Nkind (Parent (Parent (Node (Subp_Id)))) + /= N_Subprogram_Renaming_Declaration + then + Prev_Id := Subp_Id; + Next_Elmt (Subp_Id); + Remove_Elmt (Subp_List, Prev_Id); + else + R := Name (Parent (Parent (Node (Subp_Id)))); + exit; + end if; + else + Next_Elmt (Subp_Id); + end if; + end loop; + + if Present (R) then + if Nkind (R) = N_Identifier then + Remove_Homonyms (R); + + elsif Nkind (R) = N_Selected_Component then + Remove_Homonyms (Selector_Name (R)); + + else + -- renaming of attribute + + null; + end if; + end if; + end Remove_Homonyms; + + -- Start of processing for Check_Pragma_Import + + begin + + -- Find name of entity in Import pragma. We have not analyzed + -- the construct, so we must guard against syntax errors. + + Arg := Next (First (Pragma_Argument_Associations (P))); + + if No (Arg) + or else Nkind (Expression (Arg)) /= N_Identifier + then + return; + else + Imported := Expression (Arg); + end if; + + Remove_Homonyms (Imported); + end Check_Pragma_Import; + begin -- Search for Elaborate Body pragma @@ -3942,15 +4030,15 @@ package body Sem_Ch10 is while Present (Decl) loop - -- Subprogram that comes from source means body required - -- This is where a test for Import is missing ??? + -- Subprogram that comes from source means body may be needed. + -- Save for subsequent examination of import pragmas. if Comes_From_Source (Decl) and then (Nkind_In (Decl, N_Subprogram_Declaration, + N_Subprogram_Renaming_Declaration, N_Generic_Subprogram_Declaration)) then - Set_Body_Required (Library_Unit (N)); - return; + Append_Elmt (Defining_Entity (Decl), Subp_List); -- Package declaration of generic package declaration. We need -- to recursively examine nested declarations. @@ -3959,6 +4047,11 @@ package body Sem_Ch10 is N_Generic_Package_Declaration) then Check_Declarations (Specification (Decl)); + + elsif Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Name_Import + then + Check_Pragma_Import (Decl); end if; Next (Decl); @@ -3972,9 +4065,10 @@ package body Sem_Ch10 is while Present (Decl) loop if Comes_From_Source (Decl) and then (Nkind_In (Decl, N_Subprogram_Declaration, + N_Subprogram_Renaming_Declaration, N_Generic_Subprogram_Declaration)) then - Set_Body_Required (Library_Unit (N)); + Append_Elmt (Defining_Entity (Decl), Subp_List); elsif Nkind_In (Decl, N_Package_Declaration, N_Generic_Package_Declaration) @@ -3985,6 +4079,11 @@ package body Sem_Ch10 is elsif Nkind (Decl) = N_Incomplete_Type_Declaration then Append_Elmt (Decl, Incomplete_Decls); + + elsif Nkind (Decl) = N_Pragma + and then Pragma_Name (Decl) = Name_Import + then + Check_Pragma_Import (Decl); end if; Next (Decl); @@ -4022,6 +4121,29 @@ package body Sem_Ch10 is Next_Elmt (Inc); end loop; end; + + -- Finally, check whether there are subprograms that still + -- require a body. + + if not Is_Empty_Elmt_List (Subp_List) then + declare + Subp_Id : Elmt_Id; + + begin + Subp_Id := First_Elmt (Subp_List); + + while Present (Subp_Id) loop + if Nkind (Parent (Parent (Node (Subp_Id)))) + /= N_Subprogram_Renaming_Declaration + then + Set_Body_Required (Library_Unit (N)); + return; + end if; + + Next_Elmt (Subp_Id); + end loop; + end; + end if; end Check_Declarations; -- Start of processing for Check_Body_Required diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 5e420c6e267..31f931e4679 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -490,7 +490,13 @@ package body Sem_Warn is P := Parent (P); exit when P = Loop_Statement; - if Nkind (P) = N_Procedure_Call_Statement then + -- Abandon if at procedure call, or something strange is + -- going on (perhaps a node with no parent that should + -- have one but does not?) As always, for a warning we + -- prefer to just abandon the warning than get into the + -- business of complaining about the tree structure here! + + if No (P) or else Nkind (P) = N_Procedure_Call_Statement then return Abandon; end if; end loop;