+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
s-conca9$(objext) \
s-crc32$(objext) \
s-crtl$(objext) \
- s-crtrun$(objext) \
s-diflio$(objext) \
s-dim$(objext) \
s-diinio$(objext) \
-- --
------------------------------------------------------------------------------
-with System;
+with System.CRTL;
with Interfaces.C.Strings;
with Ada.Unchecked_Deallocation;
-----------
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);
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
-- --
-- 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- --
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;
-- 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
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;
-----------------
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);
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;
------------------
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;
---------------------
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 --
-------------------
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;
----------
-- --
-- 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- --
-- --
-- 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- --
-- --
-- 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- --
-- 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;
-- --
-- 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- --
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".
-- --
-- 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- --
-- 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;
-- --
-- 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- --
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".
-- --
-- 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- --
-- 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;
-- --
-- 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- --
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".
-- --
-- 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- --
-- 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 ???
-- 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;
-- --
-- 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- --
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".
-- --
-- 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- --
-- 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)
--------------------------
--------------------------
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;
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");
+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- 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;
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;
-- 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;
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
-- 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;
-- 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;
--------------
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;
--------------
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.
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.
-----------
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;
---------------
-------------
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);
----------------------
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
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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);
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;
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;
else
Result := To_Path_String_Access (Path_Addr, Path_Len);
- Free (Path_Addr);
+ CRTL.free (Path_Addr);
-- Always return an absolute path name
(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;
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;
projects / thirdparty / gcc.git / commitdiff
