mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-03-24 04:10:29 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

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

	* sem.adb (Analyze): Diagnose an illegal iterated component
	association.
	* sem_util.ads, sem_util.adb
	(Diagnose_Iterated_Component_Association): New routine.

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

	* adaint.c (__gnat_get_current_dir): Return 0 in length if
	getcwd fails.
	* a-direct.adb, g-dirope.adb, osint.adb, s-os_lib.adb: Raise
	exception if getcwd failed.

2017-04-27  Yannick Moy  <moy@adacore.com>

	* exp_dbug.adb, exp_dbug.ads (Get_External_Name): Prefix ghost
	entities with special prefix.

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

	* debug.adb Change the documentation of switch -gnatd.s.
	* exp_ch7.adb (Make_Transient_Block): Transient blocks do not need
	to manage the secondary stack when an enclosing scope already
	performs this functionality (aka relaxed management). Switch
	-gnatd.s may be used to force strict management in which case
	the block will manage the secondary stack unconditionally. Add
	a guard to stop the traversal when encountering a package or a
	subprogram scope.

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

	* sem_res.adb (Resolve_Call): Refine further the handling of
	limited views of return types in function calls. If the function
	that returns a limited view appears in the current unit,
	we do not replace its type by the non-limited view because
	this transformation is performed int the back-end. However,
	the type of the call itself must be the non-limited view, to
	prevent spurious resolution errors.

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

	* einfo,ads, einfo.adb (Class_Wide_Preconds, Class_Wide_Postconds):
	Removed, proposed implementation using generics for class-wide
	preconditions proved impractical.
	(Class_Wide_Clone): New attribute of subprogram. Designates
	subprogram created for primitive operations with class-wide
	pre/postconditions that contain calls to other primitives. The
	clone holds the body of the original primitive, but the
	pre/postonditions do not apply to it. The original body is
	rewritten as a wrapper for a call to the clone.
	(Is_Class_Wide_Clone): New flag to identify a Class_Wide_Clone. If
	the flag is set, no code for the corresponding pre/postconditions
	is inserted into its body.

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

	* exp_prag.adb, par-prag.adb, sem_ch13.adb: Ignore
	Scalar_Storage_Order if -gnatI is given.
	* sem_prag.adb (Analyze_Pragma): Ignore
	Default_Scalar_Storage_Order if -gnatI is given.

From-SVN: r247298
This commit is contained in:
Arnaud Charlet 2017-04-27 11:22:04 +02:00
parent 394fa9f54a
commit 7a71a7c4bb
20 changed files with 322 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
gcc/ada/ChangeLog
View File

@ -1,3 +1,65 @@
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* sem.adb (Analyze): Diagnose an illegal iterated component
association.
* sem_util.ads, sem_util.adb
(Diagnose_Iterated_Component_Association): New routine.
2017-04-27 Bob Duff <duff@adacore.com>
* adaint.c (__gnat_get_current_dir): Return 0 in length if
getcwd fails.
* a-direct.adb, g-dirope.adb, osint.adb, s-os_lib.adb: Raise
exception if getcwd failed.
2017-04-27 Yannick Moy <moy@adacore.com>
* exp_dbug.adb, exp_dbug.ads (Get_External_Name): Prefix ghost
entities with special prefix.
2017-04-27 Hristian Kirtchev <kirtchev@adacore.com>
* debug.adb Change the documentation of switch -gnatd.s.
* exp_ch7.adb (Make_Transient_Block): Transient blocks do not need
to manage the secondary stack when an enclosing scope already
performs this functionality (aka relaxed management). Switch
-gnatd.s may be used to force strict management in which case
the block will manage the secondary stack unconditionally. Add
a guard to stop the traversal when encountering a package or a
subprogram scope.
2017-04-27 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Resolve_Call): Refine further the handling of
limited views of return types in function calls. If the function
that returns a limited view appears in the current unit,
we do not replace its type by the non-limited view because
this transformation is performed int the back-end. However,
the type of the call itself must be the non-limited view, to
prevent spurious resolution errors.
2017-04-27 Ed Schonberg <schonberg@adacore.com>
* einfo,ads, einfo.adb (Class_Wide_Preconds, Class_Wide_Postconds):
Removed, proposed implementation using generics for class-wide
preconditions proved impractical.
(Class_Wide_Clone): New attribute of subprogram. Designates
subprogram created for primitive operations with class-wide
pre/postconditions that contain calls to other primitives. The
clone holds the body of the original primitive, but the
pre/postonditions do not apply to it. The original body is
rewritten as a wrapper for a call to the clone.
(Is_Class_Wide_Clone): New flag to identify a Class_Wide_Clone. If
the flag is set, no code for the corresponding pre/postconditions
is inserted into its body.
2017-04-27 Bob Duff <duff@adacore.com>
* exp_prag.adb, par-prag.adb, sem_ch13.adb: Ignore
Scalar_Storage_Order if -gnatI is given.
* sem_prag.adb (Analyze_Pragma): Ignore
Default_Scalar_Storage_Order if -gnatI is given.
2017-04-27 Claire Dross <dross@adacore.com>
* a-cofuba.ads (Add): Take as an additional input parameter

