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

s-fileio.adb (Errno_Message): Remove, use shared version from s-os_lib instead. 

2014-02-24  Thomas Quinot  <quinot@adacore.com>

	* s-fileio.adb (Errno_Message): Remove, use shared version from
	s-os_lib instead.
	* s-crtrun.ads, Makefile.rtl: Remove now unused unit.
	* g-stseme (Socket_Error_Message): Reimplement in terms of new
	s-os_lib function.
	* g-socthi.ads, g-socthi.adb: Change profile of
	Socket_Error_Message to return String to allow the above.
	* g-socket.adb, g-socthi-mingw.adb, g-socthi-mingw.ads,
	* g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb,
	* g-socthi-vxworks.ads: Update to account for the above profile
	change.
	* a-tags.adb: Use strlen builtin binding provided by s-crtl.
	* s-crtl.ads (strncpy): New procedure.
	* s-os_lib.adb (Copy_Attributes): Import just once (strncpy):
	Use import from s-crtl.
	* a-envvar.adb, osint.adb: Use imports of C runtime functions
	from s-crtl instead of re-importing locally.

From-SVN: r208079
This commit is contained in:
Thomas Quinot 2014-02-24 16:54:41 +00:00 committed by Arnaud Charlet
parent c6d2191a0d
commit 3e5b1f3247
20 changed files with 160 additions and 257 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
gcc/ada/ChangeLog
View File

@ -1,3 +1,23 @@
2014-02-24 Thomas Quinot <quinot@adacore.com>
* s-fileio.adb (Errno_Message): Remove, use shared version from
s-os_lib instead.
* s-crtrun.ads, Makefile.rtl: Remove now unused unit.
* g-stseme (Socket_Error_Message): Reimplement in terms of new
s-os_lib function.
* g-socthi.ads, g-socthi.adb: Change profile of
Socket_Error_Message to return String to allow the above.
* g-socket.adb, g-socthi-mingw.adb, g-socthi-mingw.ads,
* g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb,
* g-socthi-vxworks.ads: Update to account for the above profile
change.
* a-tags.adb: Use strlen builtin binding provided by s-crtl.
* s-crtl.ads (strncpy): New procedure.
* s-os_lib.adb (Copy_Attributes): Import just once (strncpy):
Use import from s-crtl.
* a-envvar.adb, osint.adb: Use imports of C runtime functions
from s-crtl instead of re-importing locally.
2014-02-24 Hristian Kirtchev <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Global_Item): Emit the

1
gcc/ada/Makefile.rtl
View File

@ -509,7 +509,6 @@ GNATRTL_NONTASKING_OBJS= \
s-conca9$(objext) \
s-crc32$(objext) \
s-crtl$(objext) \
s-crtrun$(objext) \
s-diflio$(objext) \
s-dim$(objext) \
s-diinio$(objext) \

9
gcc/ada/a-envvar.adb
View File

