OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2016-07-07  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch6.adb (Expand_Internal_Init_Call): Subsidiary procedure
	to Expand_Protected_ Subprogram_Call, to handle properly a
	call to a protected function that provides the initialization
	expression for a private component of the same protected type.
	* sem_ch9.adb (Analyze_Protected_Definition): Layout must be
	applied to itypes generated for a private operation of a protected
	type that has a formal of an anonymous access to subprogram,
	because these itypes have no freeze nodes and are frozen in place.
	* sem_ch4.adb (Analyze_Selected_Component): If prefix is a
	protected type and it is not a current instance, do not examine
	the first private component of the type.

2016-07-07  Arnaud Charlet  <charlet@adacore.com>

	* exp_imgv.adb, g-dynhta.adb, s-regexp.adb, s-fatgen.adb, s-poosiz.adb:
	Minor removal of extra whitespace.
	* einfo.ads: minor removal of repeated "as" in comment

2016-07-07  Vadim Godunko  <godunko@adacore.com>

	* adaint.c: Complete previous change.

From-SVN: r238117
This commit is contained in:
Arnaud Charlet 2016-07-07 15:20:30 +02:00
parent 0640c7d139
commit 86ec3bfb9f
11 changed files with 123 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/ada/ChangeLog
View File

@ -1,3 +1,27 @@
2016-07-07 Ed Schonberg <schonberg@adacore.com>
* exp_ch6.adb (Expand_Internal_Init_Call): Subsidiary procedure
to Expand_Protected_ Subprogram_Call, to handle properly a
call to a protected function that provides the initialization
expression for a private component of the same protected type.
* sem_ch9.adb (Analyze_Protected_Definition): Layout must be
applied to itypes generated for a private operation of a protected
type that has a formal of an anonymous access to subprogram,
because these itypes have no freeze nodes and are frozen in place.
* sem_ch4.adb (Analyze_Selected_Component): If prefix is a
protected type and it is not a current instance, do not examine
the first private component of the type.
2016-07-07 Arnaud Charlet <charlet@adacore.com>
* exp_imgv.adb, g-dynhta.adb, s-regexp.adb, s-fatgen.adb, s-poosiz.adb:
Minor removal of extra whitespace.
* einfo.ads: minor removal of repeated "as" in comment
2016-07-07 Vadim Godunko <godunko@adacore.com>
* adaint.c: Complete previous change.
2016-07-07 Vadim Godunko <godunko@adacore.com>
* adainit.h, adainit.c (__gnat_is_read_accessible_file): New

25
gcc/ada/adaint.c
View File