6
gcc/ada/a-direct.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2016, Free Software Foundation, Inc. --
-- Copyright (C) 2004-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- --
@ -528,6 +528,10 @@ package body Ada.Directories is
begin
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
if Path_Len = 0 then
raise Use_Error with "current directory does not exist";
end if;
-- We need to resolve links because of RM A.16(47), which requires
-- that we not return alternative names for files.

13
gcc/ada/adaint.c
View File

@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
* Copyright (C) 1992-2015, 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- *
@ -613,7 +613,16 @@ __gnat_get_current_dir (char *dir, int *length)
WS2SC (dir, wdir, GNAT_MAX_PATH_LEN);
#else
getcwd (dir, *length);
char* result = getcwd (dir, *length);
/* If the current directory does not exist, set length = 0
to indicate error. That can't happen on windows, where
you can't delete a directory if it is the current
directory of some process. */
if (!result)
{
*length = 0;
return;
}
#endif
*length = strlen (dir);

7
gcc/ada/debug.adb
View File

@ -109,7 +109,7 @@ package body Debug is
-- d.p Use original Ada 95 semantics for Bit_Order (disable AI95-0133)
-- d.q Suppress optimizations on imported 'in'
-- d.r Enable OK_To_Reorder_Components in non-variant records
-- d.s Minimize secondary stack Mark and Release calls
-- d.s Strict secondary stack management
-- d.t Disable static allocation of library level dispatch tables
-- d.u Enable Modify_Tree_For_C (update tree for c)
-- d.v Enable OK_To_Reorder_Components in variant records
@ -572,6 +572,11 @@ package body Debug is
-- d.r Forces the flag OK_To_Reorder_Components to be set in all record
-- base types that have no discriminants.
-- d.s The compiler no longer attempts to optimize the calls to secondary
-- stack management routines SS_Mark and SS_Release. As a result, each
-- transient block tasked with secondary stack management will fulfill
-- its role unconditionally.
-- d.s The compiler does not generate calls to secondary stack management
-- routines SS_Mark and SS_Release for a transient block when there is
-- an enclosing scoping construct which already manages the secondary

