From 86ec3bfb9fc3729d1e17d750e2d76be03f4f7110 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 7 Jul 2016 15:20:30 +0200 Subject: [PATCH] [multiple changes] 2016-07-07 Ed Schonberg * 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 * 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 * adaint.c: Complete previous change. From-SVN: r238117 --- gcc/ada/ChangeLog | 24 ++++++++++++++++++++++ gcc/ada/adaint.c | 25 +++++++++++++++++++---- gcc/ada/einfo.ads | 2 +- gcc/ada/exp_ch6.adb | 47 +++++++++++++++++++++++++++++++++++++++++--- gcc/ada/exp_imgv.adb | 10 +++++----- gcc/ada/g-dynhta.adb | 8 ++++---- gcc/ada/s-fatgen.adb | 10 +++++----- gcc/ada/s-poosiz.adb | 6 +++--- gcc/ada/s-regexp.adb | 4 ++-- gcc/ada/sem_ch4.adb | 8 +++++++- gcc/ada/sem_ch9.adb | 8 +++++++- 11 files changed, 123 insertions(+), 29 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5b2b9fa10e1..f7fa41d5f65 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2016-07-07 Ed Schonberg + + * 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 + + * 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 + + * adaint.c: Complete previous change. + 2016-07-07 Vadim Godunko * adainit.h, adainit.c (__gnat_is_read_accessible_file): New diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 9d8a438f0eb..67bdad3e8c5 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -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); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index ec065a91a02..1085862f9b6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 938484b22a2..a14274c4a98 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -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; diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb index f249afe0f8c..e4a07f7074e 100644 --- a/gcc/ada/exp_imgv.adb +++ b/gcc/ada/exp_imgv.adb @@ -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; diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb index 449ac17dec4..10931cc7d25 100644 --- a/gcc/ada/g-dynhta.adb +++ b/gcc/ada/g-dynhta.adb @@ -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 diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb index 35d037ac388..c2185e07328 100644 --- a/gcc/ada/s-fatgen.adb +++ b/gcc/ada/s-fatgen.adb @@ -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 diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb index 683f32e315d..da3a0c5594c 100644 --- a/gcc/ada/s-poosiz.adb +++ b/gcc/ada/s-poosiz.adb @@ -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 diff --git a/gcc/ada/s-regexp.adb b/gcc/ada/s-regexp.adb index 6a445340b14..e9faa1cc6b2 100644 --- a/gcc/ada/s-regexp.adb +++ b/gcc/ada/s-regexp.adb @@ -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)); diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 45ad8d63a11..5c0f4f66c0c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -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 diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 39e8dc174ea..8297db8fe74 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -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 -- 2.30.2