@ -1919,7 +1919,16 @@ __gnat_is_read_accessible_file (char *name)
S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
return !_access (wname, 4);
return !_waccess (wname, 4);
#elif defined (__vxworks)
int fd;
if (fd = open (name, O_RDONLY, 0) < 0)
return 0;
close (fd);
return 1;
#else
return !access (name, R_OK);
#endif
@ -1983,7 +1992,16 @@ __gnat_is_write_accessible_file (char *name)
S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2);
return !_access (wname, 2);
return !_waccess (wname, 2);
#elif defined (__vxworks)
int fd;
if (fd = open (name, O_WRONLY, 0) < 0)
return 0;
close (fd);
return 1;
#else
return !access (name, W_OK);
#endif
@ -3291,7 +3309,6 @@ __gnat_kill (int pid, int sig, int close ATTRIBUTE_UNUSED)
void __gnat_killprocesstree (int pid, int sig_num)
{
#if defined(_WIN32)
HANDLE hWnd;
PROCESSENTRY32 pe;
memset(&pe, 0, sizeof(PROCESSENTRY32));
@ -3315,7 +3332,7 @@ void __gnat_killprocesstree (int pid, int sig_num)
while (bContinue)
{
if (pe.th32ParentProcessID == (int)pid)
if (pe.th32ParentProcessID == (DWORD)pid)
__gnat_killprocesstree (pe.th32ProcessID, sig_num);
bContinue = Process32Next (hSnap, &pe);

2
gcc/ada/einfo.ads
View File

@ -5502,7 +5502,7 @@ package Einfo is
-- The following list of access functions applies to all entities for
-- types and subtypes. References to this list appear subsequently as
-- as "(plus type attributes)" for each appropriate Entity_Kind.
-- "(plus type attributes)" for each appropriate Entity_Kind.
-- Associated_Node_For_Itype (Node8)
-- Class_Wide_Type (Node9)

47
gcc/ada/exp_ch6.adb
View File

@ -5945,6 +5945,12 @@ package body Exp_Ch6 is
is
Rec : Node_Id;
procedure Expand_Internal_Init_Call;
-- A call to an operation of the type may occur in the initialization
-- of a private component. In that case the prefix of the call is an
-- entity name and the call is treated as internal even though it
-- appears in code outside of the protected type.
procedure Freeze_Called_Function;
-- If it is a function call it can appear in elaboration code and
-- the called entity must be frozen before the call. This must be
@ -5952,6 +5958,31 @@ package body Exp_Ch6 is
-- to something other than a call (e.g. a temporary initialized in a
-- transient block).
-------------------------------
-- Expand_Internal_Init_Call --
-------------------------------
procedure Expand_Internal_Init_Call is
begin
-- If the context is a protected object (rather than a protected
-- type) the call itself is bound to raise program_error because
-- the protected body will not have been elaborated yet. This is
-- diagnosed subsequently in Sem_Elab.
Freeze_Called_Function;
-- The target of the internal call is the first formal of the
-- enclosing initialization procedure.
Rec := New_Occurrence_Of (First_Formal (Current_Scope), Sloc (N));
Build_Protected_Subprogram_Call (N,
Name => Name (N),
Rec => Rec,
External => False);
Analyze (N);
Resolve (N, Etype (Subp));
end Expand_Internal_Init_Call;
----------------------------
-- Freeze_Called_Function --
----------------------------
@ -5975,14 +6006,24 @@ package body Exp_Ch6 is
-- case this must be handled as an inter-object call.
if not In_Open_Scopes (Scop)
or else not Is_Entity_Name (Name (N))
or else (not Is_Entity_Name (Name (N)))
then
if Nkind (Name (N)) = N_Selected_Component then
Rec := Prefix (Name (N));
else
pragma Assert (Nkind (Name (N)) = N_Indexed_Component);
elsif Nkind (Name (N)) = N_Indexed_Component then
Rec := Prefix (Prefix (Name (N)));
else
-- If the context is the initialization procedure for a protected
-- type, the call is legal because the called entity must be a
-- function of that enclosing type, and this is treated as an
-- internal call.
pragma Assert (Is_Entity_Name (Name (N))
and then Inside_Init_Proc);
Expand_Internal_Init_Call;
return;
end if;
Freeze_Called_Function;

10
gcc/ada/exp_imgv.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. --
-- Copyright (C) 2001-2016, 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- --
@ -694,7 +694,7 @@ package body Exp_Imgv is
if Ttyp = Standard_Integer_8 then
Func := RE_Value_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
elsif Ttyp = Standard_Integer_16 then
Func := RE_Value_Enumeration_16;
else
Func := RE_Value_Enumeration_32;
@ -1278,7 +1278,7 @@ package body Exp_Imgv is
when Normal =>
if Ttyp = Standard_Integer_8 then
XX := RE_Width_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
elsif Ttyp = Standard_Integer_16 then
XX := RE_Width_Enumeration_16;
else
XX := RE_Width_Enumeration_32;
@ -1287,7 +1287,7 @@ package body Exp_Imgv is
when Wide =>
if Ttyp = Standard_Integer_8 then
XX := RE_Wide_Width_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
elsif Ttyp = Standard_Integer_16 then
XX := RE_Wide_Width_Enumeration_16;
else
XX := RE_Wide_Width_Enumeration_32;
@ -1296,7 +1296,7 @@ package body Exp_Imgv is
when Wide_Wide =>
if Ttyp = Standard_Integer_8 then
XX := RE_Wide_Wide_Width_Enumeration_8;
elsif Ttyp = Standard_Integer_16 then
elsif Ttyp = Standard_Integer_16 then
XX := RE_Wide_Wide_Width_Enumeration_16;
else
XX := RE_Wide_Wide_Width_Enumeration_32;

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

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2015, AdaCore --
-- Copyright (C) 2002-2016, 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- --
@ -57,8 +57,8 @@ package body GNAT.Dynamic_HTables is
-- Get --
---------
function Get (T : Instance; K : Key) return Elmt_Ptr is
Elmt : Elmt_Ptr;
function Get (T : Instance; K : Key) return Elmt_Ptr is
Elmt : Elmt_Ptr;
begin
if T = null then
@ -224,7 +224,7 @@ package body GNAT.Dynamic_HTables is
-- Get --
---------
function Get (T : Instance; K : Key) return Element is
function Get (T : Instance; K : Key) return Element is
Tmp : Elmt_Ptr;
begin

10
gcc/ada/s-fatgen.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -84,7 +84,7 @@ package body System.Fat_Gen is
-- the sign of the exponent. The absolute value of Frac is in the range
-- 0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero.
function Gradual_Scaling (Adjustment : UI) return T;
function Gradual_Scaling (Adjustment : UI) return T;
-- Like Scaling with a first argument of 1.0, but returns the smallest
-- denormal rather than zero when the adjustment is smaller than
-- Machine_Emin. Used for Succ and Pred.
@ -368,7 +368,7 @@ package body System.Fat_Gen is
Result := Truncation (abs X);
Tail := abs X - Result;
if Tail >= 0.5 then
if Tail >= 0.5 then
Result := Result + 1.0;
end if;
@ -553,7 +553,7 @@ package body System.Fat_Gen is
Result := Truncation (abs X);
Tail := abs X - Result;
if Tail >= 0.5 then
if Tail >= 0.5 then
Result := Result + 1.0;
end if;
@ -775,7 +775,7 @@ package body System.Fat_Gen is
Result := Truncation (Abs_X);
Tail := Abs_X - Result;
if Tail > 0.5 then
if Tail > 0.5 then
Result := Result + 1.0;
elsif Tail = 0.5 then

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

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, 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- --
@ -148,7 +148,7 @@ package body System.Pool_Size is
-- Initialize --
----------------
procedure Initialize (Pool : in out Stack_Bounded_Pool) is
procedure Initialize (Pool : in out Stack_Bounded_Pool) is
-- Define the appropriate alignment for allocations. This is the
-- maximum of the requested alignment, and the alignment required
@ -180,7 +180,7 @@ package body System.Pool_Size is
-- Storage_Size --
------------------
function Storage_Size
function Storage_Size
(Pool : Stack_Bounded_Pool) return SSE.Storage_Count
is
begin

4
gcc/ada/s-regexp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1999-2015, AdaCore --
-- Copyright (C) 1999-2016, 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- --
@ -551,7 +551,7 @@ package body System.Regexp is
("Incorrect character ']' in regular expression", J);
when '\' =>
if J < S'Last then
if J < S'Last then
J := J + 1;
Add_In_Map (S (J));

8
gcc/ada/sem_ch4.adb
View File

@ -4804,8 +4804,14 @@ package body Sem_Ch4 is
In_Scope := In_Open_Scopes (Prefix_Type);
while Present (Comp) loop
-- Do not examine private operations of the type if not within
-- its scope.
if Chars (Comp) = Chars (Sel) then
if Is_Overloadable (Comp) then
if Is_Overloadable (Comp)
and then (In_Scope
or else Comp /= First_Private_Entity (Type_To_Use))
then
Add_One_Interp (Sel, Comp, Etype (Comp));
-- If the prefix is tagged, the correct interpretation may

8
gcc/ada/sem_ch9.adb
View File

@ -1875,7 +1875,9 @@ package body Sem_Ch9 is
-- composite types with inner components, we traverse recursively
-- the private components of the protected type, and indicate that
-- all itypes within are frozen. This ensures that no freeze nodes
-- will be generated for them.
-- will be generated for them. In the case of itypes that are access
-- types we need to complete their representation by calling layout,
-- which would otherwise be invoked when freezing a type.
--
-- On the other hand, components of the corresponding record are
-- frozen (or receive itype references) as for other records.
@ -1903,6 +1905,10 @@ package body Sem_Ch9 is
Set_Has_Delayed_Freeze (Comp, False);
Set_Is_Frozen (Comp);
if Is_Access_Type (Comp) then
Layout_Type (Comp);
end if;
if Is_Record_Type (Comp)
or else Is_Protected_Type (Comp)
then