55
gcc/ada/einfo.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -272,10 +272,7 @@ package body Einfo is
-- Validated_Object Node36
-- Class_Wide_Preconds List38
-- Class_Wide_Postconds List39
-- Class_Wide_Clone Node38
-- SPARK_Pragma Node40
-- Original_Protected_Subprogram Node41
@ -621,7 +618,7 @@ package body Einfo is
-- Has_Private_Extension Flag300
-- Ignore_SPARK_Mode_Pragmas Flag301
-- (unused) Flag302
-- Is_Class_Wide_Clone Flag302
-- (unused) Flag303
-- (unused) Flag304
-- (unused) Flag305
@ -873,17 +870,11 @@ package body Einfo is
return Flag31 (Id);
end Checks_May_Be_Suppressed;
function Class_Wide_Postconds (Id : E) return S is
function Class_Wide_Clone (Id : E) return E is
begin
pragma Assert (Is_Subprogram (Id));
return List39 (Id);
end Class_Wide_Postconds;
function Class_Wide_Preconds (Id : E) return S is
begin
pragma Assert (Is_Subprogram (Id));
return List38 (Id);
end Class_Wide_Preconds;
return Node38 (Id);
end Class_Wide_Clone;
function Class_Wide_Type (Id : E) return E is
begin
@ -2141,6 +2132,11 @@ package body Einfo is
return Flag73 (Id);
end Is_Child_Unit;
function Is_Class_Wide_Clone (Id : E) return B is
begin
return Flag302 (Id);
end Is_Class_Wide_Clone;
function Is_Class_Wide_Equivalent_Type (Id : E) return B is
begin
return Flag35 (Id);
@ -3958,17 +3954,11 @@ package body Einfo is
Set_Flag31 (Id, V);
end Set_Checks_May_Be_Suppressed;
procedure Set_Class_Wide_Preconds (Id : E; V : S) is
procedure Set_Class_Wide_Clone (Id : E; V : E) is
begin
pragma Assert (Is_Subprogram (Id));
Set_List38 (Id, V);
end Set_Class_Wide_Preconds;
procedure Set_Class_Wide_Postconds (Id : E; V : S) is
begin
pragma Assert (Is_Subprogram (Id));
Set_List39 (Id, V);
end Set_Class_Wide_Postconds;
Set_Node38 (Id, V);
end Set_Class_Wide_Clone;
procedure Set_Class_Wide_Type (Id : E; V : E) is
begin
@ -5266,6 +5256,11 @@ package body Einfo is
Set_Flag73 (Id, V);
end Set_Is_Child_Unit;
procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True) is
begin
Set_Flag302 (Id, V);
end Set_Is_Class_Wide_Clone;
procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True) is
begin
Set_Flag35 (Id, V);
@ -10982,11 +10977,8 @@ package body Einfo is
procedure Write_Field38_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Function
| E_Procedure
=>
Write_Str ("Class_Wide_Preconditions");
when E_Function | E_Procedure =>
Write_Str ("class-wide clone");
when others =>
Write_Str ("Field38??");
end case;
@ -10999,11 +10991,6 @@ package body Einfo is
procedure Write_Field39_Name (Id : Entity_Id) is
begin
case Ekind (Id) is
when E_Function
| E_Procedure
=>
Write_Str ("Class_Wide_Postcondition");
when others =>
Write_Str ("Field39??");
end case;

44
gcc/ada/einfo.ads
View File