@ -29,7 +29,7 @@
-- --
------------------------------------------------------------------------------
with System;
with System.CRTL;
with Interfaces.C.Strings;
with Ada.Unchecked_Deallocation;
@ -188,14 +188,11 @@ package body Ada.Environment_Variables is
-----------
function Value (Name : String) return String is
use System;
use System, System.CRTL;
procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
Env_Value_Ptr : aliased Address;
Env_Value_Length : aliased Integer;
F_Name : aliased String (1 .. Name'Length + 1);
@ -215,7 +212,7 @@ package body Ada.Environment_Variables is
declare
Result : aliased String (1 .. Env_Value_Length);
begin
Strncpy (Result'Address, Env_Value_Ptr, Env_Value_Length);
strncpy (Result'Address, Env_Value_Ptr, size_t (Env_Value_Length));
return Result;
end;
else

39
gcc/ada/a-tags.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2013, 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- --
@ -31,6 +31,7 @@
with Ada.Exceptions;
with Ada.Unchecked_Conversion;
with System.CRTL; use System.CRTL;
with System.HTable;
with System.Storage_Elements; use System.Storage_Elements;
with System.WCh_Con; use System.WCh_Con;
@ -56,10 +57,6 @@ package body Ada.Tags is
-- table. This is Inline_Always since it is called from other Inline_
-- Always subprograms where we want no out of line code to be generated.
function Length (Str : Cstring_Ptr) return Natural;
-- Length of string represented by the given pointer (treating the string
-- as a C-style string, which is Nul terminated).
function OSD (T : Tag) return Object_Specific_Data_Ptr;
-- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table,
-- retrieve the address of the record containing the Object Specific
@ -273,10 +270,11 @@ package body Ada.Tags is
function Hash (F : System.Address) return HTable_Headers is
function H is new System.HTable.Hash (HTable_Headers);
Str : constant Cstring_Ptr := To_Cstring_Ptr (F);
Res : constant HTable_Headers := H (Str (1 .. Length (Str)));
Str : String (1 .. Integer (strlen (F)));
for Str'Address use F;
pragma Import (Ada, Str);
begin
return Res;
return H (Str);
end Hash;
-----------------
@ -310,7 +308,8 @@ package body Ada.Tags is
procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is
T : Tag;
E_Tag_Len : constant Integer := Length (TSD.External_Tag);
E_Tag_Len : constant Integer :=
Integer (strlen (TSD.External_Tag.all'Address));
E_Tag : String (1 .. E_Tag_Len);
for E_Tag'Address use TSD.External_Tag.all'Address;
pragma Import (Ada, E_Tag);
@ -487,7 +486,7 @@ package body Ada.Tags is
TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
Result := TSD.Expanded_Name;
return Result (1 .. Length (Result));
return Result (1 .. Integer (strlen (Result.all'Address)));
end Expanded_Name;
------------------
@ -507,7 +506,7 @@ package body Ada.Tags is
TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size);
TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all);
Result := TSD.External_Tag;
return Result (1 .. Length (Result));
return Result (1 .. Integer (strlen (Result.all'Address)));
end External_Tag;
---------------------
@ -731,24 +730,6 @@ package body Ada.Tags is
and then D_TSD.Access_Level = A_TSD.Access_Level;
end Is_Descendant_At_Same_Level;
------------
-- Length --
------------
-- Should this be reimplemented using the strlen GCC builtin???
function Length (Str : Cstring_Ptr) return Natural is
Len : Integer;
begin
Len := 1;
while Str (Len) /= ASCII.NUL loop
Len := Len + 1;
end loop;
return Len - 1;
end Length;
-------------------
-- Offset_To_Top --
-------------------

3
gcc/ada/g-socket.adb
View File

@ -1720,8 +1720,7 @@ package body GNAT.Sockets is
use type C.Strings.chars_ptr;
begin
raise Socket_Error with
Err_Code_Image (Error)
& C.Strings.Value (Socket_Error_Message (Error));
Err_Code_Image (Error) & Socket_Error_Message (Error);
end Raise_Socket_Error;
----------

2
gcc/ada/g-socthi-dummy.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2012, AdaCore --
-- Copyright (C) 2001-2013, 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- --

2
gcc/ada/g-socthi-dummy.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2012, AdaCore --
-- Copyright (C) 2001-2013, 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- --

101
gcc/ada/g-socthi-mingw.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2012, AdaCore --
-- Copyright (C) 2001-2013, 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- --
@ -565,69 +565,70 @@ package body GNAT.Sockets.Thin is
-- Socket_Error_Message --
--------------------------
function Socket_Error_Message
(Errno : Integer) return C.Strings.chars_ptr
is
function Socket_Error_Message (Errno : Integer) return String is
use GNAT.Sockets.SOSC;
Errm : C.Strings.chars_ptr;
begin
case Errno is
when EINTR => return Error_Messages (N_EINTR);
when EBADF => return Error_Messages (N_EBADF);
when EACCES => return Error_Messages (N_EACCES);
when EFAULT => return Error_Messages (N_EFAULT);
when EINVAL => return Error_Messages (N_EINVAL);
when EMFILE => return Error_Messages (N_EMFILE);
when EWOULDBLOCK => return Error_Messages (N_EWOULDBLOCK);
when EINPROGRESS => return Error_Messages (N_EINPROGRESS);
when EALREADY => return Error_Messages (N_EALREADY);
when ENOTSOCK => return Error_Messages (N_ENOTSOCK);
when EDESTADDRREQ => return Error_Messages (N_EDESTADDRREQ);
when EMSGSIZE => return Error_Messages (N_EMSGSIZE);
when EPROTOTYPE => return Error_Messages (N_EPROTOTYPE);
when ENOPROTOOPT => return Error_Messages (N_ENOPROTOOPT);
when EPROTONOSUPPORT => return Error_Messages (N_EPROTONOSUPPORT);
when ESOCKTNOSUPPORT => return Error_Messages (N_ESOCKTNOSUPPORT);
when EOPNOTSUPP => return Error_Messages (N_EOPNOTSUPP);
when EPFNOSUPPORT => return Error_Messages (N_EPFNOSUPPORT);
when EAFNOSUPPORT => return Error_Messages (N_EAFNOSUPPORT);
when EADDRINUSE => return Error_Messages (N_EADDRINUSE);
when EADDRNOTAVAIL => return Error_Messages (N_EADDRNOTAVAIL);
when ENETDOWN => return Error_Messages (N_ENETDOWN);
when ENETUNREACH => return Error_Messages (N_ENETUNREACH);
when ENETRESET => return Error_Messages (N_ENETRESET);
when ECONNABORTED => return Error_Messages (N_ECONNABORTED);
when ECONNRESET => return Error_Messages (N_ECONNRESET);
when ENOBUFS => return Error_Messages (N_ENOBUFS);
when EISCONN => return Error_Messages (N_EISCONN);
when ENOTCONN => return Error_Messages (N_ENOTCONN);
when ESHUTDOWN => return Error_Messages (N_ESHUTDOWN);
when ETOOMANYREFS => return Error_Messages (N_ETOOMANYREFS);
when ETIMEDOUT => return Error_Messages (N_ETIMEDOUT);
when ECONNREFUSED => return Error_Messages (N_ECONNREFUSED);
when ELOOP => return Error_Messages (N_ELOOP);
when ENAMETOOLONG => return Error_Messages (N_ENAMETOOLONG);
when EHOSTDOWN => return Error_Messages (N_EHOSTDOWN);
when EHOSTUNREACH => return Error_Messages (N_EHOSTUNREACH);
when EINTR => Errm := N_EINTR;
when EBADF => Errm := N_EBADF;
when EACCES => Errm := N_EACCES;
when EFAULT => Errm := N_EFAULT;
when EINVAL => Errm := N_EINVAL;
when EMFILE => Errm := N_EMFILE;
when EWOULDBLOCK => Errm := N_EWOULDBLOCK;
when EINPROGRESS => Errm := N_EINPROGRESS;
when EALREADY => Errm := N_EALREADY;
when ENOTSOCK => Errm := N_ENOTSOCK;
when EDESTADDRREQ => Errm := N_EDESTADDRREQ;
when EMSGSIZE => Errm := N_EMSGSIZE;
when EPROTOTYPE => Errm := N_EPROTOTYPE;
when ENOPROTOOPT => Errm := N_ENOPROTOOPT;
when EPROTONOSUPPORT => Errm := N_EPROTONOSUPPORT;
when ESOCKTNOSUPPORT => Errm := N_ESOCKTNOSUPPORT;
when EOPNOTSUPP => Errm := N_EOPNOTSUPP;
when EPFNOSUPPORT => Errm := N_EPFNOSUPPORT;
when EAFNOSUPPORT => Errm := N_EAFNOSUPPORT;
when EADDRINUSE => Errm := N_EADDRINUSE;
when EADDRNOTAVAIL => Errm := N_EADDRNOTAVAIL;
when ENETDOWN => Errm := N_ENETDOWN;
when ENETUNREACH => Errm := N_ENETUNREACH;
when ENETRESET => Errm := N_ENETRESET;
when ECONNABORTED => Errm := N_ECONNABORTED;
when ECONNRESET => Errm := N_ECONNRESET;
when ENOBUFS => Errm := N_ENOBUFS;
when EISCONN => Errm := N_EISCONN;
when ENOTCONN => Errm := N_ENOTCONN;
when ESHUTDOWN => Errm := N_ESHUTDOWN;
when ETOOMANYREFS => Errm := N_ETOOMANYREFS;
when ETIMEDOUT => Errm := N_ETIMEDOUT;
when ECONNREFUSED => Errm := N_ECONNREFUSED;
when ELOOP => Errm := N_ELOOP;
when ENAMETOOLONG => Errm := N_ENAMETOOLONG;
when EHOSTDOWN => Errm := N_EHOSTDOWN;
when EHOSTUNREACH => Errm := N_EHOSTUNREACH;
-- Windows-specific error codes
when WSASYSNOTREADY => return Error_Messages (N_WSASYSNOTREADY);
when WSASYSNOTREADY => Errm := N_WSASYSNOTREADY;
when WSAVERNOTSUPPORTED =>
return Error_Messages (N_WSAVERNOTSUPPORTED);
Errm := N_WSAVERNOTSUPPORTED;
when WSANOTINITIALISED =>
return Error_Messages (N_WSANOTINITIALISED);
when WSAEDISCON => return Error_Messages (N_WSAEDISCON);
Errm := N_WSANOTINITIALISED;
when WSAEDISCON => Errm := N_WSAEDISCON;
-- h_errno values
when HOST_NOT_FOUND => return Error_Messages (N_HOST_NOT_FOUND);
when TRY_AGAIN => return Error_Messages (N_TRY_AGAIN);
when NO_RECOVERY => return Error_Messages (N_NO_RECOVERY);
when NO_DATA => return Error_Messages (N_NO_DATA);
when HOST_NOT_FOUND => Errm := N_HOST_NOT_FOUND;
when TRY_AGAIN => Errm := N_TRY_AGAIN;
when NO_RECOVERY => Errm := N_NO_RECOVERY;
when NO_DATA => Errm := N_NO_DATA;
when others => return Error_Messages (N_OTHERS);
when others => Errm := N_OTHERS;
end case;
return Value (Errm);
end Socket_Error_Message;
end GNAT.Sockets.Thin;

4
gcc/ada/g-socthi-mingw.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2012, AdaCore --
-- Copyright (C) 2001-2013, 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- --
@ -56,7 +56,7 @@ package GNAT.Sockets.Thin is
procedure Set_Socket_Errno (Errno : Integer);
-- Set last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
function Socket_Error_Message (Errno : Integer) return String;
-- Returns the error message string for the error number Errno. If Errno is
-- not known, returns "Unknown system error".

6
gcc/ada/g-socthi-vms.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2012, AdaCore --
-- Copyright (C) 2001-2013, 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- --
@ -500,8 +500,6 @@ package body GNAT.Sockets.Thin is
-- Socket_Error_Message --
--------------------------
function Socket_Error_Message
(Errno : Integer) return C.Strings.chars_ptr
is separate;
function Socket_Error_Message (Errno : Integer) return String is separate;
end GNAT.Sockets.Thin;

4
gcc/ada/g-socthi-vms.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2012, AdaCore --
-- Copyright (C) 2002-2013, 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- --
@ -59,7 +59,7 @@ package GNAT.Sockets.Thin is
procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno;
-- Set last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
function Socket_Error_Message (Errno : Integer) return String;
-- Returns the error message string for the error number Errno. If Errno is
-- not known, returns "Unknown system error".

6
gcc/ada/g-socthi-vxworks.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2012, AdaCore --
-- Copyright (C) 2002-2013, 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- --
@ -485,8 +485,6 @@ package body GNAT.Sockets.Thin is
-- Socket_Error_Message --
--------------------------
function Socket_Error_Message
(Errno : Integer) return C.Strings.chars_ptr
is separate;
function Socket_Error_Message (Errno : Integer) return String is separate;
end GNAT.Sockets.Thin;

4
gcc/ada/g-socthi-vxworks.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2012, AdaCore --
-- Copyright (C) 2002-2013, 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,7 +57,7 @@ package GNAT.Sockets.Thin is
procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno;
-- Set last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
function Socket_Error_Message (Errno : Integer) return String;
-- Returns the error message string for the error number Errno. If Errno is
-- not known, returns "Unknown system error".

9
gcc/ada/g-socthi.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2012, AdaCore --
-- Copyright (C) 2001-2013, 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,7 @@ package body GNAT.Sockets.Thin is
-- non-blocking mode and we spend a period of time Quantum between
-- two attempts on a blocking operation.
Unknown_System_Error : constant C.Strings.chars_ptr :=
C.Strings.New_String ("Unknown system error");
Unknown_System_Error : constant String := "Unknown system error";
-- Comments required for following functions ???
@ -490,8 +489,6 @@ package body GNAT.Sockets.Thin is
-- Socket_Error_Message --
--------------------------
function Socket_Error_Message
(Errno : Integer) return C.Strings.chars_ptr
is separate;
function Socket_Error_Message (Errno : Integer) return String is separate;
end GNAT.Sockets.Thin;

4
gcc/ada/g-socthi.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2012, AdaCore --
-- Copyright (C) 2001-2013, 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- --
@ -58,7 +58,7 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
function Socket_Error_Message (Errno : Integer) return String;
-- Returns the error message string for the error number Errno. If Errno is
-- not known, returns "Unknown system error".

16
gcc/ada/g-stseme.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2007-2009, AdaCore --
-- Copyright (C) 2007-2013, 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- --
@ -34,8 +34,6 @@
-- since on that platform socket errno values are distinct from the system
-- ones: there is a specific variant of this function in g-socthi-mingw.adb.
with System.CRTL.Runtime;
separate (GNAT.Sockets.Thin)
--------------------------
@ -43,16 +41,8 @@ separate (GNAT.Sockets.Thin)
--------------------------
function Socket_Error_Message
(Errno : Integer) return C.Strings.chars_ptr
(Errno : Integer) return String
is
use type Interfaces.C.Strings.chars_ptr;
C_Msg : constant C.Strings.chars_ptr :=
System.CRTL.Runtime.strerror (Errno);
begin
if C_Msg = C.Strings.Null_Ptr then
return Unknown_System_Error;
else
return C_Msg;
end if;
return Errno_Message (Errno, Default => Unknown_System_Error);
end Socket_Error_Message;

21
gcc/ada/s-crtl.ads
View File

@ -67,13 +67,26 @@ package System.CRTL is
pragma Convention (C, Filename_Encoding);
-- Describes the filename's encoding
function atoi (A : System.Address) return Integer;
pragma Import (C, atoi, "atoi");
--------------------
-- GCC intrinsics --
--------------------
-- The following functions are imported with convention Intrinsic so that
-- we take advantage of back-end builtins if present (else we fall back
-- to C library functions by the same names).
function strlen (A : System.Address) return size_t;
pragma Import (Intrinsic, strlen, "strlen");
-- Import with convention Intrinsic so that we take advantage of the GCC
-- builtin where available (and fall back to the library function if not).
procedure strncpy (dest, src : System.Address; n : size_t);
pragma Import (Intrinsic, strncpy, "strncpy");
-------------------------------
-- Other C runtime functions --
-------------------------------
function atoi (A : System.Address) return Integer;
pragma Import (C, atoi, "atoi");
procedure clearerr (stream : FILEs);
pragma Import (C, clearerr, "clearerr");

46
gcc/ada/s-crtrun.ads
View File

@ -1,46 +0,0 @@
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- S Y S T E M . C R T L . R U N T I M E --
-- --
-- S p e c --
-- --
-- Copyright (C) 2009, 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- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package provides the low level interface to the C runtime library
-- (additional declarations for use in the Ada runtime only, not in the
-- compiler itself).
with Interfaces.C.Strings;
package System.CRTL.Runtime is
pragma Preelaborate;
subtype chars_ptr is Interfaces.C.Strings.chars_ptr;
function strerror (errno : int) return chars_ptr;
pragma Import (C, strerror, "strerror");
end System.CRTL.Runtime;

32
gcc/ada/s-fileio.adb
View File

@ -33,10 +33,9 @@ with Ada.Finalization; use Ada.Finalization;
with Ada.IO_Exceptions; use Ada.IO_Exceptions;
with Interfaces.C;
with Interfaces.C.Strings; use Interfaces.C.Strings;
with Interfaces.C_Streams; use Interfaces.C_Streams;
with System.CRTL.Runtime;
with System.CRTL;
with System.Case_Util; use System.Case_Util;
with System.OS_Lib;
with System.Soft_Links;
@ -130,15 +129,9 @@ package body System.File_IO is
-- the access method from the Access_Method field of the FCB.
function Errno_Message
(Errno : Integer := OS_Lib.Errno) return String;
function Errno_Message
(Name : String;
(Name : String;
Errno : Integer := OS_Lib.Errno) return String;
-- Return a message suitable for "raise ... with Errno_Message (...)".
-- Errno defaults to the current errno, but should be passed explicitly if
-- there is significant code in between the call that sets errno and the
-- call to Errno_Message, in case that code also sets errno. The version
-- with Name includes that file name in the message.
-- Return Errno_Message for Errno, with file name prepended
procedure Raise_Device_Error
(File : AFCB_Ptr;
@ -241,7 +234,7 @@ package body System.File_IO is
Close_Status : int := 0;
Dup_Strm : Boolean := False;
File : AFCB_Ptr renames File_Ptr.all;
Errno : Integer;
Errno : Integer := 0;
begin
-- Take a task lock, to protect the global data value Open_Files
@ -351,7 +344,7 @@ package body System.File_IO is
-- we did the open, and we want to unlink the right file.
if unlink (Filename'Address) = -1 then
raise Use_Error with Errno_Message;
raise Use_Error with OS_Lib.Errno_Message;
end if;
end;
end Delete;
@ -383,23 +376,12 @@ package body System.File_IO is
-- Errno_Message --
-------------------
function Errno_Message (Errno : Integer := OS_Lib.Errno) return String is
Message : constant chars_ptr := CRTL.Runtime.strerror (Errno);
begin
if Message = Null_Ptr then
return "errno =" & Errno'Img;
else
return Value (Message);
end if;
end Errno_Message;
function Errno_Message
(Name : String;
Errno : Integer := OS_Lib.Errno) return String
is
begin
return Name & ": " & String'(Errno_Message (Errno));
return Name & ": " & OS_Lib.Errno_Message (Err => Errno);
end Errno_Message;
--------------
@ -1321,7 +1303,7 @@ package body System.File_IO is
clearerr (File.Stream);
end if;
raise Device_Error with Errno_Message (Errno);
raise Device_Error with OS_Lib.Errno_Message (Err => Errno);
end Raise_Device_Error;
--------------

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

@ -40,6 +40,11 @@ with System.Soft_Links;
package body System.OS_Lib is
subtype size_t is CRTL.size_t;
procedure Strncpy (dest, src : System.Address; n : size_t)
renames CRTL.strncpy;
-- Imported procedures Dup and Dup2 are used in procedures Spawn and
-- Non_Blocking_Spawn.
@ -49,6 +54,13 @@ package body System.OS_Lib is
procedure Dup2 (Old_Fd, New_Fd : File_Descriptor);
pragma Import (C, Dup2, "__gnat_dup2");
function Copy_Attributes
(From, To : System.Address;
Mode : Integer) return Integer;
pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
-- Mode = 0 - copy only time stamps.
-- Mode = 1 - copy time stamps and read/write/execute attributes
On_Windows : constant Boolean := Directory_Separator = '\';
-- An indication that we are on Windows. Used in Normalize_Pathname, to
-- deal with drive letters in the beginning of absolute paths.
@ -265,17 +277,17 @@ package body System.OS_Lib is
-----------
procedure Close (FD : File_Descriptor) is
procedure C_Close (FD : File_Descriptor);
pragma Import (C, C_Close, "close");
use CRTL;
Discard : constant int := close (int (FD));
pragma Unreferenced (Discard);
begin
C_Close (FD);
null;
end Close;
procedure Close (FD : File_Descriptor; Status : out Boolean) is
function C_Close (FD : File_Descriptor) return Integer;
pragma Import (C, C_Close, "close");
use CRTL;
begin
Status := (C_Close (FD) = 0);
Status := (close (int (FD)) = 0);
end Close;
---------------
@ -442,14 +454,6 @@ package body System.OS_Lib is
-------------
procedure Copy_To (To_Name : String) is
function Copy_Attributes
(From, To : System.Address;
Mode : Integer) return Integer;
pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
-- Mode = 0 - copy only time stamps.
-- Mode = 1 - copy time stamps and read/write/execute attributes
C_From : String (1 .. Name'Length + 1);
C_To : String (1 .. To_Name'Length + 1);
@ -609,13 +613,6 @@ package body System.OS_Lib is
----------------------
procedure Copy_Time_Stamps (Source, Dest : String; Success : out Boolean) is
function Copy_Attributes
(From, To : System.Address;
Mode : Integer) return Integer;
pragma Import (C, Copy_Attributes, "__gnat_copy_attribs");
-- Mode = 0 - copy only time stamps.
-- Mode = 1 - copy time stamps and read/write/execute attributes
begin
if Is_Regular_File (Source) and then Is_Writable_File (Dest) then
declare
@ -976,9 +973,6 @@ package body System.OS_Lib is
procedure Get_Suffix_Ptr (Length, Ptr : Address);
pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
Suffix_Ptr : Address;
Suffix_Length : Integer;
Result : String_Access;
@ -988,7 +982,7 @@ package body System.OS_Lib is
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
end if;
return Result;
@ -1002,9 +996,6 @@ package body System.OS_Lib is
procedure Get_Suffix_Ptr (Length, Ptr : Address);
pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
Suffix_Ptr : Address;
Suffix_Length : Integer;
Result : String_Access;
@ -1014,7 +1005,7 @@ package body System.OS_Lib is
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
end if;
return Result;
@ -1028,9 +1019,6 @@ package body System.OS_Lib is
procedure Get_Suffix_Ptr (Length, Ptr : Address);
pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
Suffix_Ptr : Address;
Suffix_Length : Integer;
Result : String_Access;
@ -1040,7 +1028,7 @@ package body System.OS_Lib is
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
Strncpy (Result.all'Address, Suffix_Ptr, Suffix_Length);
Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length));
end if;
return Result;
@ -1055,9 +1043,6 @@ package body System.OS_Lib is
pragma Import
(C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
Suffix_Length : Integer;
Result : String_Access;
@ -1066,7 +1051,8 @@ package body System.OS_Lib is
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
Strncpy
(Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
end if;
return Result;
@ -1081,9 +1067,6 @@ package body System.OS_Lib is
pragma Import
(C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
Suffix_Length : Integer;
Result : String_Access;
@ -1092,7 +1075,8 @@ package body System.OS_Lib is
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
Strncpy (Result.all'Address, Target_Exec_Ext_Ptr, Suffix_Length);
Strncpy
(Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length));
end if;
return Result;
@ -1107,9 +1091,6 @@ package body System.OS_Lib is
pragma Import
(C, Target_Object_Ext_Ptr, "__gnat_target_object_extension");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
Suffix_Length : Integer;
Result : String_Access;
@ -1118,7 +1099,8 @@ package body System.OS_Lib is
Result := new String (1 .. Suffix_Length);
if Suffix_Length > 0 then
Strncpy (Result.all'Address, Target_Object_Ext_Ptr, Suffix_Length);
Strncpy
(Result.all'Address, Target_Object_Ext_Ptr, size_t (Suffix_Length));
end if;
return Result;
@ -1132,9 +1114,6 @@ package body System.OS_Lib is
procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
pragma Import (C, Strncpy, "strncpy");
Env_Value_Ptr : aliased Address;
Env_Value_Length : aliased Integer;
F_Name : aliased String (1 .. Name'Length + 1);
@ -1150,7 +1129,8 @@ package body System.OS_Lib is
Result := new String (1 .. Env_Value_Length);
if Env_Value_Length > 0 then
Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
Strncpy
(Result.all'Address, Env_Value_Ptr, size_t (Env_Value_Length));
end if;
return Result;
@ -1456,9 +1436,6 @@ package body System.OS_Lib is
function Locate_Exec_On_Path (C_Exec_Name : Address) return Address;
pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path");
procedure Free (Ptr : System.Address);
pragma Import (C, Free, "free");
C_Exec_Name : String (1 .. Exec_Name'Length + 1);
Path_Addr : Address;
Path_Len : Integer;
@ -1476,7 +1453,7 @@ package body System.OS_Lib is
else
Result := To_Path_String_Access (Path_Addr, Path_Len);
Free (Path_Addr);
CRTL.free (Path_Addr);
-- Always return an absolute path name
@ -1506,9 +1483,6 @@ package body System.OS_Lib is
(C_File_Name, Path_Val : Address) return Address;
pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file");
procedure Free (Ptr : System.Address);
pragma Import (C, Free, "free");
Path_Addr : Address;
Path_Len : Integer;
Result : String_Access;
@ -1522,7 +1496,7 @@ package body System.OS_Lib is
else
Result := To_Path_String_Access (Path_Addr, Path_Len);
Free (Path_Addr);
CRTL.free (Path_Addr);
return Result;
end if;
end Locate_Regular_File;