+2017-11-09 Piotr Trojanek <trojanek@adacore.com>
+
+ * 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 <schonberg@adacore.com>
+
+ * 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 <squirek@adacore.com>
+
+ * sem_ch8.adb (Analyze_Use_Package): Force installation of use_clauses
+ when processing generic instances.
+
+2017-11-09 Bob Duff <duff@adacore.com>
+
+ * 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 <charlet@adacore.com>
* gnat1drv.adb (Adjust_Global_Switches): Suppress warnings in codepeer
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;
-- 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;
procedure Append_Decoded_With_Brackets
(Buf : in out Bounded_String;
- Id : Name_Id)
+ Id : Valid_Name_Id)
is
P : Natural;
-- 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);
procedure Append_Unqualified_Decoded
(Buf : in out Bounded_String;
- Id : Name_Id)
+ Id : Valid_Name_Id)
is
Temp : Bounded_String;
begin
-- 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);
-- 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);
------------------------
procedure Get_Last_Two_Chars
- (N : Name_Id;
+ (N : Valid_Name_Id;
C1 : out Character;
C2 : out Character)
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);
-- 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;
-- 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;
-- 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;
-- 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;
-- 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;
-- 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;
-- 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);
-- 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);
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
-- 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;
-- 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;
----------------
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
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);
---------------
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
-- 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
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);
-- 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;
-- 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;
-- 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;
-- 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;
-- 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;
-- 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;
procedure wn (Id : Name_Id) is
begin
- if Id not in Name_Entries.First .. Name_Entries.Last then
- Write_Str ("<invalid name_id>");
+ 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 ("<No_Name>");
Write_Str ("<Error_Name>");
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 ("<invalid name_id>");
+ Write_Int (Int (Id));
end if;
Write_Eol;
-- 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
-- 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 --
------------------------------
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
-- 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
-- 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
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
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
-- 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
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);
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.
-- 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).
-- 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.
-- 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.
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);
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,
-- --
-- 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- --
-- 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;
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;
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);
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
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;
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;
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;
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;
projects / gcc.git / commitdiff