From c312b9f280e4bf77c5b2869a9508ea3e8a6c5744 Mon Sep 17 00:00:00 2001 From: Pierre-Marie de Rodat Date: Thu, 9 Nov 2017 11:24:53 +0000 Subject: [multiple changes] 2017-11-09 Piotr Trojanek * sem_prag.adb (Analyze_Part_Of): Reword error message. (Get_SPARK_Mode_Type): Do not raise Program_Error in case pragma SPARK_Mode appears with an illegal mode, treat this as a non-existent mode. 2017-11-09 Ed Schonberg * sem_ch4.adb (Analyze_Call): Reject a call to a function that returns a limited view of a type T declared in unit U1, when the function is declared in another unit U2 and the call appears in a procedure within another unit. 2017-11-09 Justin Squirek * sem_ch8.adb (Analyze_Use_Package): Force installation of use_clauses when processing generic instances. 2017-11-09 Bob Duff * namet.ads, namet.adb (Valid_Name_Id): New subtype that excludes Error_Name and No_Name. Use this (versus Name_Id) to indicate which objects can have those special values. Valid_Name_Id could usefully be used all over the compiler front end, but that's too much trouble for now. If we did that, we might want to rename: Name_Id --> Optional_Name_Id, Valid_Name_Id --> Name_Id. For parameters of type Valid_Name_Id, remove some redundant tests, including the ones found by CodePeer. Use Is_Valid_Name instead of membership test when appropriate. (Error_Name_Or_No_Name): Delete this; it's no longer needed. * sem_ch2.adb (Analyze_Identifier): Use "not Is_Valid_Name" instead of "in Error_Name_Or_No_Name". (Check_Parameterless_Call): Use "not Is_Valid_Name" instead of "in Error_Name_Or_No_Name". From-SVN: r254569 --- gcc/ada/ChangeLog | 36 ++++++++++++++ gcc/ada/namet.adb | 133 +++++++++++++++++++++++++-------------------------- gcc/ada/namet.ads | 77 ++++++++++++++--------------- gcc/ada/sem_ch2.adb | 4 +- gcc/ada/sem_ch4.adb | 24 +++++++++- gcc/ada/sem_ch8.adb | 5 +- gcc/ada/sem_prag.adb | 13 ++--- gcc/ada/sem_res.adb | 2 +- 8 files changed, 177 insertions(+), 117 deletions(-) (limited to 'gcc/ada') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2f92c29..1e599d0 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,39 @@ +2017-11-09 Piotr Trojanek + + * sem_prag.adb (Analyze_Part_Of): Reword error message. + (Get_SPARK_Mode_Type): Do not raise Program_Error in case pragma + SPARK_Mode appears with an illegal mode, treat this as a non-existent + mode. + +2017-11-09 Ed Schonberg + + * sem_ch4.adb (Analyze_Call): Reject a call to a function that returns + a limited view of a type T declared in unit U1, when the function is + declared in another unit U2 and the call appears in a procedure within + another unit. + +2017-11-09 Justin Squirek + + * sem_ch8.adb (Analyze_Use_Package): Force installation of use_clauses + when processing generic instances. + +2017-11-09 Bob Duff + + * namet.ads, namet.adb (Valid_Name_Id): New subtype that excludes + Error_Name and No_Name. Use this (versus Name_Id) to indicate which + objects can have those special values. Valid_Name_Id could usefully be + used all over the compiler front end, but that's too much trouble for + now. If we did that, we might want to rename: + Name_Id --> Optional_Name_Id, Valid_Name_Id --> Name_Id. + For parameters of type Valid_Name_Id, remove some redundant tests, + including the ones found by CodePeer. Use Is_Valid_Name instead of + membership test when appropriate. + (Error_Name_Or_No_Name): Delete this; it's no longer needed. + * sem_ch2.adb (Analyze_Identifier): Use "not Is_Valid_Name" instead of + "in Error_Name_Or_No_Name". + (Check_Parameterless_Call): Use "not Is_Valid_Name" instead of "in + Error_Name_Or_No_Name". + 2017-11-09 Arnaud Charlet * gnat1drv.adb (Adjust_Global_Switches): Suppress warnings in codepeer diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 2dcbe1a..ddb5482 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -159,8 +159,8 @@ package body Namet is Append (Buf, Buf2.Chars (1 .. Buf2.Length)); end Append; - procedure Append (Buf : in out Bounded_String; Id : Name_Id) is - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + procedure Append (Buf : in out Bounded_String; Id : Valid_Name_Id) is + pragma Assert (Is_Valid_Name (Id)); Index : constant Int := Name_Entries.Table (Id).Name_Chars_Index; Len : constant Short := Name_Entries.Table (Id).Name_Len; @@ -174,7 +174,9 @@ package body Namet is -- Append_Decoded -- -------------------- - procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id) is + procedure Append_Decoded + (Buf : in out Bounded_String; Id : Valid_Name_Id) + is C : Character; P : Natural; Temp : Bounded_String; @@ -449,7 +451,7 @@ package body Namet is procedure Append_Decoded_With_Brackets (Buf : in out Bounded_String; - Id : Name_Id) + Id : Valid_Name_Id) is P : Natural; @@ -596,7 +598,9 @@ package body Namet is -- Append_Unqualified -- ------------------------ - procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id) is + procedure Append_Unqualified + (Buf : in out Bounded_String; Id : Valid_Name_Id) + is Temp : Bounded_String; begin Append (Temp, Id); @@ -610,7 +614,7 @@ package body Namet is procedure Append_Unqualified_Decoded (Buf : in out Bounded_String; - Id : Name_Id) + Id : Valid_Name_Id) is Temp : Bounded_String; begin @@ -773,7 +777,7 @@ package body Namet is -- Get_Decoded_Name_String -- ----------------------------- - procedure Get_Decoded_Name_String (Id : Name_Id) is + procedure Get_Decoded_Name_String (Id : Valid_Name_Id) is begin Global_Name_Buffer.Length := 0; Append_Decoded (Global_Name_Buffer, Id); @@ -783,7 +787,7 @@ package body Namet is -- Get_Decoded_Name_String_With_Brackets -- ------------------------------------------- - procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id) is + procedure Get_Decoded_Name_String_With_Brackets (Id : Valid_Name_Id) is begin Global_Name_Buffer.Length := 0; Append_Decoded_With_Brackets (Global_Name_Buffer, Id); @@ -794,7 +798,7 @@ package body Namet is ------------------------ procedure Get_Last_Two_Chars - (N : Name_Id; + (N : Valid_Name_Id; C1 : out Character; C2 : out Character) is @@ -815,13 +819,13 @@ package body Namet is -- Get_Name_String -- --------------------- - procedure Get_Name_String (Id : Name_Id) is + procedure Get_Name_String (Id : Valid_Name_Id) is begin Global_Name_Buffer.Length := 0; Append (Global_Name_Buffer, Id); end Get_Name_String; - function Get_Name_String (Id : Name_Id) return String is + function Get_Name_String (Id : Valid_Name_Id) return String is Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); begin Append (Buf, Id); @@ -832,7 +836,7 @@ package body Namet is -- Get_Name_String_And_Append -- -------------------------------- - procedure Get_Name_String_And_Append (Id : Name_Id) is + procedure Get_Name_String_And_Append (Id : Valid_Name_Id) is begin Append (Global_Name_Buffer, Id); end Get_Name_String_And_Append; @@ -841,9 +845,9 @@ package body Namet is -- Get_Name_Table_Boolean1 -- ----------------------------- - function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean is + function Get_Name_Table_Boolean1 (Id : Valid_Name_Id) return Boolean is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); return Name_Entries.Table (Id).Boolean1_Info; end Get_Name_Table_Boolean1; @@ -851,9 +855,9 @@ package body Namet is -- Get_Name_Table_Boolean2 -- ----------------------------- - function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean is + function Get_Name_Table_Boolean2 (Id : Valid_Name_Id) return Boolean is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); return Name_Entries.Table (Id).Boolean2_Info; end Get_Name_Table_Boolean2; @@ -861,9 +865,9 @@ package body Namet is -- Get_Name_Table_Boolean3 -- ----------------------------- - function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean is + function Get_Name_Table_Boolean3 (Id : Valid_Name_Id) return Boolean is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); return Name_Entries.Table (Id).Boolean3_Info; end Get_Name_Table_Boolean3; @@ -871,9 +875,9 @@ package body Namet is -- Get_Name_Table_Byte -- ------------------------- - function Get_Name_Table_Byte (Id : Name_Id) return Byte is + function Get_Name_Table_Byte (Id : Valid_Name_Id) return Byte is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); return Name_Entries.Table (Id).Byte_Info; end Get_Name_Table_Byte; @@ -881,9 +885,9 @@ package body Namet is -- Get_Name_Table_Int -- ------------------------- - function Get_Name_Table_Int (Id : Name_Id) return Int is + function Get_Name_Table_Int (Id : Valid_Name_Id) return Int is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); return Name_Entries.Table (Id).Int_Info; end Get_Name_Table_Int; @@ -891,7 +895,7 @@ package body Namet is -- Get_Unqualified_Decoded_Name_String -- ----------------------------------------- - procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id) is + procedure Get_Unqualified_Decoded_Name_String (Id : Valid_Name_Id) is begin Global_Name_Buffer.Length := 0; Append_Unqualified_Decoded (Global_Name_Buffer, Id); @@ -901,7 +905,7 @@ package body Namet is -- Get_Unqualified_Name_String -- --------------------------------- - procedure Get_Unqualified_Name_String (Id : Name_Id) is + procedure Get_Unqualified_Name_String (Id : Valid_Name_Id) is begin Global_Name_Buffer.Length := 0; Append_Unqualified (Global_Name_Buffer, Id); @@ -1032,15 +1036,11 @@ package body Namet is return False; end Is_Internal_Name; - function Is_Internal_Name (Id : Name_Id) return Boolean is + function Is_Internal_Name (Id : Valid_Name_Id) return Boolean is Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); begin - if Id in Error_Name_Or_No_Name then - return False; - else - Append (Buf, Id); - return Is_Internal_Name (Buf); - end if; + Append (Buf, Id); + return Is_Internal_Name (Buf); end Is_Internal_Name; function Is_Internal_Name return Boolean is @@ -1066,10 +1066,10 @@ package body Namet is -- Is_Operator_Name -- ---------------------- - function Is_Operator_Name (Id : Name_Id) return Boolean is + function Is_Operator_Name (Id : Valid_Name_Id) return Boolean is S : Int; begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); S := Name_Entries.Table (Id).Name_Chars_Index; return Name_Chars.Table (S + 1) = 'O'; end Is_Operator_Name; @@ -1087,7 +1087,7 @@ package body Namet is -- Length_Of_Name -- -------------------- - function Length_Of_Name (Id : Name_Id) return Nat is + function Length_Of_Name (Id : Valid_Name_Id) return Nat is begin return Int (Name_Entries.Table (Id).Name_Len); end Length_Of_Name; @@ -1111,7 +1111,7 @@ package body Namet is ---------------- function Name_Enter - (Buf : Bounded_String := Global_Name_Buffer) return Name_Id + (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id is begin Name_Entries.Append @@ -1136,7 +1136,7 @@ package body Namet is return Name_Entries.Last; end Name_Enter; - function Name_Enter (S : String) return Name_Id is + function Name_Enter (S : String) return Valid_Name_Id is Buf : Bounded_String (Max_Length => S'Length); begin Append (Buf, S); @@ -1157,7 +1157,7 @@ package body Namet is --------------- function Name_Find - (Buf : Bounded_String := Global_Name_Buffer) return Name_Id + (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id is New_Id : Name_Id; -- Id of entry in hash search, and value to be returned @@ -1172,7 +1172,7 @@ package body Namet is -- Quick handling for one character names if Buf.Length = 1 then - return Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1))); + return Valid_Name_Id (First_Name_Id + Character'Pos (Buf.Chars (1))); -- Otherwise search hash table for existing matching entry @@ -1241,7 +1241,7 @@ package body Namet is end if; end Name_Find; - function Name_Find (S : String) return Name_Id is + function Name_Find (S : String) return Valid_Name_Id is Buf : Bounded_String (Max_Length => S'Length); begin Append (Buf, S); @@ -1476,7 +1476,7 @@ package body Namet is -- Name_Equals -- ----------------- - function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean is + function Name_Equals (N1, N2 : Valid_Name_Id) return Boolean is begin return N1 = N2 or else Get_Name_String (N1) = Get_Name_String (N2); end Name_Equals; @@ -1550,9 +1550,9 @@ package body Namet is -- Set_Name_Table_Boolean1 -- ----------------------------- - procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean) is + procedure Set_Name_Table_Boolean1 (Id : Valid_Name_Id; Val : Boolean) is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); Name_Entries.Table (Id).Boolean1_Info := Val; end Set_Name_Table_Boolean1; @@ -1560,9 +1560,9 @@ package body Namet is -- Set_Name_Table_Boolean2 -- ----------------------------- - procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean) is + procedure Set_Name_Table_Boolean2 (Id : Valid_Name_Id; Val : Boolean) is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); Name_Entries.Table (Id).Boolean2_Info := Val; end Set_Name_Table_Boolean2; @@ -1570,9 +1570,9 @@ package body Namet is -- Set_Name_Table_Boolean3 -- ----------------------------- - procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean) is + procedure Set_Name_Table_Boolean3 (Id : Valid_Name_Id; Val : Boolean) is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); Name_Entries.Table (Id).Boolean3_Info := Val; end Set_Name_Table_Boolean3; @@ -1580,9 +1580,9 @@ package body Namet is -- Set_Name_Table_Byte -- ------------------------- - procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte) is + procedure Set_Name_Table_Byte (Id : Valid_Name_Id; Val : Byte) is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); Name_Entries.Table (Id).Byte_Info := Val; end Set_Name_Table_Byte; @@ -1590,9 +1590,9 @@ package body Namet is -- Set_Name_Table_Int -- ------------------------- - procedure Set_Name_Table_Int (Id : Name_Id; Val : Int) is + procedure Set_Name_Table_Int (Id : Valid_Name_Id; Val : Int) is begin - pragma Assert (Id in Name_Entries.First .. Name_Entries.Last); + pragma Assert (Is_Valid_Name (Id)); Name_Entries.Table (Id).Int_Info := Val; end Set_Name_Table_Int; @@ -1734,8 +1734,13 @@ package body Namet is procedure wn (Id : Name_Id) is begin - if Id not in Name_Entries.First .. Name_Entries.Last then - Write_Str (""); + if Is_Valid_Name (Id) then + declare + Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); + begin + Append (Buf, Id); + Write_Str (Buf.Chars (1 .. Buf.Length)); + end; elsif Id = No_Name then Write_Str (""); @@ -1744,12 +1749,8 @@ package body Namet is Write_Str (""); else - declare - Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); - begin - Append (Buf, Id); - Write_Str (Buf.Chars (1 .. Buf.Length)); - end; + Write_Str (""); + Write_Int (Int (Id)); end if; Write_Eol; @@ -1759,26 +1760,22 @@ package body Namet is -- Write_Name -- ---------------- - procedure Write_Name (Id : Name_Id) is + procedure Write_Name (Id : Valid_Name_Id) is Buf : Bounded_String (Max_Length => Natural (Length_Of_Name (Id))); begin - if Id >= First_Name_Id then - Append (Buf, Id); - Write_Str (Buf.Chars (1 .. Buf.Length)); - end if; + Append (Buf, Id); + Write_Str (Buf.Chars (1 .. Buf.Length)); end Write_Name; ------------------------ -- Write_Name_Decoded -- ------------------------ - procedure Write_Name_Decoded (Id : Name_Id) is + procedure Write_Name_Decoded (Id : Valid_Name_Id) is Buf : Bounded_String; begin - if Id >= First_Name_Id then - Append_Decoded (Buf, Id); - Write_Str (Buf.Chars (1 .. Buf.Length)); - end if; + Append_Decoded (Buf, Id); + Write_Str (Buf.Chars (1 .. Buf.Length)); end Write_Name_Decoded; -- Package initialization, initialize tables diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 72ac8fa..f5b078d 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -198,12 +198,12 @@ package Namet is -- indicate that some kind of error was encountered in scanning out -- the relevant name, so it does not have a representable label. - subtype Error_Name_Or_No_Name is Name_Id range No_Name .. Error_Name; - -- Used to test for either error name or no name - First_Name_Id : constant Name_Id := Names_Low_Bound + 2; -- Subscript of first entry in names table + subtype Valid_Name_Id is Name_Id range First_Name_Id .. Name_Id'Last; + -- All but No_Name and Error_Name + ------------------------------ -- Name_Id Membership Tests -- ------------------------------ @@ -337,8 +337,8 @@ package Namet is function "+" (Buf : Bounded_String) return String renames To_String; function Name_Find - (Buf : Bounded_String := Global_Name_Buffer) return Name_Id; - function Name_Find (S : String) return Name_Id; + (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id; + function Name_Find (S : String) return Valid_Name_Id; -- Name_Find searches the names table to see if the string has already been -- stored. If so, the Id of the existing entry is returned. Otherwise a new -- entry is created with its Name_Table_Int fields set to zero/false. Note @@ -346,8 +346,8 @@ package Namet is -- name string. function Name_Enter - (Buf : Bounded_String := Global_Name_Buffer) return Name_Id; - function Name_Enter (S : String) return Name_Id; + (Buf : Bounded_String := Global_Name_Buffer) return Valid_Name_Id; + function Name_Enter (S : String) return Valid_Name_Id; -- Name_Enter is similar to Name_Find. The difference is that it does not -- search the table for an existing match, and also subsequent Name_Find -- calls using the same name will not locate the entry created by this @@ -358,10 +358,10 @@ package Namet is -- names, since these are efficiently located without hashing by Name_Find -- in any case. - function Name_Equals (N1 : Name_Id; N2 : Name_Id) return Boolean; + function Name_Equals (N1, N2 : Valid_Name_Id) return Boolean; -- Return whether N1 and N2 denote the same character sequence - function Get_Name_String (Id : Name_Id) return String; + function Get_Name_String (Id : Valid_Name_Id) return String; -- Returns the characters of Id as a String. The lower bound is 1. -- The following Append procedures ignore any characters that don't fit in @@ -380,11 +380,11 @@ package Namet is procedure Append (Buf : in out Bounded_String; Buf2 : Bounded_String); -- Append Buf2 onto Buf - procedure Append (Buf : in out Bounded_String; Id : Name_Id); + procedure Append (Buf : in out Bounded_String; Id : Valid_Name_Id); -- Append the characters of Id onto Buf. It is an error to call this with -- one of the special name Id values (No_Name or Error_Name). - procedure Append_Decoded (Buf : in out Bounded_String; Id : Name_Id); + procedure Append_Decoded (Buf : in out Bounded_String; Id : Valid_Name_Id); -- Same as Append, except that the result is decoded, so that upper half -- characters and wide characters appear as originally found in the source -- program text, operators have their source forms (special characters and @@ -393,7 +393,7 @@ package Namet is procedure Append_Decoded_With_Brackets (Buf : in out Bounded_String; - Id : Name_Id); + Id : Valid_Name_Id); -- Same as Append_Decoded, except that the brackets notation (Uhh -- replaced by ["hh"], Whhhh replaced by ["hhhh"], WWhhhhhhhh replaced by -- ["hhhhhhhh"]) is used for all non-lower half characters, regardless of @@ -403,7 +403,8 @@ package Namet is -- requirement for a canonical representation not affected by the -- character set options (e.g. in the binder generation of symbols). - procedure Append_Unqualified (Buf : in out Bounded_String; Id : Name_Id); + procedure Append_Unqualified + (Buf : in out Bounded_String; Id : Valid_Name_Id); -- Same as Append, except that qualification (as defined in unit -- Exp_Dbug) is removed (including both preceding __ delimited names, and -- also the suffixes used to indicate package body entities and to @@ -415,7 +416,7 @@ package Namet is procedure Append_Unqualified_Decoded (Buf : in out Bounded_String; - Id : Name_Id); + Id : Valid_Name_Id); -- Same as Append_Unqualified, but decoded as for Append_Decoded procedure Append_Encoded (Buf : in out Bounded_String; C : Char_Code); @@ -443,40 +444,40 @@ package Namet is function Is_Internal_Name (Buf : Bounded_String) return Boolean; procedure Get_Last_Two_Chars - (N : Name_Id; + (N : Valid_Name_Id; C1 : out Character; C2 : out Character); -- Obtains last two characters of a name. C1 is last but one character and -- C2 is last character. If name is less than two characters long then both -- C1 and C2 are set to ASCII.NUL on return. - function Get_Name_Table_Boolean1 (Id : Name_Id) return Boolean; - function Get_Name_Table_Boolean2 (Id : Name_Id) return Boolean; - function Get_Name_Table_Boolean3 (Id : Name_Id) return Boolean; + function Get_Name_Table_Boolean1 (Id : Valid_Name_Id) return Boolean; + function Get_Name_Table_Boolean2 (Id : Valid_Name_Id) return Boolean; + function Get_Name_Table_Boolean3 (Id : Valid_Name_Id) return Boolean; -- Fetches the Boolean values associated with the given name - function Get_Name_Table_Byte (Id : Name_Id) return Byte; + function Get_Name_Table_Byte (Id : Valid_Name_Id) return Byte; pragma Inline (Get_Name_Table_Byte); -- Fetches the Byte value associated with the given name - function Get_Name_Table_Int (Id : Name_Id) return Int; + function Get_Name_Table_Int (Id : Valid_Name_Id) return Int; pragma Inline (Get_Name_Table_Int); -- Fetches the Int value associated with the given name - procedure Set_Name_Table_Boolean1 (Id : Name_Id; Val : Boolean); - procedure Set_Name_Table_Boolean2 (Id : Name_Id; Val : Boolean); - procedure Set_Name_Table_Boolean3 (Id : Name_Id; Val : Boolean); + procedure Set_Name_Table_Boolean1 (Id : Valid_Name_Id; Val : Boolean); + procedure Set_Name_Table_Boolean2 (Id : Valid_Name_Id; Val : Boolean); + procedure Set_Name_Table_Boolean3 (Id : Valid_Name_Id; Val : Boolean); -- Sets the Boolean value associated with the given name - procedure Set_Name_Table_Byte (Id : Name_Id; Val : Byte); + procedure Set_Name_Table_Byte (Id : Valid_Name_Id; Val : Byte); pragma Inline (Set_Name_Table_Byte); -- Sets the Byte value associated with the given name - procedure Set_Name_Table_Int (Id : Name_Id; Val : Int); + procedure Set_Name_Table_Int (Id : Valid_Name_Id; Val : Int); pragma Inline (Set_Name_Table_Int); -- Sets the Int value associated with the given name - function Is_Internal_Name (Id : Name_Id) return Boolean; + function Is_Internal_Name (Id : Valid_Name_Id) return Boolean; -- Returns True if the name is an internal name, i.e. contains a character -- for which Is_OK_Internal_Letter is true, or if the name starts or ends -- with an underscore. @@ -500,7 +501,7 @@ package Namet is -- set of reserved letters is O, Q, U, W) and also returns False for the -- letter X, which is reserved for debug output (see Exp_Dbug). - function Is_Operator_Name (Id : Name_Id) return Boolean; + function Is_Operator_Name (Id : Valid_Name_Id) return Boolean; -- Returns True if name given is of the form of an operator (that is, it -- starts with an upper case O). @@ -508,7 +509,7 @@ package Namet is -- True if Id is a valid name - points to a valid entry in the Name_Entries -- table. - function Length_Of_Name (Id : Name_Id) return Nat; + function Length_Of_Name (Id : Valid_Name_Id) return Nat; pragma Inline (Length_Of_Name); -- Returns length of given name in characters. This is the length of the -- encoded name, as stored in the names table. @@ -553,13 +554,13 @@ package Namet is -- Writes out internal tables to current tree file using the relevant -- Table.Tree_Write routines. - procedure Write_Name (Id : Name_Id); + procedure Write_Name (Id : Valid_Name_Id); -- Write_Name writes the characters of the specified name using the -- standard output procedures in package Output. The name is written -- in encoded form (i.e. including Uhh, Whhh, Qx, _op as they appear in -- the name table). If Id is Error_Name, or No_Name, no text is output. - procedure Write_Name_Decoded (Id : Name_Id); + procedure Write_Name_Decoded (Id : Valid_Name_Id); -- Like Write_Name, except that the name written is the decoded name, as -- described for Append_Decoded. @@ -586,17 +587,17 @@ package Namet is procedure Add_Str_To_Name_Buffer (S : String); - procedure Get_Decoded_Name_String (Id : Name_Id); + procedure Get_Decoded_Name_String (Id : Valid_Name_Id); - procedure Get_Decoded_Name_String_With_Brackets (Id : Name_Id); + procedure Get_Decoded_Name_String_With_Brackets (Id : Valid_Name_Id); - procedure Get_Name_String (Id : Name_Id); + procedure Get_Name_String (Id : Valid_Name_Id); - procedure Get_Name_String_And_Append (Id : Name_Id); + procedure Get_Name_String_And_Append (Id : Valid_Name_Id); - procedure Get_Unqualified_Decoded_Name_String (Id : Name_Id); + procedure Get_Unqualified_Decoded_Name_String (Id : Valid_Name_Id); - procedure Get_Unqualified_Name_String (Id : Name_Id); + procedure Get_Unqualified_Name_String (Id : Valid_Name_Id); procedure Insert_Str_In_Name_Buffer (S : String; Index : Positive); @@ -739,12 +740,12 @@ private for Name_Entry'Size use 16 * 8; -- This ensures that we did not leave out any fields - -- This is the table that is referenced by Name_Id entries. + -- This is the table that is referenced by Valid_Name_Id entries. -- It contains one entry for each unique name in the table. package Name_Entries is new Table.Table ( Table_Component_Type => Name_Entry, - Table_Index_Type => Name_Id'Base, + Table_Index_Type => Valid_Name_Id'Base, Table_Low_Bound => First_Name_Id, Table_Initial => Alloc.Names_Initial, Table_Increment => Alloc.Names_Increment, diff --git a/gcc/ada/sem_ch2.adb b/gcc/ada/sem_ch2.adb index f20a518..92f1c02 100644 --- a/gcc/ada/sem_ch2.adb +++ b/gcc/ada/sem_ch2.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -68,7 +68,7 @@ package body Sem_Ch2 is -- this is the result of some kind of previous error generating a -- junk identifier. - if Chars (N) in Error_Name_Or_No_Name + if not Is_Valid_Name (Chars (N)) and then Total_Errors_Detected /= 0 then return; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 2ef5747..c8ef8d8 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1520,6 +1520,27 @@ package body Sem_Ch4 is and then Present (Non_Limited_View (Etype (N))) then Set_Etype (N, Non_Limited_View (Etype (N))); + + -- If there is no completion for the type, this may be because + -- there is only a limited view of it and there is nothing in + -- the context of the current unit that has required a regular + -- compilation of the unit containing the type. We recognize + -- this unusual case by the fact that that unit is not analyzed. + -- Note that the call being analyzed is in a different unit from + -- the function declaration, and nothing indicates that the type + -- is a limited view. + + elsif Ekind (Scope (Etype (N))) = E_Package + and then Present (Limited_View (Scope (Etype (N)))) + and then not Analyzed (Unit_Declaration_Node (Scope (Etype (N)))) + then + Error_Msg_NE ("cannot call function that returns " + & "limited view of}", N, Etype (N)); + Error_Msg_NE + ("\there must be a regular with_clause for package& " + & "in the current unit, or in some unit in its context", + N, Scope (Etype (N))); + Set_Etype (N, Any_Type); end if; end if; end if; @@ -8681,7 +8702,8 @@ package body Sem_Ch4 is else -- The type of the subprogram may be a limited view obtained -- transitively from another unit. If full view is available, - -- use it to analyze call. + -- use it to analyze call. If there is no nonlimited view, then + -- this is diagnosed when analyzing the rewritten call. declare T : constant Entity_Id := Etype (Subprog); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 31ce62b..aea9bf8 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -3821,7 +3821,10 @@ package body Sem_Ch8 is Check_In_Previous_With_Clause (N, Name (N)); end if; - Use_One_Package (N, Name (N)); + -- Force the use_clause when we are in a generic instance because the + -- scope of the package has changed and we must ensure visibility. + + Use_One_Package (N, Name (N), Force => In_Instance); -- Capture the first Ghost package and the first living package diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 0f6223e..596f306 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -3287,8 +3287,8 @@ package body Sem_Prag is if not Is_Child_Or_Sibling (Pack_Id, Scope (Encap_Id)) then SPARK_Msg_NE - ("indicator Part_Of must denote abstract state or public " - & "descendant of & (SPARK RM 7.2.6(3))", + ("indicator Part_Of must denote abstract state of & " + & "or of its public descendant (SPARK RM 7.2.6(3))", Indic, Parent_Unit); return; @@ -3301,8 +3301,8 @@ package body Sem_Prag is else SPARK_Msg_NE - ("indicator Part_Of must denote abstract state or public " - & "descendant of & (SPARK RM 7.2.6(3))", + ("indicator Part_Of must denote abstract state of & " + & "or of its public descendant (SPARK RM 7.2.6(3))", Indic, Parent_Unit); return; end if; @@ -29364,10 +29364,11 @@ package body Sem_Prag is elsif N = Name_Off then return Off; - -- Any other argument is illegal + -- Any other argument is illegal. Assume that no SPARK mode applies to + -- avoid potential cascaded errors. else - raise Program_Error; + return None; end if; end Get_SPARK_Mode_Type; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3faeb55..49a654f 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -1030,7 +1030,7 @@ package body Sem_Res is if Nkind (N) in N_Has_Etype and then Etype (N) = Any_Type then return; elsif Nkind (N) in N_Has_Chars - and then Chars (N) in Error_Name_Or_No_Name + and then not Is_Valid_Name (Chars (N)) then return; end if; -- cgit v1.1