@ -625,16 +625,12 @@ package Einfo is
-- tables must be consulted to determine if there actually is an active
-- Suppress or Unsuppress pragma that applies to the entity.
-- Class_Wide_Preconds (List38)
-- Defined on subprograms. Holds the list of class-wide precondition
-- functions inherited from ancestors. Each such function is an
-- instantiation of the generic function generated from an explicit
-- aspect specification for a class-wide precondition. A type is an
-- ancestor of itself, and therefore a root type has such an instance
-- on its own list.
-- Class_Wide_Postconds (List39)
-- Ditto for class-wide postconditions.
-- Class_Wide_Clone (Node38)
-- Defined on subprogram entities. Set if the subprogram has a class-wide
-- ore- or postcondition, and the expression contains calls to other
-- primitive funtions of the type. Used to implement properly the
-- semantics of inherited operations whose class-wide condition may
-- be different from that of the ancestor (See AI012-0195).
-- Class_Wide_Type (Node9)
-- Defined in all type entities. For a tagged type or subtype, returns
@ -2360,6 +2356,12 @@ package Einfo is
-- Defined in all entities. Set only for defining entities of program
-- units that are child units (but False for subunits).
-- Is_Class_Wide_Clone (Flag302)
-- Defined on subprogram entities. Set for subprograms built in order
-- to implement properly the inheritance of class-wide pre- or post-
-- conditions when the condition contains calls to other primitives
-- of the ancestor type. Used to implement AI12-0195.
-- Is_Class_Wide_Equivalent_Type (Flag35)
-- Defined in record types and subtypes. Set to True, if the type acts
-- as a class-wide equivalent type, i.e. the Equivalent_Type field of
@ -6045,8 +6047,7 @@ package Einfo is
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- Class_Wide_Clone (Node38)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
@ -6362,8 +6363,7 @@ package Einfo is
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Import_Pragma (Node35) (non-generic case only)
-- Class_Wide_Preconds (List38)
-- Class_Wide_Postconds (List39)
-- Class_Wide_Clone (Node38)
-- SPARK_Pragma (Node40)
-- Original_Protected_Subprogram (Node41)
-- Body_Needed_For_SAL (Flag40)
@ -6926,8 +6926,7 @@ package Einfo is
function Can_Never_Be_Null (Id : E) return B;
function Can_Use_Internal_Rep (Id : E) return B;
function Checks_May_Be_Suppressed (Id : E) return B;
function Class_Wide_Postconds (Id : E) return S;
function Class_Wide_Preconds (Id : E) return S;
function Class_Wide_Clone (Id : E) return E;
function Class_Wide_Type (Id : E) return E;
function Cloned_Subtype (Id : E) return E;
function Component_Alignment (Id : E) return C;
@ -7143,6 +7142,7 @@ package Einfo is
function Is_Character_Type (Id : E) return B;
function Is_Checked_Ghost_Entity (Id : E) return B;
function Is_Child_Unit (Id : E) return B;
function Is_Class_Wide_Clone (Id : E) return B;
function Is_Class_Wide_Equivalent_Type (Id : E) return B;
function Is_Compilation_Unit (Id : E) return B;
function Is_Completely_Hidden (Id : E) return B;
@ -7615,8 +7615,7 @@ package Einfo is
procedure Set_Can_Never_Be_Null (Id : E; V : B := True);
procedure Set_Can_Use_Internal_Rep (Id : E; V : B := True);
procedure Set_Checks_May_Be_Suppressed (Id : E; V : B := True);
procedure Set_Class_Wide_Postconds (Id : E; V : S);
procedure Set_Class_Wide_Preconds (Id : E; V : S);
procedure Set_Class_Wide_Clone (Id : E; V : E);
procedure Set_Class_Wide_Type (Id : E; V : E);
procedure Set_Cloned_Subtype (Id : E; V : E);
procedure Set_Component_Alignment (Id : E; V : C);
@ -7828,6 +7827,7 @@ package Einfo is
procedure Set_Is_Character_Type (Id : E; V : B := True);
procedure Set_Is_Checked_Ghost_Entity (Id : E; V : B := True);
procedure Set_Is_Child_Unit (Id : E; V : B := True);
procedure Set_Is_Class_Wide_Clone (Id : E; V : B := True);
procedure Set_Is_Class_Wide_Equivalent_Type (Id : E; V : B := True);
procedure Set_Is_Compilation_Unit (Id : E; V : B := True);
procedure Set_Is_Completely_Hidden (Id : E; V : B := True);
@ -8421,8 +8421,7 @@ package Einfo is
pragma Inline (Can_Never_Be_Null);
pragma Inline (Can_Use_Internal_Rep);
pragma Inline (Checks_May_Be_Suppressed);
pragma Inline (Class_Wide_Preconds);
pragma Inline (Class_Wide_Postconds);
pragma Inline (Class_Wide_Clone);
pragma Inline (Class_Wide_Type);
pragma Inline (Cloned_Subtype);
pragma Inline (Component_Bit_Offset);
@ -8634,6 +8633,7 @@ package Einfo is
pragma Inline (Is_Character_Type);
pragma Inline (Is_Checked_Ghost_Entity);
pragma Inline (Is_Child_Unit);
pragma Inline (Is_Class_Wide_Clone);
pragma Inline (Is_Class_Wide_Equivalent_Type);
pragma Inline (Is_Class_Wide_Type);
pragma Inline (Is_Compilation_Unit);
@ -8946,8 +8946,7 @@ package Einfo is
pragma Inline (Set_Can_Never_Be_Null);
pragma Inline (Set_Can_Use_Internal_Rep);
pragma Inline (Set_Checks_May_Be_Suppressed);
pragma Inline (Set_Class_Wide_Postconds);
pragma Inline (Set_Class_Wide_Preconds);
pragma Inline (Set_Class_Wide_Clone);
pragma Inline (Set_Class_Wide_Type);
pragma Inline (Set_Cloned_Subtype);
pragma Inline (Set_Component_Bit_Offset);
@ -9150,6 +9149,7 @@ package Einfo is
pragma Inline (Set_Is_Character_Type);
pragma Inline (Set_Is_Checked_Ghost_Entity);
pragma Inline (Set_Is_Child_Unit);
pragma Inline (Set_Is_Class_Wide_Clone);
pragma Inline (Set_Is_Class_Wide_Equivalent_Type);
pragma Inline (Set_Is_Compilation_Unit);
pragma Inline (Set_Is_Completely_Hidden);

