From 0640c7d139ea91870c378de96cab14d708517593 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 7 Jul 2016 15:17:51 +0200 Subject: [PATCH] [multiple changes] 2016-07-07 Vadim Godunko * adainit.h, adainit.c (__gnat_is_read_accessible_file): New subprogram. (__gnat_is_write_accessible_file): New subprogram. * s-os_lib.ads, s-os_lib.adb (Is_Read_Accessible_File): New subprogram. (Is_Write_Accessible_File): New subprogram. 2016-07-07 Justin Squirek * sem_ch12.adb (Install_Body): Minor refactoring in the order of local functions. (In_Same_Scope): Change loop condition to be more expressive. From-SVN: r238116 --- gcc/ada/ChangeLog | 14 +++++++++++ gcc/ada/adaint.c | 28 ++++++++++++++++++++++ gcc/ada/adaint.h | 4 +++- gcc/ada/s-os_lib.adb | 30 ++++++++++++++++++++++++ gcc/ada/s-os_lib.ads | 10 +++++++- gcc/ada/sem_ch12.adb | 56 +++++++++++++++++++++++++------------------- 6 files changed, 116 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 1dea7dbf8fa..5b2b9fa10e1 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,17 @@ +2016-07-07 Vadim Godunko + + * adainit.h, adainit.c (__gnat_is_read_accessible_file): New + subprogram. + (__gnat_is_write_accessible_file): New subprogram. + * s-os_lib.ads, s-os_lib.adb (Is_Read_Accessible_File): New subprogram. + (Is_Write_Accessible_File): New subprogram. + +2016-07-07 Justin Squirek + + * sem_ch12.adb (Install_Body): Minor refactoring in the order + of local functions. + (In_Same_Scope): Change loop condition to be more expressive. + 2016-07-07 Gary Dismukes * sem_ch3.adb, sem_prag.adb, sem_prag.ads, prj-ext.adb, freeze.adb, diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 2c47f006e9c..9d8a438f0eb 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -1911,6 +1911,20 @@ __gnat_is_readable_file_attr (char* name, struct file_attributes* attr) return attr->readable; } +int +__gnat_is_read_accessible_file (char *name) +{ +#if defined (_WIN32) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + return !_access (wname, 4); +#else + return !access (name, R_OK); +#endif +} + int __gnat_is_readable_file (char *name) { @@ -1961,6 +1975,20 @@ __gnat_is_writable_file (char *name) return __gnat_is_writable_file_attr (name, &attr); } +int +__gnat_is_write_accessible_file (char *name) +{ +#if defined (_WIN32) + TCHAR wname [GNAT_MAX_PATH_LEN + 2]; + + S2WSC (wname, name, GNAT_MAX_PATH_LEN + 2); + + return !_access (wname, 2); +#else + return !access (name, W_OK); +#endif +} + int __gnat_is_executable_file_attr (char* name, struct file_attributes* attr) { diff --git a/gcc/ada/adaint.h b/gcc/ada/adaint.h index 2559a31ea84..338b2ef70e0 100644 --- a/gcc/ada/adaint.h +++ b/gcc/ada/adaint.h @@ -6,7 +6,7 @@ * * * C Header File * * * - * 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- * @@ -207,6 +207,8 @@ extern int __gnat_is_directory (char *); extern int __gnat_is_writable_file (char *); extern int __gnat_is_readable_file (char *name); extern int __gnat_is_executable_file (char *name); +extern int __gnat_is_write_accessible_file (char *name); +extern int __gnat_is_read_accessible_file (char *name); extern void __gnat_reset_attributes (struct file_attributes *); extern int __gnat_error_attributes (struct file_attributes *); diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb index f97bcbe79dc..31b2f08cab9 100644 --- a/gcc/ada/s-os_lib.adb +++ b/gcc/ada/s-os_lib.adb @@ -1495,6 +1495,21 @@ package body System.OS_Lib is return Is_Directory (F_Name'Address); end Is_Directory; + ----------------------------- + -- Is_Read_Accessible_File -- + ----------------------------- + + function Is_Read_Accessible_File (Name : String) return Boolean is + function Is_Read_Accessible_File (Name : Address) return Integer; + pragma Import + (C, Is_Read_Accessible_File, "__gnat_is_read_accessible_file"); + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Read_Accessible_File (F_Name'Address) /= 0; + end Is_Read_Accessible_File; + ---------------------- -- Is_Readable_File -- ---------------------- @@ -1571,6 +1586,21 @@ package body System.OS_Lib is return Is_Symbolic_Link (F_Name'Address); end Is_Symbolic_Link; + ------------------------------ + -- Is_Write_Accessible_File -- + ------------------------------ + + function Is_Write_Accessible_File (Name : String) return Boolean is + function Is_Write_Accessible_File (Name : Address) return Integer; + pragma Import + (C, Is_Write_Accessible_File, "__gnat_is_write_accessible_file"); + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Write_Accessible_File (F_Name'Address) /= 0; + end Is_Write_Accessible_File; + ---------------------- -- Is_Writable_File -- ---------------------- diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads index dd0851ded7d..90048749082 100644 --- a/gcc/ada/s-os_lib.ads +++ b/gcc/ada/s-os_lib.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1995-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- -- @@ -457,6 +457,14 @@ package System.OS_Lib is -- not actually be writable due to some other process having exclusive -- access. + function Is_Read_Accessible_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is readable. Returns True if so, False otherwise. + + function Is_Write_Accessible_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is writable. Returns True if so, False otherwise. + function Locate_Exec_On_Path (Exec_Name : String) return String_Access; -- Try to locate an executable whose name is given by Exec_Name in the -- directories listed in the environment Path. If the Exec_Name does not diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 0aa23ebc2cd..8533af0ecc7 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -713,7 +713,10 @@ package body Sem_Ch12 is -- body. Early instantiations can also appear if generic, instance and -- body are all in the declarative part of a subprogram or entry. Entities -- of packages that are early instantiations are delayed, and their freeze - -- node appears after the generic body. + -- node appears after the generic body. This rather complex machinery is + -- needed when nested instantiations are present, because the source does + -- not carry any indication of where the corresponding instance bodies must + -- be installed and frozen. procedure Install_Formal_Packages (Par : Entity_Id); -- Install the visible part of any formal of the parent that is a formal @@ -8927,23 +8930,13 @@ package body Sem_Ch12 is Gen_Body : Node_Id; Gen_Decl : Node_Id) is - Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); - Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); - Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); - Par : constant Entity_Id := Scope (Gen_Id); - Gen_Unit : constant Node_Id := - Unit (Cunit (Get_Source_Unit (Gen_Decl))); - Orig_Body : Node_Id := Gen_Body; - F_Node : Node_Id; - Body_Unit : Node_Id; - - Must_Delay : Boolean; - function In_Same_Scope (Generic_Id, Actual_Id : Node_Id) return Boolean; - -- Check if the generic definition's scope tree and the instantiation's - -- scope tree share a dependency. + function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean; + -- Check if the generic definition and the instantiation come from + -- a common scope, in which case the instance must be frozen after + -- the generic body. - function True_Sloc (N : Node_Id) return Source_Ptr; + function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr; -- If the instance is nested inside a generic unit, the Sloc of the -- instance indicates the place of the original definition, not the -- point of the current enclosing instance. Pending a better usage of @@ -8955,20 +8948,22 @@ package body Sem_Ch12 is -- In_Same_Scope -- ------------------- - function In_Same_Scope (Generic_Id, Actual_Id : Node_Id) return Boolean - is - Act_Scop : Entity_Id := Scope (Actual_Id); - Gen_Scop : Entity_Id := Scope (Generic_Id); + function In_Same_Scope (Gen_Id, Act_Id : Node_Id) return Boolean is + Act_Scop : Entity_Id := Scope (Act_Id); + Gen_Scop : Entity_Id := Scope (Gen_Id); + begin - while Scope_Depth_Value (Act_Scop) > 0 - and then Scope_Depth_Value (Gen_Scop) > 0 + while Act_Scop /= Standard_Standard + and then Gen_Scop /= Standard_Standard loop if Act_Scop = Gen_Scop then return True; end if; + Act_Scop := Scope (Act_Scop); Gen_Scop := Scope (Gen_Scop); end loop; + return False; end In_Same_Scope; @@ -8976,7 +8971,7 @@ package body Sem_Ch12 is -- True_Sloc -- --------------- - function True_Sloc (N : Node_Id) return Source_Ptr is + function True_Sloc (N, Act_Unit : Node_Id) return Source_Ptr is Res : Source_Ptr; N1 : Node_Id; @@ -8994,6 +8989,18 @@ package body Sem_Ch12 is return Res; end True_Sloc; + Act_Id : constant Entity_Id := Corresponding_Spec (Act_Body); + Act_Unit : constant Node_Id := Unit (Cunit (Get_Source_Unit (N))); + Gen_Id : constant Entity_Id := Corresponding_Spec (Gen_Body); + Par : constant Entity_Id := Scope (Gen_Id); + Gen_Unit : constant Node_Id := + Unit (Cunit (Get_Source_Unit (Gen_Decl))); + Orig_Body : Node_Id := Gen_Body; + F_Node : Node_Id; + Body_Unit : Node_Id; + + Must_Delay : Boolean; + -- Start of processing for Install_Body begin @@ -9058,7 +9065,8 @@ package body Sem_Ch12 is and then (Nkind_In (Gen_Unit, N_Package_Declaration, N_Generic_Package_Declaration) or else (Gen_Unit = Body_Unit - and then True_Sloc (N) < Sloc (Orig_Body))) + and then True_Sloc (N, Act_Unit) + < Sloc (Orig_Body))) and then Is_In_Main_Unit (Original_Node (Gen_Unit)) and then (In_Same_Scope (Gen_Id, Act_Id))); -- 2.30.2