+2016-07-07 Vadim Godunko <godunko@adacore.com>
+
+ * 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 <squirek@adacore.com>
+
+ * 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 <dismukes@adacore.com>
* sem_ch3.adb, sem_prag.adb, sem_prag.ads, prj-ext.adb, freeze.adb,
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)
{
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)
{
* *
* 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- *
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 *);
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 --
----------------------
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 --
----------------------
-- --
-- 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- --
-- 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
-- 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
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
-- 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;
-- 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;
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
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)));
projects / gcc.git / commitdiff