78
gcc/ada/exp_ch7.adb
View File

@ -8275,31 +8275,27 @@ package body Exp_Ch7 is
function Manages_Sec_Stack (Id : Entity_Id) return Boolean is
begin
-- An exception handler with a choice parameter utilizes a dummy
-- block to provide a declarative region. Such a block should not be
-- considered because it never manifests in the tree and can never
-- release the secondary stack.
case Ekind (Id) is
if Ekind (Id) = E_Block
and then Uses_Sec_Stack (Id)
and then not Is_Exception_Handler (Id)
then
return True;
-- An exception handler with a choice parameter utilizes a dummy
-- block to provide a declarative region. Such a block should not
-- be considered because it never manifests in the tree and can
-- never release the secondary stack.
-- Loops are intentionally excluded because they undergo special
-- treatment, see Establish_Transient_Scope.
when E_Block =>
return
Uses_Sec_Stack (Id) and then not Is_Exception_Handler (Id);
elsif Ekind_In (Id, E_Entry,
E_Entry_Family,
E_Function,
E_Procedure)
and then Uses_Sec_Stack (Id)
then
return True;
when E_Entry
| E_Entry_Family
| E_Function
| E_Procedure
=>
return Uses_Sec_Stack (Id);
else
return False;
end if;
when others =>
return False;
end case;
end Manages_Sec_Stack;
-- Local variables
@ -8326,16 +8322,13 @@ package body Exp_Ch7 is
Scop := Scope (Trans_Id);
while Present (Scop) loop
-- It should not be possible to reach Standard without hitting one
-- of the other cases first unless Standard was manually pushed.
if Scop = Standard_Standard then
exit;
-- The transient block must manage the secondary stack when the
-- block appears within a loop in order to reclaim the memory at
-- each iteration.
elsif Ekind (Scop) = E_Loop then
exit;
-- The transient block is within a function which returns on the
-- secondary stack. Take a conservative approach and assume that
-- the value on the secondary stack is part of the result. Note
@ -8351,15 +8344,36 @@ package body Exp_Ch7 is
Set_Uses_Sec_Stack (Trans_Id, False);
exit;
-- When requested, the transient block does not need to manage the
-- secondary stack when there exists an enclosing block, entry,
-- entry family, function, or a procedure which already does that.
-- The transient block must manage the secondary stack when the
-- block appears within a loop in order to reclaim the memory at
-- each iteration.
elsif Ekind (Scop) = E_Loop then
exit;
-- The transient block does not need to manage the secondary stack
-- when there is an enclosing construct which already does that.
-- This optimization saves on SS_Mark and SS_Release calls but may
-- allow objects to live a little longer than required.
elsif Debug_Flag_Dot_S and then Manages_Sec_Stack (Scop) then
-- The transient block must manage the secondary stack when switch
-- -gnatd.s (strict management) is in effect.
elsif Manages_Sec_Stack (Scop) and then not Debug_Flag_Dot_S then
Set_Uses_Sec_Stack (Trans_Id, False);
exit;
-- Prevent the search from going too far because transient blocks
-- are bounded by packages and subprogram scopes.
elsif Ekind_In (Scop, E_Entry,
E_Entry_Family,
E_Function,
E_Package,
E_Procedure,
E_Subprogram_Body)
then
exit;
end if;
Scop := Scope (Scop);

23
gcc/ada/exp_dbug.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
@ -892,6 +892,27 @@ package body Exp_Dbug is
Add_Str_To_Name_Buffer (Suffix);
end if;
-- Add a special prefix to distinguish Ghost entities. In Ignored Ghost
-- mode, these entities should not leak in the "living" space and they
-- should be removed by the compiler in a post-processing pass. Thus,
-- the prefix allows anyone to check that the final executable indeed
-- does not contain such entities, in such a case. Do not insert this
-- prefix for compilation units, whose name is used as a basis for the
-- name of the generated elaboration procedure and (when appropriate)
-- the executable produced. Only insert this prefix once, for Ghost
-- entities declared inside other Ghost entities. Three leading
-- underscores are used so that "___ghost_" is a unique substring of
-- names produced for Ghost entities, while "__ghost_" can appear in
-- names of entities inside a child/local package called "Ghost".
if Is_Ghost_Entity (E)
and then not Is_Compilation_Unit (E)
and then (Name_Len < 9
or else Name_Buffer (1 .. 9) /= "___ghost_")
then
Insert_Str_In_Name_Buffer ("___ghost_", 1);
end if;
Name_Buffer (Name_Len + 1) := ASCII.NUL;
end Get_External_Name;

8
gcc/ada/exp_dbug.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1996-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1996-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- --
@ -76,6 +76,12 @@ package Exp_Dbug is
-- qualification for such entities. In particular this means that direct
-- local variables of a procedure are not qualified.
-- For Ghost entities, the encoding adds a prefix "___ghost_" to aid the
-- detection of leaks of Ignored Ghost entities in the "living" space.
-- Ignored Ghost entities and any code associated with them should be
-- removed by the compiler in a post-processing pass. As a result,
-- object files should not contain any occurrences of this prefix.
-- As an example of the local name convention, consider a procedure V.W
-- with a local variable X, and a nested block Y containing an entity Z.
-- The fully qualified names of the entities X and Z are:

16
gcc/ada/exp_prag.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -162,19 +162,23 @@ package body Exp_Prag is
---------------------
procedure Expand_N_Pragma (N : Node_Id) is
Pname : constant Name_Id := Pragma_Name (N);
Pname : constant Name_Id := Pragma_Name (N);
Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
begin
-- Rewrite pragma ignored by Ignore_Pragma to null statement, so that
-- the back end or the expander here does not get overenthusiastic and
-- start processing such a pragma!
-- the back end doesn't see it. The same goes for pragma
-- Default_Scalar_Storage_Order if the -gnatI switch was given.
if Should_Ignore_Pragma_Sem (N) then
if Should_Ignore_Pragma_Sem (N)
or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
and then Ignore_Rep_Clauses)
then
Rewrite (N, Make_Null_Statement (Sloc (N)));
return;
end if;
case Get_Pragma_Id (Pname) is
case Prag_Id is
-- Pragmas requiring special expander action

8
gcc/ada/g-dirope.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2014, AdaCore --
-- Copyright (C) 1998-2017, AdaCore --
-- --
-- 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- --
@ -29,6 +29,7 @@
-- --
------------------------------------------------------------------------------
with Ada.IO_Exceptions;
with Ada.Characters.Handling;
with Ada.Strings.Fixed;
@ -573,6 +574,11 @@ package body GNAT.Directory_Operations is
begin
Local_Get_Current_Dir (Buffer'Address, Path_Len'Address);
if Path_Len = 0 then
raise Ada.IO_Exceptions.Use_Error
with "current directory does not exist";
end if;
Last :=
(if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last);

4
gcc/ada/osint.adb
View File

@ -1550,6 +1550,10 @@ package body Osint is
begin
Get_Current_Dir (Buffer'Address, Path_Len'Address);
if Path_Len = 0 then
raise Program_Error;
end if;
if Buffer (Path_Len) /= Directory_Separator then
Path_Len := Path_Len + 1;
Buffer (Path_Len) := Directory_Separator;

8
gcc/ada/par-prag.adb
View File

@ -292,9 +292,13 @@ begin
return Pragma_Node;
end if;
-- Ignore pragma previously flagged by Ignore_Pragma
-- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
-- Default_Scalar_Storage_Order if the -gnatI switch was given.
if Should_Ignore_Pragma_Par (Prag_Name) then
if Should_Ignore_Pragma_Par (Prag_Name)
or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
and then Ignore_Rep_Clauses)
then
return Pragma_Node;
end if;

6
gcc/ada/s-os_lib.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1995-2016, AdaCore --
-- Copyright (C) 1995-2017, AdaCore --
-- --
-- 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- --
@ -2191,6 +2191,10 @@ package body System.OS_Lib is
begin
Get_Current_Dir (Buffer'Address, Path_Len'Address);
if Path_Len = 0 then
raise Program_Error;
end if;
if Buffer (Path_Len) /= Directory_Separator then
Path_Len := Path_Len + 1;
Buffer (Path_Len) := Directory_Separator;

10
gcc/ada/sem.adb
View File

@ -654,6 +654,15 @@ package body Sem is
=>
null;
-- A quantified expression with a missing "all" or "some" qualifier
-- looks identical to an iterated component association. By language
-- definition, the latter must be present within array aggregates. If
-- this is not the case, then the iterated component association is
-- really an illegal quantified expression. Diagnose this scenario.
when N_Iterated_Component_Association =>
Diagnose_Iterated_Component_Association (N);
-- For the remaining node types, we generate compiler abort, because
-- these nodes are always analyzed within the Sem_Chn routines and
-- there should never be a case of making a call to the main Analyze
@ -704,7 +713,6 @@ package body Sem is
| N_Function_Specification
| N_Generic_Association
| N_Index_Or_Discriminant_Constraint
| N_Iterated_Component_Association
| N_Iteration_Scheme
| N_Mod_Clause
| N_Modular_Type_Definition

2
gcc/ada/sem_ch13.adb
View File

@ -4670,8 +4670,10 @@ package body Sem_Ch13 is
when Attribute_Alignment
| Attribute_Bit_Order
| Attribute_Component_Size
| Attribute_Default_Scalar_Storage_Order
| Attribute_Machine_Radix
| Attribute_Object_Size
| Attribute_Scalar_Storage_Order
| Attribute_Size
| Attribute_Small
| Attribute_Stream_Size

12
gcc/ada/sem_prag.adb
View File

@ -3427,13 +3427,14 @@ package body Sem_Prag is
procedure Analyze_Pragma (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Prag_Id : Pragma_Id;
Pname : Name_Id := Pragma_Name (N);
-- Name of the source pragma, or name of the corresponding aspect for
-- pragmas which originate in a source aspect. In the latter case, the
-- name may be different from the pragma name.
Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
Pragma_Exit : exception;
-- This exception is used to exit pragma processing completely. It
-- is used when an error is detected, and no further processing is
@ -10529,9 +10530,13 @@ package body Sem_Prag is
Check_Restriction_No_Use_Of_Pragma (N);
-- Ignore pragma if Ignore_Pragma applies
-- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
-- Default_Scalar_Storage_Order if the -gnatI switch was given.
if Should_Ignore_Pragma_Sem (N) then
if Should_Ignore_Pragma_Sem (N)
or else (Prag_Id = Pragma_Default_Scalar_Storage_Order
and then Ignore_Rep_Clauses)
then
return;
end if;
@ -10557,7 +10562,6 @@ package body Sem_Prag is
-- Here to start processing for recognized pragma
Prag_Id := Get_Pragma_Id (Pname);
Pname := Original_Aspect_Pragma_Name (N);
-- Capture setting of Opt.Uneval_Old

25
gcc/ada/sem_res.adb
View File

@ -6,7 +6,7 @@
-- --
-- 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 --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -6102,17 +6102,24 @@ package body Sem_Res is
-- If the called function is not declared in the main unit and it
-- returns the limited view of type then use the available view (as
-- is done in Try_Object_Operation) to prevent back-end confusion;
-- the call must appear in a context where the nonlimited view is
-- available. If the called function is in the extended main unit
-- then no action is needed, because the back end handles this case.
-- for the function entity itself. The call must appear in a context
-- where the nonlimited view is available. If the function entity is
-- in the extended main unit then no action is needed, because the
-- back end handles this case. In either case the type of the call
-- is the nonlimited view.
if not In_Extended_Main_Code_Unit (Nam)
and then From_Limited_With (Etype (Nam))
if From_Limited_With (Etype (Nam))
and then Present (Available_View (Etype (Nam)))
then
Set_Etype (Nam, Available_View (Etype (Nam)));
end if;
Set_Etype (N, Available_View (Etype (Nam)));
Set_Etype (N, Etype (Nam));
if not In_Extended_Main_Code_Unit (Nam) then
Set_Etype (Nam, Available_View (Etype (Nam)));
end if;
else
Set_Etype (N, Etype (Nam));
end if;
end if;
-- In the case where the call is to an overloaded subprogram, Analyze

53
gcc/ada/sem_util.adb
View File

@ -6023,12 +6023,52 @@ package body Sem_Util is
end if;
end Designate_Same_Unit;
------------------------------------------
-- function Dynamic_Accessibility_Level --
------------------------------------------
---------------------------------------------
-- Diagnose_Iterated_Component_Association --
---------------------------------------------
procedure Diagnose_Iterated_Component_Association (N : Node_Id) is
Def_Id : constant Entity_Id := Defining_Identifier (N);
Aggr : Node_Id;
begin
-- Determine whether the iterated component association appears within
-- an aggregate. If this is the case, raise Program_Error because the
-- iterated component association cannot be left in the tree as is and
-- must always be processed by the related aggregate.
Aggr := N;
while Present (Aggr) loop
if Nkind (Aggr) = N_Aggregate then
raise Program_Error;
-- Prevent the search from going too far
elsif Is_Body_Or_Package_Declaration (Aggr) then
exit;
end if;
Aggr := Parent (Aggr);
end loop;
-- At this point it is known that the iterated component association is
-- not within an aggregate. This is really a quantified expression with
-- a missing "all" or "some" quantifier.
Error_Msg_N ("missing quantifier", Def_Id);
-- Rewrite the iterated component association as True to prevent any
-- cascaded errors.
Rewrite (N, New_Occurrence_Of (Standard_True, Sloc (N)));
Analyze (N);
end Diagnose_Iterated_Component_Association;
---------------------------------
-- Dynamic_Accessibility_Level --
---------------------------------
function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id is
E : Entity_Id;
Loc : constant Source_Ptr := Sloc (Expr);
function Make_Level_Literal (Level : Uint) return Node_Id;
@ -6041,11 +6081,16 @@ package body Sem_Util is
function Make_Level_Literal (Level : Uint) return Node_Id is
Result : constant Node_Id := Make_Integer_Literal (Loc, Level);
begin
Set_Etype (Result, Standard_Natural);
return Result;
end Make_Level_Literal;
-- Local variables
E : Entity_Id;
-- Start of processing for Dynamic_Accessibility_Level
begin

4
gcc/ada/sem_util.ads
View File

@ -545,6 +545,10 @@ package Sem_Util is
-- these names is supposed to be a selected component name, an expanded
-- name, a defining program unit name or an identifier.
procedure Diagnose_Iterated_Component_Association (N : Node_Id);
-- Emit an error if iterated component association N is actually an illegal
-- quantified expression lacking a quantifier.
function Dynamic_Accessibility_Level (Expr : Node_Id) return Node_Id;
-- Expr should be an expression of an access type. Builds an integer
-- literal except in cases involving anonymous access types where