From: Arnaud Charlet Date: Tue, 7 Apr 2009 15:10:30 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=df46b832b04ae500284492241a71854b434aec37;p=gcc.git [multiple changes] 2009-04-07 Robert Dewar * g-socket.adb: Minor reformatting. * g-socthi-mingw.adb: Minor reformatting * g-sothco.ads: Minor reformatting * exp_ch4.adb: (Expand_Concatenate_String): Complete rewrite to generate efficient code inline instead of relying on external library routines. * s-strops.ads, s-sopco5.ads, s-sopco5.adb, s-sopco4.ads, s-sopco4.adb, s-sopco3.ads, s-sopco3.adb, s-strops.adb: Note that this unit is now obsolescent 2009-04-07 Ed Schonberg * sem_attr.adb: (Eval_Attribute): for attributes of array objects that are not strings, attributes are not static if nominal subtype of object is unconstrained. 2009-04-07 Ed Schonberg * sem_ch6.adb (New_Overloaded_Entity): If two implicit homonym operations for a type T in an instance do not override each other, when T is derived from a formal private type, the corresponding operations inherited by a type derived from T outside of the instance do not override each other either. From-SVN: r145679 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 7d168c87aac..7404808ded2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,33 @@ +2009-04-07 Robert Dewar + + * g-socket.adb: Minor reformatting. + + * g-socthi-mingw.adb: Minor reformatting + + * g-sothco.ads: Minor reformatting + + * exp_ch4.adb: + (Expand_Concatenate_String): Complete rewrite to generate efficient code + inline instead of relying on external library routines. + + * s-strops.ads, s-sopco5.ads, s-sopco5.adb, s-sopco4.ads, s-sopco4.adb, + s-sopco3.ads, s-sopco3.adb, s-strops.adb: Note that this unit is now + obsolescent + +2009-04-07 Ed Schonberg + + * sem_attr.adb: + (Eval_Attribute): for attributes of array objects that are not strings, + attributes are not static if nominal subtype of object is unconstrained. + +2009-04-07 Ed Schonberg + + * sem_ch6.adb (New_Overloaded_Entity): If two implicit homonym + operations for a type T in an instance do not override each other, + when T is derived from a formal private type, the corresponding + operations inherited by a type derived from T outside + of the instance do not override each other either. + 2009-04-07 Robert Dewar (Osint.Fail): Change calling sequence to have one string arg diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index e511e97e2e8..080a1af7b3f 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -62,6 +62,7 @@ with Sem_Warn; use Sem_Warn; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; +with Stringt; use Stringt; with Targparm; use Targparm; with Tbuild; use Tbuild; with Ttypes; use Ttypes; @@ -145,11 +146,9 @@ package body Exp_Ch4 is -- singleton operands into singleton aggregates. procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id); - -- Routine to expand concatenation of 2-5 operands (in the list Operands) - -- and replace node Cnode with the result of the concatenation. If there - -- are two operands, they can be string or character. If there are more - -- than two operands, then are always of type string (i.e. the caller has - -- already converted character operands to strings in this case). + -- Routine to expand concatenation a sequence of two or more operands (in + -- the list Operands) and replace node Cnode with the result of the + -- concatenation. The operands can be of type String or Character. procedure Fixup_Universal_Fixed_Operation (N : Node_Id); -- N is a N_Op_Divide or N_Op_Multiply node whose result is universal @@ -2761,74 +2760,440 @@ package body Exp_Ch4 is ------------------------------- procedure Expand_Concatenate_String (Cnode : Node_Id; Opnds : List_Id) is - Loc : constant Source_Ptr := Sloc (Cnode); - Opnd1 : constant Node_Id := First (Opnds); - Opnd2 : constant Node_Id := Next (Opnd1); - Typ1 : constant Entity_Id := Base_Type (Etype (Opnd1)); - Typ2 : constant Entity_Id := Base_Type (Etype (Opnd2)); + Loc : constant Source_Ptr := Sloc (Cnode); - R : RE_Id; - -- RE_Id value for function to be called + N : constant Nat := List_Length (Opnds); + -- Number of concatenation operands including nulls + + NN : Nat := 0; + -- Number of operands excluding any known to be null + + -- Arrays describing the operands, only the first NN entries of each + -- array are set (NN < N when we exclude known null operands). + + Is_Fixed_Length : array (1 .. N) of Boolean; + -- True if length of corresponding operand known at compile time + + Operands : array (1 .. N) of Node_Id; + -- Set to the corresponding entry in the Opnds list + + Fixed_Length : array (1 .. N) of Uint; + -- Set to length of operand. Entries in this array are set only if + -- the corresponding entry in Is_Fixed_Length is True. Note that the + -- values in this array are always greater than zero, since we exclude + -- any + + 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 are True. + + 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. + + 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. + + 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. + + Result : Node_Id; + -- Result of the concatenation + + Opnd : Node_Id; + Ent : Entity_Id; + Len : Uint; + J : Nat; + Clen : Node_Id; + Set : Boolean; begin - -- In all cases, we build a call to a routine giving the list of - -- arguments as the parameter list to the routine. + Aggr_Length (0) := Make_Integer_Literal (Loc, 0); - case List_Length (Opnds) is - when 2 => - if Typ1 = Standard_Character then - if Typ2 = Standard_Character then - R := RE_Str_Concat_CC; + -- Go through operands settinn up the above arrays - else - pragma Assert (Typ2 = Standard_String); - R := RE_Str_Concat_CS; + J := 1; + while J <= N loop + Opnd := Remove_Head (Opnds); + Set_Parent (Opnd, Parent (Cnode)); + Set := False; + + -- Character or Character literal case + + if Base_Type (Etype (Opnd)) = Standard_Character then + NN := NN + 1; + Operands (NN) := Opnd; + Is_Fixed_Length (NN) := True; + Fixed_Length (NN) := Uint_1; + Fixed_Low_Bound (NN) := Uint_1; + Set := True; + + -- String literal case + + elsif Nkind (Opnd) = N_String_Literal then + Len := UI_From_Int (String_Length (Strval (Opnd))); + + 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) := Uint_1; + Set := True; + + -- All other cases + + else + -- Check constrained case with known bounds + + if Is_Constrained (Etype (Opnd)) 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); + Hi : constant Node_Id := Type_High_Bound (Indx_Typ); + + begin + -- Fixed length constrained string type with known at + -- compile time bounds is last case of fixed length + + if Compile_Time_Known_Value (Lo) + and then + Compile_Time_Known_Value (Hi) + then + declare + Loval : constant Uint := Expr_Value (Lo); + Hival : constant Uint := Expr_Value (Hi); + Len : constant Uint := + UI_Max (Hival - Loval + 1, Uint_0); + + begin + -- Exclude the null length case where the lower bound + -- is other than 1 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 or Len > 0 then + + -- Skip null case (we know that low bound is 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; + end if; + 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. Capture length of operand in entity. + -- separate entities + + if not Set then + NN := NN + 1; + Operands (NN) := Opnd; + Is_Fixed_Length (NN) := False; + + Var_Length (NN) := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + Insert_Action (Cnode, + Make_Object_Declaration (Loc, + Defining_Identifier => Var_Length (NN), + Constant_Present => True, + + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Opnd, Name_Req => True), + Attribute_Name => Name_Length)), + + Suppress => All_Checks); + end if; + end if; + + -- 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 + + if NN = 1 then + if Is_Fixed_Length (1) then + Aggr_Length (1) := + Make_Integer_Literal (Loc, + Intval => Fixed_Length (1)); + else + Aggr_Length (1) := + New_Reference_To (Var_Length (1), Loc); + end if; + + -- If entry is fixed length and only fixed lengths so far, make + -- appropriate new integer literal adding new length. + + elsif Is_Fixed_Length (NN) + and then Nkind (Aggr_Length (NN - 1)) = N_Integer_Literal + then + Aggr_Length (NN) := + Make_Integer_Literal (Loc, + Intval => Fixed_Length (NN) + Intval (Aggr_Length (NN - 1))); + + -- All other cases, construct an addition node for the length and + -- create an entity initialized to this length. + + else + Ent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); + + if Is_Fixed_Length (NN) then + Clen := Make_Integer_Literal (Loc, Fixed_Length (NN)); + else + Clen := New_Reference_To (Var_Length (NN), Loc); + end if; + + Insert_Action (Cnode, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Constant_Present => True, + + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Copy (Aggr_Length (NN - 1)), + Right_Opnd => Clen)), + + Suppress => All_Checks); + + Aggr_Length (NN) := + Make_Identifier (Loc, + Chars => Chars (Ent)); + end if; + + <> + J := J + 1; + end loop; + + -- If we have only null operands, return a null string literal. Note + -- that this means the lower bound is 1, but we retained any known null + -- operands whose lower bound was not 1, so this is legitimate. + + if NN = 0 then + Start_String; + Result := + Make_String_Literal (Loc, + Strval => End_String); + goto Done; + end if; + + -- If we have only one non-null operand, return it and we are done. + -- There is one case in which this cannot be done, and that is when + -- the sole operand is of a character type, in which case it must be + -- converted to a string, and the easiest way of doing that is to go + -- through the normal general circuit. + + if NN = 1 + and then Base_Type (Etype (Operands (1))) /= Standard_Character + then + Result := Operands (1); + goto Done; + end if; + + -- Cases where we have a real concatenation + + -- Next step is to find the low bound for the result string that we + -- will allocate. Annoyingly this is not simply the low bound of the + -- first argument, because of the darned null string special exception. + + -- 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. + + if Is_Fixed_Length (1) then + Low_Bound := + Make_Integer_Literal (Loc, + Intval => Fixed_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 + -- else + -- if Opnd2'Length /= 0 then + -- Opnd2'First + -- else + -- ... + + -- The nesting ends either when we hit an operand whose length is known + -- at compile time, or on reaching the last operand, whose low bound we + -- take unconditionally whether or not it is null. It's easiest to do + -- this with a recursive procedure: + + else + declare + function Get_Known_Bound (J : Nat) return Node_Id; + -- Returns the lower bound determined by operands J .. NN + + --------------------- + -- Get_Known_Bound -- + --------------------- + + 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; - elsif Typ1 = Standard_String then - if Typ2 = Standard_Character then - R := RE_Str_Concat_SC; + Lo := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr (Operands (J), Name_Req => True), + Attribute_Name => Name_First); + + if J = NN then + return Lo; else - pragma Assert (Typ2 = Standard_String); - R := RE_Str_Concat; + return + Make_Conditional_Expression (Loc, + Expressions => New_List ( + + Make_Op_Ne (Loc, + Left_Opnd => New_Reference_To (Var_Length (J), Loc), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + + Lo, + Get_Known_Bound (J + 1))); end if; + end Get_Known_Bound; - -- If we have anything other than Standard_Character or - -- Standard_String, then we must have had a serious error - -- earlier, so we just abandon the attempt at expansion. + begin + Ent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('L')); - else - pragma Assert (Serious_Errors_Detected > 0); - return; - end if; + Insert_Action (Cnode, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, + Constant_Present => True, + Object_Definition => + New_Occurrence_Of (Standard_Natural, Loc), + Expression => Get_Known_Bound (1)), + Suppress => All_Checks); + + Low_Bound := New_Reference_To (Ent, Loc); + end; + end if; - when 3 => - R := RE_Str_Concat_3; + -- Now we build the result, which is a reference to the string entity + -- we will construct with appropriate bounds. - when 4 => - R := RE_Str_Concat_4; + Ent := + Make_Defining_Identifier (Loc, + Chars => New_Internal_Name ('S')); - when 5 => - R := RE_Str_Concat_5; + Insert_Action (Cnode, + Make_Object_Declaration (Loc, + Defining_Identifier => Ent, - when others => - R := RE_Null; - raise Program_Error; - end case; + Object_Definition => + Make_Subtype_Indication (Loc, + Subtype_Mark => New_Occurrence_Of (Standard_String, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => New_List ( + Make_Range (Loc, + Low_Bound => New_Copy (Low_Bound), + High_Bound => + 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, 1)))))))), + + Suppress => All_Checks); + + -- Now we will generate the assignments to do the actual concatenation + + for J in 1 .. NN loop + declare + Lo : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => New_Copy (Low_Bound), + Right_Opnd => Aggr_Length (J - 1)); + + Hi : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => New_Copy (Low_Bound), + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => Aggr_Length (J), + Right_Opnd => Make_Integer_Literal (Loc, 1))); - -- Now generate the appropriate call + begin + if Base_Type (Etype (Operands (J))) = Standard_Character then + Insert_Action (Cnode, + Make_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Expressions => New_List (Lo)), + Expression => Operands (J)), + Suppress => All_Checks); - Rewrite (Cnode, - Make_Function_Call (Sloc (Cnode), - Name => New_Occurrence_Of (RTE (R), Loc), - Parameter_Associations => Opnds)); + else + Insert_Action (Cnode, + Make_Assignment_Statement (Loc, + Name => + Make_Slice (Loc, + Prefix => New_Occurrence_Of (Ent, Loc), + Discrete_Range => + Make_Range (Loc, + Low_Bound => Lo, + High_Bound => Hi)), + Expression => Operands (J)), + Suppress => All_Checks); + end if; + end; + end loop; - Analyze_And_Resolve (Cnode, Standard_String); + Result := New_Reference_To (Ent, Loc); - exception - when RE_Not_Available => - return; + <> + Rewrite (Cnode, Result); + Analyze_And_Resolve (Cnode, Standard_String); end Expand_Concatenate_String; ------------------------ @@ -4540,21 +4905,6 @@ package body Exp_Ch4 is -- Expand_N_Op_Concat -- ------------------------ - Max_Available_String_Operands : Int := -1; - -- This is initialized the first time this routine is called. It records - -- a value of 0,2,3,4,5 depending on what Str_Concat_n procedures are - -- available in the run-time: - -- - -- 0 None available - -- 2 RE_Str_Concat available, RE_Str_Concat_3 not available - -- 3 RE_Str_Concat/Concat_3 available, RE_Str_Concat_4 not available - -- 4 RE_Str_Concat/Concat_3/4 available, RE_Str_Concat_5 not available - -- 5 All routines including RE_Str_Concat_5 available - - Char_Concat_Available : Boolean; - -- Records if the routines RE_Str_Concat_CC/CS/SC are available. True if - -- all three are available, False if any one of these is unavailable. - procedure Expand_N_Op_Concat (N : Node_Id) is Opnds : List_Id; -- List of operands to be concatenated @@ -4573,37 +4923,6 @@ package body Exp_Ch4 is -- Component type of concatenation represented by Cnode begin - -- Initialize global variables showing run-time status - - if Max_Available_String_Operands < 1 then - - -- See what routines are available and set max operand count - -- according to the highest count available in the run-time. - - if not RTE_Available (RE_Str_Concat) then - Max_Available_String_Operands := 0; - - elsif not RTE_Available (RE_Str_Concat_3) then - Max_Available_String_Operands := 2; - - elsif not RTE_Available (RE_Str_Concat_4) then - Max_Available_String_Operands := 3; - - elsif not RTE_Available (RE_Str_Concat_5) then - Max_Available_String_Operands := 4; - - else - Max_Available_String_Operands := 5; - end if; - - Char_Concat_Available := - RTE_Available (RE_Str_Concat_CC) - and then - RTE_Available (RE_Str_Concat_CS) - and then - RTE_Available (RE_Str_Concat_SC); - end if; - -- Ensure validity of both operands Binary_Op_Validity_Checks (N); @@ -4632,29 +4951,16 @@ package body Exp_Ch4 is -- nodes above, so now we process bottom up, doing the operations. We -- gather a string that is as long as possible up to five operands - -- The outer loop runs more than once if there are more than five - -- concatenations of type Standard.String, the most we handle for - -- this case, or if more than one concatenation type is involved. + -- The outer loop runs more than once if more than one concatenation + -- type is involved. Outer : loop Opnds := New_List (Left_Opnd (Cnode), Right_Opnd (Cnode)); Set_Parent (Opnds, N); - -- The inner loop gathers concatenation operands. We gather any - -- number of these in the non-string case, or if no concatenation - -- routines are available for string (since in that case we will - -- treat string like any other non-string case). Otherwise we only - -- gather as many operands as can be handled by the available - -- procedures in the run-time library (normally 5, but may be - -- less for the configurable run-time case). + -- The inner loop gathers concatenation operands Inner : while Cnode /= N - and then (Base_Type (Etype (Cnode)) /= Standard_String - or else - Max_Available_String_Operands = 0 - or else - List_Length (Opnds) < - Max_Available_String_Operands) and then Base_Type (Etype (Cnode)) = Base_Type (Etype (Parent (Cnode))) loop @@ -4662,17 +4968,15 @@ package body Exp_Ch4 is Append (Right_Opnd (Cnode), Opnds); end loop Inner; - -- Here we process the collected operands. First we convert singleton - -- operands to singleton aggregates. This is skipped however for the - -- case of two operands of type String since we have special routines - -- for these cases. + -- Here we process the collected operands. First convert singleton + -- operands to singleton aggregates. This is skipped however for + -- the case of operands of type Character/String since the string + -- concatenation routine can handle these special cases. Atyp := Base_Type (Etype (Cnode)); Ctyp := Base_Type (Component_Type (Etype (Cnode))); - if (List_Length (Opnds) > 2 or else Atyp /= Standard_String) - or else not Char_Concat_Available - then + if Atyp /= Standard_String then Opnd := First (Opnds); loop if Base_Type (Etype (Opnd)) = Ctyp then @@ -4689,9 +4993,7 @@ package body Exp_Ch4 is -- Now call appropriate continuation routine - if Atyp = Standard_String - and then Max_Available_String_Operands > 0 - then + if Atyp = Standard_String then Expand_Concatenate_String (Cnode, Opnds); else Expand_Concatenate_Other (Cnode, Opnds); diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index 0112ed8b84e..d14fae8f44c 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -1830,6 +1830,7 @@ package body GNAT.Sockets is procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is begin if Item.Last = No_Socket then + -- Uninitialized socket set, make sure it is properly zeroed out Reset_Socket_Set (Item.Set'Access); @@ -1838,6 +1839,7 @@ package body GNAT.Sockets is elsif Item.Last < Socket then Item.Last := Socket; end if; + Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); end Set; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb index a99c715fb31..a85a2572d8f 100644 --- a/gcc/ada/g-socthi-mingw.adb +++ b/gcc/ada/g-socthi-mingw.adb @@ -300,16 +300,16 @@ package body GNAT.Sockets.Thin is Last : aliased C.int; begin - -- Asynchronous connection failures are notified in the - -- exception fd set instead of the write fd set. To ensure - -- POSIX compatibility, copy write fd set into exception fd - -- set. Once select() returns, check any socket present in the - -- exception fd set and peek at incoming out-of-band data. If - -- the test is not successful, and the socket is present in - -- the initial write fd set, then move the socket from the + -- Asynchronous connection failures are notified in the exception fd set + -- instead of the write fd set. To ensure POSIX compatibility, copy + -- write fd set into exception fd set. Once select() returns, check any + -- socket present in the exception fd set and peek at incoming + -- out-of-band data. If the test is not successful, and the socket is + -- present in the initial write fd set, then move the socket from the -- exception fd set to the write fd set. if Writefds /= No_Fd_Set_Access then + -- Add any socket present in write fd set into exception fd set declare diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads index fc8304757c6..cb0bc09b86f 100644 --- a/gcc/ada/g-sothco.ads +++ b/gcc/ada/g-sothco.ads @@ -122,7 +122,7 @@ package GNAT.Sockets.Thin_Common is Sa_Family : Sockaddr_Length_And_Family; -- Address family (and address length on some platforms) - Sa_Data : C.char_array (1 .. 14) := (others => C.nul); + Sa_Data : C.char_array (1 .. 14) := (others => C.nul); -- Family-specific data -- Note that some platforms require that all unused (reserved) bytes -- in addresses be initialized to 0 (e.g. VxWorks). @@ -169,14 +169,15 @@ package GNAT.Sockets.Thin_Common is Sin_Family : Sockaddr_Length_And_Family; -- Address family (and address length on some platforms) - Sin_Port : C.unsigned_short; + Sin_Port : C.unsigned_short; -- Port in network byte order - Sin_Addr : In_Addr; + Sin_Addr : In_Addr; -- IPv4 address - Sin_Zero : C.char_array (1 .. 8) := (others => C.nul); + Sin_Zero : C.char_array (1 .. 8) := (others => C.nul); -- Padding + -- -- Note that some platforms require that all unused (reserved) bytes -- in addresses be initialized to 0 (e.g. VxWorks). end record; @@ -272,8 +273,8 @@ package GNAT.Sockets.Thin_Common is -- value if it is, zero if it is not. procedure Last_Socket_In_Set - (Set : access Fd_Set; - Last : Int_Access); + (Set : access Fd_Set; + Last : Int_Access); -- Find the largest socket in the socket set. This is needed for select(). -- When Last_Socket_In_Set is called, parameter Last is a maximum value of -- the largest socket. This hint is used to avoid scanning very large diff --git a/gcc/ada/s-sopco3.adb b/gcc/ada/s-sopco3.adb index 6637b082de1..da427cb5bcc 100644 --- a/gcc/ada/s-sopco3.adb +++ b/gcc/ada/s-sopco3.adb @@ -31,6 +31,10 @@ -- -- ------------------------------------------------------------------------------ +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + pragma Warnings (Off); pragma Compiler_Unit; pragma Warnings (On); diff --git a/gcc/ada/s-sopco3.ads b/gcc/ada/s-sopco3.ads index 1698b14acec..6bff28f3940 100644 --- a/gcc/ada/s-sopco3.ads +++ b/gcc/ada/s-sopco3.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, 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- -- @@ -33,6 +33,10 @@ -- This package contains the function for concatenating three strings +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + pragma Warnings (Off); pragma Compiler_Unit; pragma Warnings (On); diff --git a/gcc/ada/s-sopco4.adb b/gcc/ada/s-sopco4.adb index f7751aaae5a..3188e75c6f3 100644 --- a/gcc/ada/s-sopco4.adb +++ b/gcc/ada/s-sopco4.adb @@ -31,6 +31,10 @@ -- -- ------------------------------------------------------------------------------ +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + pragma Warnings (Off); pragma Compiler_Unit; pragma Warnings (On); diff --git a/gcc/ada/s-sopco4.ads b/gcc/ada/s-sopco4.ads index e705e5753d3..b08bcadea85 100644 --- a/gcc/ada/s-sopco4.ads +++ b/gcc/ada/s-sopco4.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, 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- -- @@ -33,6 +33,10 @@ -- This package contains the function for concatenating four strings +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + pragma Warnings (Off); pragma Compiler_Unit; pragma Warnings (On); diff --git a/gcc/ada/s-sopco5.adb b/gcc/ada/s-sopco5.adb index bacae9f7aa0..8ca4cda8443 100644 --- a/gcc/ada/s-sopco5.adb +++ b/gcc/ada/s-sopco5.adb @@ -31,6 +31,10 @@ -- -- ------------------------------------------------------------------------------ +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + pragma Warnings (Off); pragma Compiler_Unit; pragma Warnings (On); diff --git a/gcc/ada/s-sopco5.ads b/gcc/ada/s-sopco5.ads index 2613a439a4a..19766311d3f 100644 --- a/gcc/ada/s-sopco5.ads +++ b/gcc/ada/s-sopco5.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, 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- -- @@ -33,6 +33,10 @@ -- This package contains the function for concatenating five strings +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + pragma Warnings (Off); pragma Compiler_Unit; pragma Warnings (On); diff --git a/gcc/ada/s-strops.adb b/gcc/ada/s-strops.adb index e92c3bb7a6c..1c9b75f0f7e 100644 --- a/gcc/ada/s-strops.adb +++ b/gcc/ada/s-strops.adb @@ -31,6 +31,10 @@ -- -- ------------------------------------------------------------------------------ +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + pragma Warnings (Off); pragma Compiler_Unit; pragma Warnings (On); diff --git a/gcc/ada/s-strops.ads b/gcc/ada/s-strops.ads index 5d4191db783..ca8230d03b9 100644 --- a/gcc/ada/s-strops.ads +++ b/gcc/ada/s-strops.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2007, 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- -- @@ -34,6 +34,10 @@ -- This package contains functions for runtime operations on strings -- (other than runtime comparison, found in s-strcom.ads). +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + pragma Warnings (Off); pragma Compiler_Unit; pragma Warnings (On); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index fd72ba080d5..bab1802ec3a 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5258,7 +5258,7 @@ package body Sem_Attr is if Present (AS) and then Is_Constrained (AS) then P_Entity := AS; - -- If we have an unconstrained type, cannot fold + -- If we have an unconstrained type we cannot fold else Check_Expressions; @@ -5517,6 +5517,9 @@ package body Sem_Attr is -- an optimization, but it falls out essentially free, so why not. -- Again we compute the variable Static for easy reference later -- (note that no array attributes are static in Ada 83). + -- we also need to set Static properly for subsequent legality checks + -- which might otherwise accept non-static constants in contexts + -- where they are not legal. Static := Ada_Version >= Ada_95 and then Statically_Denotes_Entity (P); @@ -5526,6 +5529,16 @@ package body Sem_Attr is begin N := First_Index (P_Type); + + -- The expression is static if the array type is constrained + -- by given bounds, and not by an initial expression. Constant + -- strings are static in any case. + + if Root_Type (P_Type) /= Standard_String then + Static := + Static and then not Is_Constr_Subt_For_U_Nominal (P_Type); + end if; + while Present (N) loop Static := Static and then Is_Static_Subtype (Etype (N)); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 764d5245a95..0bc6dcee3df 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -7154,20 +7154,26 @@ package body Sem_Ch6 is -- odd case where both are derived operations declared at the -- same point, both operations should be declared, and in that -- case we bypass the following test and proceed to the next - -- part (this can only occur for certain obscure cases - -- involving homographs in instances and can't occur for - -- dispatching operations ???). Note that the following - -- condition is less than clear. For example, it's not at all - -- clear why there's a test for E_Entry here. ??? + -- part. This can only occur for certain obscure cases in + -- instances, when an operation on a type derived from a formal + -- private type does not override a homograph inherited from + -- the actual. In subsequent derivations of such a type, the + -- DT positions of these operations remain distinct, if they + -- have been set. if Present (Alias (S)) and then (No (Alias (E)) + or else Is_Abstract_Subprogram (S) or else Comes_From_Source (E) - or else Is_Dispatching_Operation (E)) - and then - (Ekind (E) = E_Entry - or else Ekind (E) /= E_Enumeration_Literal) + or else + (Is_Dispatching_Operation (E) + and then Present (DTC_Entity (Alias (S))) + and then Present (DTC_Entity (Alias (E))) + and then DT_Position (Alias (S)) + = DT_Position (Alias (E)))) + and then Ekind (E) /= E_Enumeration_Literal then + -- When an derived operation is overloaded it may be due to -- the fact that the full view of a private extension -- re-inherits. It has to be dealt with.