Commit 522aa6ee by Arnaud Charlet

[multiple changes]

2017-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_ch8.adb (Find_Direct_Name): Account for the case where
	a use-visible entity is defined within a nested scope of an
	instance when giving priority to entities which were visible in
	the original generic.
	* sem_util.ads, sem_util.adb (Nearest_Enclosing_Instance): New routine.

2017-04-27  Tristan Gingold  <gingold@adacore.com>

	* raise-gcc.c: Don't use unwind.h while compiling
	for the frontend, but mimic host behavior.

2017-04-27  Javier Miranda  <miranda@adacore.com>

	* sem_ch3.adb (Build_Discriminated_Subtype):
	Propagate Has_Pragma_Unreferenced_Objects to the built subtype.

2017-04-27  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_prag.adb (Analyze_Global_Item):
	Do not consider discriminants because they are not "entire
	objects". Remove the discriminant-related checks because they are
	obsolete.
	(Analyze_Input_Output): Do not consider discriminants
	because they are not "entire objects".

2017-04-27  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Do not
	perform check if the current scope does not come from source,
	as is the case for a rewritten task body, because check has
	been performed already, and may not be doable because of changed
	visibility.

From-SVN: r247309
parent f138ea5c
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com> 2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch8.adb (Find_Direct_Name): Account for the case where
a use-visible entity is defined within a nested scope of an
instance when giving priority to entities which were visible in
the original generic.
* sem_util.ads, sem_util.adb (Nearest_Enclosing_Instance): New routine.
2017-04-27 Tristan Gingold <gingold@adacore.com>
* raise-gcc.c: Don't use unwind.h while compiling
for the frontend, but mimic host behavior.
2017-04-27 Javier Miranda <miranda@adacore.com>
* sem_ch3.adb (Build_Discriminated_Subtype):
Propagate Has_Pragma_Unreferenced_Objects to the built subtype.
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Global_Item):
Do not consider discriminants because they are not "entire
objects". Remove the discriminant-related checks because they are
obsolete.
(Analyze_Input_Output): Do not consider discriminants
because they are not "entire objects".
2017-04-27 Ed Schonberg <schonberg@adacore.com>
* sem_ch13.adb (Check_Aspect_At_End_Of_Declarations): Do not
perform check if the current scope does not come from source,
as is the case for a rewritten task body, because check has
been performed already, and may not be doable because of changed
visibility.
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* a-cofuse.adb, a-cfdlli.adb, a-cofuse.ads, a-cfdlli.ads, a-cofuve.adb, * a-cofuse.adb, a-cfdlli.adb, a-cofuse.ads, a-cfdlli.ads, a-cofuve.adb,
a-cofuve.ads, a-cofuma.adb, a-cofuma.ads, sem_eval.adb, a-cofuba.adb: a-cofuve.ads, a-cofuma.adb, a-cofuma.ads, sem_eval.adb, a-cofuba.adb:
Minor reformatting. Minor reformatting.
......
...@@ -32,12 +32,20 @@ ...@@ -32,12 +32,20 @@
/* Code related to the integration of the GCC mechanism for exception /* Code related to the integration of the GCC mechanism for exception
handling. */ handling. */
#ifndef CERT #ifndef IN_RTS
#include "tconfig.h" /* For gnat1/gnatbind compilation: use host headers. */
#include "tsystem.h" # include "config.h"
# include "system.h"
/* Don't use fancy_abort. */
# undef abort
#else #else
#define ATTRIBUTE_UNUSED __attribute__((unused)) # ifndef CERT
#define HAVE_GETIPINFO 1 # include "tconfig.h"
# include "tsystem.h"
# else
# define ATTRIBUTE_UNUSED __attribute__((unused))
# define HAVE_GETIPINFO 1
# endif
#endif #endif
#include <stdarg.h> #include <stdarg.h>
...@@ -71,7 +79,19 @@ typedef char bool; ...@@ -71,7 +79,19 @@ typedef char bool;
(SJLJ or DWARF). We need a consistently named interface to import from (SJLJ or DWARF). We need a consistently named interface to import from
a-except, so wrappers are defined here. */ a-except, so wrappers are defined here. */
#include "unwind.h" #ifndef IN_RTS
/* For gnat1/gnatbind compilation: cannot use unwind.h, as it is for the
target. So mimic configure...
This is a hack ???, the real fix is to link gnat1/gnatbind with the
runtime of the build compiler. */
# ifdef EH_MECHANISM_arm
# include "config/arm/unwind-arm.h"
# else
# include "unwind-generic.h"
# endif
#else
# include "unwind.h"
#endif
#ifdef __cplusplus #ifdef __cplusplus
extern "C" { extern "C" {
...@@ -98,6 +118,11 @@ extern void __gnat_raise_abort (void) __attribute__ ((noreturn)); ...@@ -98,6 +118,11 @@ extern void __gnat_raise_abort (void) __attribute__ ((noreturn));
#include "unwind-pe.h" #include "unwind-pe.h"
#ifdef __ARM_EABI_UNWINDER__
/* for memcmp */
#include <string.h>
#endif
/* The known and handled exception classes. */ /* The known and handled exception classes. */
#ifdef __ARM_EABI_UNWINDER__ #ifdef __ARM_EABI_UNWINDER__
......
...@@ -9083,6 +9083,14 @@ package body Sem_Ch13 is ...@@ -9083,6 +9083,14 @@ package body Sem_Ch13 is
if In_Instance then if In_Instance then
return; return;
-- The enclosing scope may have been rewritten during expansion (.e.g.
-- a task body is rewritten as a procedure) after this conformance check
-- has been performed, so do not perform it again (it may not easily
-- be done if full visibility of local entities is not available).
elsif not Comes_From_Source (Current_Scope) then
return;
-- Case of aspects Dimension, Dimension_System and Synchronization -- Case of aspects Dimension, Dimension_System and Synchronization
elsif A_Id = Aspect_Synchronization then elsif A_Id = Aspect_Synchronization then
......
...@@ -9931,6 +9931,8 @@ package body Sem_Ch3 is ...@@ -9931,6 +9931,8 @@ package body Sem_Ch3 is
Set_Last_Entity (Def_Id, Last_Entity (T)); Set_Last_Entity (Def_Id, Last_Entity (T));
Set_Has_Implicit_Dereference Set_Has_Implicit_Dereference
(Def_Id, Has_Implicit_Dereference (T)); (Def_Id, Has_Implicit_Dereference (T));
Set_Has_Pragma_Unreferenced_Objects
(Def_Id, Has_Pragma_Unreferenced_Objects (T));
-- If the subtype is the completion of a private declaration, there may -- If the subtype is the completion of a private declaration, there may
-- have been representation clauses for the partial view, and they must -- have been representation clauses for the partial view, and they must
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2016, 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -4764,16 +4764,16 @@ package body Sem_Ch8 is ...@@ -4764,16 +4764,16 @@ package body Sem_Ch8 is
---------------------- ----------------------
procedure Find_Direct_Name (N : Node_Id) is procedure Find_Direct_Name (N : Node_Id) is
E : Entity_Id; E : Entity_Id;
E2 : Entity_Id; E2 : Entity_Id;
Msg : Boolean; Msg : Boolean;
Inst : Entity_Id := Empty;
-- Enclosing instance, if any
Homonyms : Entity_Id; Homonyms : Entity_Id;
-- Saves start of homonym chain -- Saves start of homonym chain
Inst : Entity_Id := Empty;
-- Enclosing instance, if any
Nvis_Entity : Boolean; Nvis_Entity : Boolean;
-- Set True to indicate that there is at least one entity on the homonym -- Set True to indicate that there is at least one entity on the homonym
-- chain which, while not visible, is visible enough from the user point -- chain which, while not visible, is visible enough from the user point
...@@ -4835,8 +4835,6 @@ package body Sem_Ch8 is ...@@ -4835,8 +4835,6 @@ package body Sem_Ch8 is
Scop : constant Entity_Id := Scope (E); Scop : constant Entity_Id := Scope (E);
-- Declared scope of candidate entity -- Declared scope of candidate entity
Act : Entity_Id;
function Declared_In_Actual (Pack : Entity_Id) return Boolean; function Declared_In_Actual (Pack : Entity_Id) return Boolean;
-- Recursive function that does the work and examines actuals of -- Recursive function that does the work and examines actuals of
-- actual packages of current instance. -- actual packages of current instance.
...@@ -4858,7 +4856,7 @@ package body Sem_Ch8 is ...@@ -4858,7 +4856,7 @@ package body Sem_Ch8 is
if Renamed_Object (Pack) = Scop then if Renamed_Object (Pack) = Scop then
return True; return True;
-- Check for end of list of actuals. -- Check for end of list of actuals
elsif Ekind (Act) = E_Package elsif Ekind (Act) = E_Package
and then Renamed_Object (Act) = Pack and then Renamed_Object (Act) = Pack
...@@ -4878,6 +4876,10 @@ package body Sem_Ch8 is ...@@ -4878,6 +4876,10 @@ package body Sem_Ch8 is
end if; end if;
end Declared_In_Actual; end Declared_In_Actual;
-- Local variables
Act : Entity_Id;
-- Start of processing for From_Actual_Package -- Start of processing for From_Actual_Package
begin begin
...@@ -5331,6 +5333,11 @@ package body Sem_Ch8 is ...@@ -5331,6 +5333,11 @@ package body Sem_Ch8 is
Msg := True; Msg := True;
end Undefined; end Undefined;
-- Local variables
Nested_Inst : Entity_Id := Empty;
-- The entity of a nested instance which appears within Inst (if any)
-- Start of processing for Find_Direct_Name -- Start of processing for Find_Direct_Name
begin begin
...@@ -5497,15 +5504,17 @@ package body Sem_Ch8 is ...@@ -5497,15 +5504,17 @@ package body Sem_Ch8 is
-- If there is more than one potentially use-visible entity and at -- If there is more than one potentially use-visible entity and at
-- least one of them non-overloadable, we have an error (RM 8.4(11)). -- least one of them non-overloadable, we have an error (RM 8.4(11)).
-- Note that E points to the first such entity on the homonym list. -- Note that E points to the first such entity on the homonym list.
-- Special case: if one of the entities is declared in an actual
-- package, it was visible in the generic, and takes precedence over
-- other entities that are potentially use-visible. Same if it is
-- declared in a local instantiation of the current instance.
else else
-- If one of the entities is declared in an actual package, it
-- was visible in the generic, and takes precedence over other
-- entities that are potentially use-visible. The same applies
-- if the entity is declared in a local instantiation of the
-- current instance.
if In_Instance then if In_Instance then
-- Find current instance -- Find the current instance
Inst := Current_Scope; Inst := Current_Scope;
while Present (Inst) and then Inst /= Standard_Standard loop while Present (Inst) and then Inst /= Standard_Standard loop
...@@ -5516,12 +5525,21 @@ package body Sem_Ch8 is ...@@ -5516,12 +5525,21 @@ package body Sem_Ch8 is
Inst := Scope (Inst); Inst := Scope (Inst);
end loop; end loop;
-- Reexamine the candidate entities, giving priority to those
-- that were visible within the generic.
E2 := E; E2 := E;
while Present (E2) loop while Present (E2) loop
Nested_Inst := Nearest_Enclosing_Instance (E2);
-- The entity is declared within an actual package, or in a
-- nested instance. The ">=" accounts for the case where the
-- current instance and the nested instance are the same.
if From_Actual_Package (E2) if From_Actual_Package (E2)
or else or else (Present (Nested_Inst)
(Is_Generic_Instance (Scope (E2)) and then Scope_Depth (Nested_Inst) >=
and then Scope_Depth (Scope (E2)) > Scope_Depth (Inst)) Scope_Depth (Inst))
then then
E := E2; E := E2;
goto Found; goto Found;
...@@ -5533,8 +5551,7 @@ package body Sem_Ch8 is ...@@ -5533,8 +5551,7 @@ package body Sem_Ch8 is
Nvis_Messages; Nvis_Messages;
goto Done; goto Done;
elsif elsif Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
Is_Predefined_File_Name (Unit_File_Name (Current_Sem_Unit))
then then
-- A use-clause in the body of a system file creates conflict -- A use-clause in the body of a system file creates conflict
-- with some entity in a user scope, while rtsfind is active. -- with some entity in a user scope, while rtsfind is active.
...@@ -5543,7 +5560,7 @@ package body Sem_Ch8 is ...@@ -5543,7 +5560,7 @@ package body Sem_Ch8 is
E2 := E; E2 := E;
while Present (E2) loop while Present (E2) loop
if Is_Predefined_File_Name if Is_Predefined_File_Name
(Unit_File_Name (Get_Source_Unit (Sloc (E2)))) (Unit_File_Name (Get_Source_Unit (Sloc (E2))))
then then
E := E2; E := E2;
goto Found; goto Found;
......
...@@ -928,9 +928,7 @@ package body Sem_Prag is ...@@ -928,9 +928,7 @@ package body Sem_Prag is
-- Constants -- Constants
if Ekind_In (Item_Id, E_Constant, if Ekind_In (Item_Id, E_Constant, E_Loop_Parameter)
E_Discriminant,
E_Loop_Parameter)
or else or else
-- Current instances of concurrent types -- Current instances of concurrent types
...@@ -2216,7 +2214,6 @@ package body Sem_Prag is ...@@ -2216,7 +2214,6 @@ package body Sem_Prag is
elsif not Ekind_In (Item_Id, E_Abstract_State, elsif not Ekind_In (Item_Id, E_Abstract_State,
E_Constant, E_Constant,
E_Discriminant,
E_Loop_Parameter, E_Loop_Parameter,
E_Variable) E_Variable)
then then
...@@ -2287,19 +2284,6 @@ package body Sem_Prag is ...@@ -2287,19 +2284,6 @@ package body Sem_Prag is
return; return;
end if; end if;
-- Discriminant related checks
elsif Ekind (Item_Id) = E_Discriminant then
-- A discriminant is a read-only item, therefore it cannot
-- act as an output.
if Nam_In (Global_Mode, Name_In_Out, Name_Output) then
SPARK_Msg_NE
("discriminant & cannot act as output", Item, Item_Id);
return;
end if;
-- Loop parameter related checks -- Loop parameter related checks
elsif Ekind (Item_Id) = E_Loop_Parameter then elsif Ekind (Item_Id) = E_Loop_Parameter then
...@@ -16750,6 +16750,26 @@ package body Sem_Util is ...@@ -16750,6 +16750,26 @@ package body Sem_Util is
Mark_Allocators (Root_Nod); Mark_Allocators (Root_Nod);
end Mark_Coextensions; end Mark_Coextensions;
--------------------------------
-- Nearest_Enclosing_Instance --
--------------------------------
function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id is
Inst : Entity_Id;
begin
Inst := Scope (E);
while Present (Inst) and then Inst /= Standard_Standard loop
if Is_Generic_Instance (Inst) then
return Inst;
end if;
Inst := Scope (Inst);
end loop;
return Empty;
end Nearest_Enclosing_Instance;
---------------------- ----------------------
-- Needs_One_Actual -- -- Needs_One_Actual --
---------------------- ----------------------
......
...@@ -1941,6 +1941,10 @@ package Sem_Util is ...@@ -1941,6 +1941,10 @@ package Sem_Util is
-- to guarantee this in all cases. Note that it is more possible to give -- to guarantee this in all cases. Note that it is more possible to give
-- correct answer if the tree is fully analyzed. -- correct answer if the tree is fully analyzed.
function Nearest_Enclosing_Instance (E : Entity_Id) return Entity_Id;
-- Return the entity of the nearest enclosing instance which encapsulates
-- entity E. If no such instance exits, return Empty.
function Needs_One_Actual (E : Entity_Id) return Boolean; function Needs_One_Actual (E : Entity_Id) return Boolean;
-- Returns True if a function has defaults for all but its first -- Returns True if a function has defaults for all but its first
-- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that -- formal. Used in Ada 2005 mode to solve the syntactic ambiguity that
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment