Commit caa64a44 by Arnaud Charlet

[multiple changes]

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

	* sem_prag.adb (Process_Atomic_Independent_Shared_Volatile): Code
	cleanup. Check the original node when trying to determine the node kind
	of pragma Volatile's argument to account for untagged derivations
	where the type is transformed into a constrained subtype.

2016-04-27  Olivier Hainque  <hainque@adacore.com>

	* mkdir.c (__gnat_mkdir): Rework the vxworks section to use a
	consistent posix interface on the caller side.

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

	* sem_ch10.adb (Build_Limited_View, Decorate_Type): If this
	is a limited view of a type, initialize the Limited_Dependents
	field to catch misuses of the type in a client unit.

2016-04-27  Thomas Quinot  <quinot@adacore.com>

	* a-strunb-shared.adb (Finalize): add missing Reference call.
	* s-strhas.adb: minor grammar fix and extension of comment
	* sem_ch8.adb: minor whitespace fixes

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

	* lib-xref.adb (Get_Type_Reference): Handle properly the case
	of an object declaration whose type definition is a class-wide
	subtype and whose expression is a function call that returns a
	classwide type.

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

	* sem_util.ads, sem_util.adb (Output_Entity): New routine.
	(Output_Name): New routine.

2016-04-27  Bob Duff  <duff@adacore.com>

	* exp_ch3.adb (Rewrite_As_Renaming): Disable previous change for now.

From-SVN: r235495
parent a6ac7311
2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Process_Atomic_Independent_Shared_Volatile): Code
cleanup. Check the original node when trying to determine the node kind
of pragma Volatile's argument to account for untagged derivations
where the type is transformed into a constrained subtype.
2016-04-27 Olivier Hainque <hainque@adacore.com>
* mkdir.c (__gnat_mkdir): Rework the vxworks section to use a
consistent posix interface on the caller side.
2016-04-27 Ed Schonberg <schonberg@adacore.com>
* sem_ch10.adb (Build_Limited_View, Decorate_Type): If this
is a limited view of a type, initialize the Limited_Dependents
field to catch misuses of the type in a client unit.
2016-04-27 Thomas Quinot <quinot@adacore.com>
* a-strunb-shared.adb (Finalize): add missing Reference call.
* s-strhas.adb: minor grammar fix and extension of comment
* sem_ch8.adb: minor whitespace fixes
2016-04-27 Ed Schonberg <schonberg@adacore.com>
* lib-xref.adb (Get_Type_Reference): Handle properly the case
of an object declaration whose type definition is a class-wide
subtype and whose expression is a function call that returns a
classwide type.
2016-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem_util.ads, sem_util.adb (Output_Entity): New routine.
(Output_Name): New routine.
2016-04-27 Bob Duff <duff@adacore.com>
* exp_ch3.adb (Rewrite_As_Renaming): Disable previous change for now.
2016-04-27 Vincent Celier <celier@adacore.com> 2016-04-27 Vincent Celier <celier@adacore.com>
* gnatcmd.adb: For "gnat ls -V -P", recognize switch * gnatcmd.adb: For "gnat ls -V -P", recognize switch
......
...@@ -799,6 +799,7 @@ package body Ada.Strings.Unbounded is ...@@ -799,6 +799,7 @@ package body Ada.Strings.Unbounded is
-- effects if a program references an already-finalized object. -- effects if a program references an already-finalized object.
Object.Reference := Null_Unbounded_String.Reference; Object.Reference := Null_Unbounded_String.Reference;
Reference (Object.Reference);
Unreference (SR); Unreference (SR);
end if; end if;
end Finalize; end Finalize;
......
...@@ -6351,7 +6351,10 @@ package body Exp_Ch3 is ...@@ -6351,7 +6351,10 @@ package body Exp_Ch3 is
-- would otherwise make two copies. The RM allows removing redunant -- would otherwise make two copies. The RM allows removing redunant
-- Adjust/Finalize calls, but does not allow insertion of extra ones. -- Adjust/Finalize calls, but does not allow insertion of extra ones.
return (Nkind (Expr_Q) = N_Explicit_Dereference -- This part is disabled for now, because it breaks GPS builds.
return (False -- ???
and then Nkind (Expr_Q) = N_Explicit_Dereference
and then not Comes_From_Source (Expr_Q) and then not Comes_From_Source (Expr_Q)
and then Nkind (Original_Node (Expr_Q)) = N_Function_Call and then Nkind (Original_Node (Expr_Q)) = N_Function_Call
and then Nkind (Object_Definition (N)) in N_Has_Entity and then Nkind (Object_Definition (N)) in N_Has_Entity
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- Copyright (C) 1998-2016, 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- --
...@@ -1467,17 +1467,23 @@ package body Lib.Xref is ...@@ -1467,17 +1467,23 @@ package body Lib.Xref is
-- initialized with a tag-indeterminate call gets a subtype -- initialized with a tag-indeterminate call gets a subtype
-- of the classwide type during expansion. See if the original -- of the classwide type during expansion. See if the original
-- type in the declaration is named, and return it instead -- type in the declaration is named, and return it instead
-- of going to the root type. -- of going to the root type. The expression may be a class-
-- wide function call whose result is on the secondary stack,
-- which forces the declaration to be rewritten as a renaming,
-- so examine the source declaration.
if Ekind (Tref) = E_Class_Wide_Subtype if Ekind (Tref) = E_Class_Wide_Subtype then
and then Nkind (Parent (Ent)) = N_Object_Declaration declare
and then Decl : constant Node_Id := Original_Node (Parent (Ent));
Nkind (Original_Node (Object_Definition (Parent (Ent)))) begin
= N_Identifier if Nkind (Decl) = N_Object_Declaration
and then Is_Entity_Name
(Original_Node ((Object_Definition (Decl))))
then then
Tref := Tref :=
Entity Entity ((Original_Node ((Object_Definition (Decl)))));
(Original_Node ((Object_Definition (Parent (Ent))))); end if;
end;
end if; end if;
-- For anything else, exit -- For anything else, exit
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * C Implementation File *
* * * *
* Copyright (C) 2002-2014, Free Software Foundation, Inc. * * Copyright (C) 2002-2016, 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- *
...@@ -60,8 +60,18 @@ ...@@ -60,8 +60,18 @@
int int
__gnat_mkdir (char *dir_name, int encoding ATTRIBUTE_UNUSED) __gnat_mkdir (char *dir_name, int encoding ATTRIBUTE_UNUSED)
{ {
#if defined (__vxworks) && !(defined (__RTP__) && ((_WRS_VXWORKS_MAJOR == 7) || (_WRS_VXWORKS_MINOR != 0))) #if defined (__vxworks)
return mkdir (dir_name);
/* Pretend that the system mkdir is posix compliant even though it
sometimes is not, not expecting the second argument in some
configurations (e.g. vxworks 653 2.2, difference from 2.5). The
second actual argument will just be ignored in this case. */
typedef int posix_mkdir (const char * name, mode_t mode);
posix_mkdir * vxmkdir = (posix_mkdir *)&mkdir;
return vxmkdir (dir_name, S_IRWXU | S_IRWXG | S_IRWXO);
#elif defined (__MINGW32__) #elif defined (__MINGW32__)
TCHAR wname [GNAT_MAX_PATH_LEN + 2]; TCHAR wname [GNAT_MAX_PATH_LEN + 2];
......
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- S p e c --
-- -- -- --
-- Copyright (C) 2009-2013, Free Software Foundation, Inc. -- -- Copyright (C) 2009-2016, 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- --
...@@ -33,8 +33,9 @@ pragma Compiler_Unit_Warning; ...@@ -33,8 +33,9 @@ pragma Compiler_Unit_Warning;
package body System.String_Hash is package body System.String_Hash is
-- Compute a hash value for a key. The approach here is follows the -- Compute a hash value for a key. The approach here follows the algorithm
-- algorithm used in GNU Awk and the ndbm substitute SDBM by Ozan Yigit. -- introduced in the ndbm substitute SDBM by Ozan Yigit and then reused in
-- GNU Awk (where they are implemented as a Duff's device).
---------- ----------
-- Hash -- -- Hash --
......
...@@ -84,6 +84,13 @@ package body Sem_Ch10 is ...@@ -84,6 +84,13 @@ package body Sem_Ch10 is
-- required in order to avoid passing non-decorated entities to the -- required in order to avoid passing non-decorated entities to the
-- back-end. Implements Ada 2005 (AI-50217). -- back-end. Implements Ada 2005 (AI-50217).
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
-- Common processing for all stubs (subprograms, tasks, packages, and
-- protected cases). N is the stub to be analyzed. Once the subunit name
-- is established, load and analyze. Nam is the non-overloadable entity
-- for which the proper body provides a completion. Subprogram stubs are
-- handled differently because they can be declarations.
procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id); procedure Check_Body_Needed_For_SAL (Unit_Name : Entity_Id);
-- Check whether the source for the body of a compilation unit must be -- Check whether the source for the body of a compilation unit must be
-- included in a standalone library. -- included in a standalone library.
...@@ -203,13 +210,6 @@ package body Sem_Ch10 is ...@@ -203,13 +210,6 @@ package body Sem_Ch10 is
procedure Unchain (E : Entity_Id); procedure Unchain (E : Entity_Id);
-- Remove single entity from visibility list -- Remove single entity from visibility list
procedure Analyze_Proper_Body (N : Node_Id; Nam : Entity_Id);
-- Common processing for all stubs (subprograms, tasks, packages, and
-- protected cases). N is the stub to be analyzed. Once the subunit name
-- is established, load and analyze. Nam is the non-overloadable entity
-- for which the proper body provides a completion. Subprogram stubs are
-- handled differently because they can be declarations.
procedure sm; procedure sm;
-- A dummy procedure, for debugging use, called just before analyzing the -- A dummy procedure, for debugging use, called just before analyzing the
-- main unit (after dealing with any context clauses). -- main unit (after dealing with any context clauses).
...@@ -1489,7 +1489,7 @@ package body Sem_Ch10 is ...@@ -1489,7 +1489,7 @@ package body Sem_Ch10 is
-- Check if the named package (or some ancestor) -- Check if the named package (or some ancestor)
-- leaves visible the full-view of the unit given -- leaves visible the full-view of the unit given
-- in the limited-with clause -- in the limited-with clause.
loop loop
if Designate_Same_Unit (Lim_Unit_Name, if Designate_Same_Unit (Lim_Unit_Name,
...@@ -5633,7 +5633,7 @@ package body Sem_Ch10 is ...@@ -5633,7 +5633,7 @@ package body Sem_Ch10 is
begin begin
-- An unanalyzed type or a shadow entity of a type is treated as an -- An unanalyzed type or a shadow entity of a type is treated as an
-- incomplete type. -- incomplete type, and carries the corresponding attributes.
Set_Ekind (Ent, E_Incomplete_Type); Set_Ekind (Ent, E_Incomplete_Type);
Set_Etype (Ent, Ent); Set_Etype (Ent, Ent);
...@@ -5643,6 +5643,10 @@ package body Sem_Ch10 is ...@@ -5643,6 +5643,10 @@ package body Sem_Ch10 is
Set_Stored_Constraint (Ent, No_Elist); Set_Stored_Constraint (Ent, No_Elist);
Init_Size_Align (Ent); Init_Size_Align (Ent);
if From_Limited_With (Ent) then
Set_Private_Dependents (Ent, New_Elmt_List);
end if;
-- A tagged type and its corresponding shadow entity share one common -- A tagged type and its corresponding shadow entity share one common
-- class-wide type. The list of primitive operations for the shadow -- class-wide type. The list of primitive operations for the shadow
-- entity is empty. -- entity is empty.
......
...@@ -6467,11 +6467,6 @@ package body Sem_Prag is ...@@ -6467,11 +6467,6 @@ package body Sem_Prag is
------------------------------------------------ ------------------------------------------------
procedure Process_Atomic_Independent_Shared_Volatile is procedure Process_Atomic_Independent_Shared_Volatile is
D : Node_Id;
E : Entity_Id;
E_Id : Node_Id;
K : Node_Kind;
procedure Set_Atomic_VFA (E : Entity_Id); procedure Set_Atomic_VFA (E : Entity_Id);
-- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
-- no explicit alignment was given, set alignment to unknown, since -- no explicit alignment was given, set alignment to unknown, since
...@@ -6495,6 +6490,12 @@ package body Sem_Prag is ...@@ -6495,6 +6490,12 @@ package body Sem_Prag is
end if; end if;
end Set_Atomic_VFA; end Set_Atomic_VFA;
-- Local variables
Decl : Node_Id;
E : Entity_Id;
E_Arg : Node_Id;
-- Start of processing for Process_Atomic_Independent_Shared_Volatile -- Start of processing for Process_Atomic_Independent_Shared_Volatile
begin begin
...@@ -6502,15 +6503,14 @@ package body Sem_Prag is ...@@ -6502,15 +6503,14 @@ package body Sem_Prag is
Check_No_Identifiers; Check_No_Identifiers;
Check_Arg_Count (1); Check_Arg_Count (1);
Check_Arg_Is_Local_Name (Arg1); Check_Arg_Is_Local_Name (Arg1);
E_Id := Get_Pragma_Arg (Arg1); E_Arg := Get_Pragma_Arg (Arg1);
if Etype (E_Id) = Any_Type then if Etype (E_Arg) = Any_Type then
return; return;
end if; end if;
E := Entity (E_Id); E := Entity (E_Arg);
D := Declaration_Node (E); Decl := Declaration_Node (E);
K := Nkind (D);
-- A pragma that applies to a Ghost entity becomes Ghost for the -- A pragma that applies to a Ghost entity becomes Ghost for the
-- purposes of legality checks and removal of ignored Ghost code. -- purposes of legality checks and removal of ignored Ghost code.
...@@ -6619,8 +6619,8 @@ package body Sem_Prag is ...@@ -6619,8 +6619,8 @@ package body Sem_Prag is
Set_Treat_As_Volatile (Underlying_Type (E)); Set_Treat_As_Volatile (Underlying_Type (E));
end if; end if;
elsif K = N_Object_Declaration elsif Nkind (Decl) = N_Object_Declaration
or else (K = N_Component_Declaration or else (Nkind (Decl) = N_Component_Declaration
and then Original_Record_Component (E) = E) and then Original_Record_Component (E) = E)
then then
if Rep_Item_Too_Late (E, N) then if Rep_Item_Too_Late (E, N) then
...@@ -6674,11 +6674,14 @@ package body Sem_Prag is ...@@ -6674,11 +6674,14 @@ package body Sem_Prag is
-- The following check is only relevant when SPARK_Mode is on as -- The following check is only relevant when SPARK_Mode is on as
-- this is not a standard Ada legality rule. Pragma Volatile can -- this is not a standard Ada legality rule. Pragma Volatile can
-- only apply to a full type declaration or an object declaration -- only apply to a full type declaration or an object declaration
-- (SPARK RM C.6(1)). -- (SPARK RM C.6(1)). Original_Node is necessary to account for
-- untagged derived types that are rewritten as subtypes of their
-- respective root types.
if SPARK_Mode = On if SPARK_Mode = On
and then Prag_Id = Pragma_Volatile and then Prag_Id = Pragma_Volatile
and then not Nkind_In (K, N_Full_Type_Declaration, and then
not Nkind_In (Original_Node (Decl), N_Full_Type_Declaration,
N_Object_Declaration) N_Object_Declaration)
then then
Error_Pragma_Arg Error_Pragma_Arg
......
...@@ -17708,6 +17708,67 @@ package body Sem_Util is ...@@ -17708,6 +17708,67 @@ package body Sem_Util is
end if; end if;
end Original_Corresponding_Operation; end Original_Corresponding_Operation;
-------------------
-- Output_Entity --
-------------------
procedure Output_Entity (Id : Entity_Id) is
Scop : Entity_Id;
begin
Scop := Scope (Id);
-- The entity may lack a scope when it is in the process of being
-- analyzed. Use the current scope as an approximation.
if No (Scop) then
Scop := Current_Scope;
end if;
Output_Name (Chars (Id), Scop);
end Output_Entity;
-----------------
-- Output_Name --
-----------------
procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope) is
procedure Output_Scope (S : Entity_Id);
-- Add the fully qualified form of scope S to the name buffer. The
-- qualification format is:
-- scope1__scopeN__
------------------
-- Output_Scope --
------------------
procedure Output_Scope (S : Entity_Id) is
begin
if S = Empty then
null;
elsif S = Standard_Standard then
null;
else
Output_Scope (Scope (S));
Add_Str_To_Name_Buffer (Get_Name_String (Chars (S)));
Add_Str_To_Name_Buffer ("__");
end if;
end Output_Scope;
-- Start of processing for Output_Name
begin
Name_Len := 0;
Output_Scope (Scop);
Add_Str_To_Name_Buffer (Get_Name_String (Nam));
Write_Str (Name_Buffer (1 .. Name_Len));
Write_Eol;
end Output_Name;
---------------------- ----------------------
-- Policy_In_Effect -- -- Policy_In_Effect --
---------------------- ----------------------
......
...@@ -1933,6 +1933,22 @@ package Sem_Util is ...@@ -1933,6 +1933,22 @@ package Sem_Util is
-- corresponding operation of S is the original corresponding operation of -- corresponding operation of S is the original corresponding operation of
-- S2. Otherwise, it is S itself. -- S2. Otherwise, it is S itself.
procedure Output_Entity (Id : Entity_Id);
-- Print entity Id to standard output. The name of the entity appears in
-- fully qualified form.
--
-- WARNING: this routine should be used in debugging scenarios such as
-- tracking down undefined symbols as it is fairly low level.
procedure Output_Name (Nam : Name_Id; Scop : Entity_Id := Current_Scope);
-- Print name Nam to standard output. The name appears in fully qualified
-- form assuming it appears in scope Scop. Note that this may not reflect
-- the final qualification as the entity which carries the name may be
-- relocated to a different scope.
--
-- WARNING: this routine should be used in debugging scenarios such as
-- tracking down undefined symbols as it is fairly low level.
function Policy_In_Effect (Policy : Name_Id) return Name_Id; function Policy_In_Effect (Policy : Name_Id) return Name_Id;
-- Given a policy, return the policy identifier associated with it. If no -- Given a policy, return the policy identifier associated with it. If no
-- such policy is in effect, the value returned is No_Name. -- such policy is in effect, the value returned is No_Name.
......
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