+2017-01-12 Tristan Gingold <gingold@adacore.com>
+
+ * s-mmap.ads, s-mmap.adb, s-mmosin-unix.ads, s-mmosin-unix.adb,
+ s-mmauni-long.ads, s-mmosin-mingw.ads, s-mmosin-mingw.adb: New files.
+
+2017-01-12 Yannick Moy <moy@adacore.com>
+
+ * errout.adb, errout.ads (Initialize): Factor common treatment
+ in Reset_Warnings.
+ (Reset_Warnings): New procedure to reset counts related to warnings.
+ (Record_Compilation_Errors): New variable to store the presence of an
+ error, used in gnat2why to allow changing the Warning_Mode.
+ (Compilation_Errors): Use new variable Record_Compilation_Errors to
+ store the presence of an error.
+
+2017-01-12 Javier Miranda <miranda@adacore.com>
+
+ * sem_ch13.adb (Analyze_Aspect_Specifications):
+ For Interrupt_Handler and Attach_ Handler aspects, decorate the
+ internally built reference to the protected procedure as coming
+ from sources and force its analysis.
+
+2017-01-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch3.adb (Build_Derived_Type): For a scalar derived type,
+ inherit predicates if any from the first_subtype of the parent,
+ not from the anonymous parent type.
+ * sem_eval.adb (Is_Static_Subtype): A type that inherits a dynamic
+ predicate is not a static subtype.
+
+2017-01-12 Gary Dismukes <dismukes@adacore.com>
+
+ * freeze.adb (Check_Suspicious_Convention): New procedure
+ performing a warning check on discriminated record types with
+ convention C or C++. Factored out of procedure Freeze_Record_Type,
+ and changed to only apply to base types (to avoid spurious
+ warnings on subtypes). Minor improvement of warning messages
+ to refer to discriminated rather than variant record types.
+ (Freeze_Record_Type): Remove code for performing a suspicious
+ convention check.
+ (Freeze_Entity): Only call Freeze_Record_Type
+ on types that aren't declared within any enclosing generic units
+ (rather than just excluding the type when the innermost scope
+ is generic). Call Check_Suspicious_Convention whether or not
+ the type is declared within a generic unit.
+ * sem_ch8.adb (In_Generic_Scope): Move this function to Sem_Util.
+ * sem_util.ads, sem_util.adb (In_Generic_Scope): New function (moved
+ from Sem_Ch8).
+
+2017-01-12 Tristan Gingold <gingold@adacore.com>
+
+ * sysdep.c, adaint.c, rtinit.c, ming32.h:
+ (__gnat_current_codepage): Renamed from CurrentCodePage
+ (__gnat_current_ccs_encoding): Renamed from CurrentCCSEncoding
+
+2017-01-12 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch6.adb (Fully_Conformant_Expressions): Handle properly
+ quantified expressions, following AI12-050: the loop parameters
+ of two quantified expressions are conformant if they have the
+ same identifier.
+
2017-01-12 Arnaud Charlet <charlet@adacore.com>
* gcc-interface/Makefile.in: Clean up VxWorks targets.
#include "mingw32.h"
/* Current code page and CCS encoding to use, set in initialize.c. */
-UINT CurrentCodePage;
-UINT CurrentCCSEncoding;
+UINT __gnat_current_codepage;
+UINT __gnat_current_ccs_encoding;
#include <sys/utime.h>
Finalize_Called : Boolean := False;
-- Set True if the Finalize routine has been called
+ Record_Compilation_Errors : Boolean := False;
+ -- Record that a compilation error was witnessed during a given phase of
+ -- analysis for gnat2why. This is needed as Warning_Mode is modified twice
+ -- in gnat2why, hence Erroutc.Compilation_Errors can only return a suitable
+ -- value for each phase of analysis separately. This is updated at each
+ -- call to Compilation_Errors.
+
Warn_On_Instance : Boolean;
-- Flag set true for warning message to be posted on instance
begin
if not Finalize_Called then
raise Program_Error;
+
+ -- Record that a compilation error was witnessed during a given phase of
+ -- analysis for gnat2why. This is needed as Warning_Mode is modified
+ -- twice in gnat2why, hence Erroutc.Compilation_Errors can only return a
+ -- suitable value for each phase of analysis separately.
+
else
- return Erroutc.Compilation_Errors;
+ Record_Compilation_Errors := Record_Compilation_Errors or else
+ Erroutc.Compilation_Errors;
+
+ return Record_Compilation_Errors;
end if;
end Compilation_Errors;
Last_Error_Msg := No_Error_Msg;
Serious_Errors_Detected := 0;
Total_Errors_Detected := 0;
- Warnings_Treated_As_Errors := 0;
- Warnings_Detected := 0;
- Info_Messages := 0;
- Warnings_As_Errors_Count := 0;
Cur_Msg := No_Error_Msg;
List_Pragmas.Init;
+ -- Reset counts for warnings
+
+ Reset_Warnings;
+
-- Initialize warnings tables
Warnings.Init;
end if;
end Remove_Warning_Messages;
+ --------------------
+ -- Reset_Warnings --
+ --------------------
+
+ procedure Reset_Warnings is
+ begin
+ Warnings_Treated_As_Errors := 0;
+ Warnings_Detected := 0;
+ Info_Messages := 0;
+ Warnings_As_Errors_Count := 0;
+ end Reset_Warnings;
+
----------------------
-- Adjust_Name_Case --
----------------------
-- Remove warnings on all elements of a list (Calls Remove_Warning_Messages
-- on each element of the list, see above).
+ procedure Reset_Warnings;
+ -- Reset the counts related to warnings. This is used both to initialize
+ -- these counts and to reset them after each phase of analysis for a given
+ -- value of Opt.Warning_Mode in gnat2why.
+
procedure Set_Ignore_Errors (To : Boolean);
-- Following a call to this procedure with To=True, all error calls are
-- ignored. A call with To=False restores the default treatment in which
function Compilation_Errors return Boolean;
-- Returns True if errors have been detected, or warnings in -gnatwe (treat
-- warnings as errors) mode. Note that it is mandatory to call Finalize
- -- before calling this routine. Always returns False in formal verification
- -- mode, because errors issued when analyzing code are not compilation
- -- errors, and should not result in exiting with an error status.
+ -- before calling this routine. To account for changes to Warning_Mode in
+ -- gnat2why between phases, the past or current presence of an error is
+ -- recorded in a global variable at each call.
procedure Error_Msg_CRT (Feature : String; N : Node_Id);
-- Posts a non-fatal message on node N saying that the feature identified
-- which is the current instance type can only be applied when the type
-- is limited.
+ procedure Check_Suspicious_Convention (Rec_Type : Entity_Id);
+ -- Give a warning for pragma Convention with language C or C++ applied
+ -- to a discriminated record type. This is suppressed for the unchecked
+ -- union case, since the whole point in this case is interface C. We
+ -- also do not generate this within instantiations, since we will have
+ -- generated a message on the template.
+
procedure Check_Suspicious_Modulus (Utype : Entity_Id);
-- Give warning for modulus of 8, 16, 32, or 64 given as an explicit
-- integer literal without an explicit corresponding size clause. The
end if;
end Check_Current_Instance;
+ ---------------------------------
+ -- Check_Suspicious_Convention --
+ ---------------------------------
+
+ procedure Check_Suspicious_Convention (Rec_Type : Entity_Id) is
+ begin
+ if Has_Discriminants (Rec_Type)
+ and then Is_Base_Type (Rec_Type)
+ and then not Is_Unchecked_Union (Rec_Type)
+ and then (Convention (Rec_Type) = Convention_C
+ or else
+ Convention (Rec_Type) = Convention_CPP)
+ and then Comes_From_Source (Rec_Type)
+ and then not In_Instance
+ and then not Has_Warnings_Off (Rec_Type)
+ then
+ declare
+ Cprag : constant Node_Id :=
+ Get_Rep_Pragma (Rec_Type, Name_Convention);
+ A2 : Node_Id;
+
+ begin
+ if Present (Cprag) then
+ A2 := Next (First (Pragma_Argument_Associations (Cprag)));
+
+ if Convention (Rec_Type) = Convention_C then
+ Error_Msg_N
+ ("?x?discriminated record has no direct " &
+ "equivalent in C",
+ A2);
+ else
+ Error_Msg_N
+ ("?x?discriminated record has no direct " &
+ "equivalent in C++",
+ A2);
+ end if;
+
+ Error_Msg_NE
+ ("\?x?use of convention for type& is dubious",
+ A2, Rec_Type);
+ end if;
+ end;
+ end if;
+ end Check_Suspicious_Convention;
+
------------------------------
-- Check_Suspicious_Modulus --
------------------------------
end loop;
end if;
- -- Generate warning for applying C or C++ convention to a record
- -- with discriminants. This is suppressed for the unchecked union
- -- case, since the whole point in this case is interface C. We also
- -- do not generate this within instantiations, since we will have
- -- generated a message on the template.
-
- if Has_Discriminants (E)
- and then not Is_Unchecked_Union (E)
- and then (Convention (E) = Convention_C
- or else
- Convention (E) = Convention_CPP)
- and then Comes_From_Source (E)
- and then not In_Instance
- and then not Has_Warnings_Off (E)
- and then not Has_Warnings_Off (Base_Type (E))
- then
- declare
- Cprag : constant Node_Id := Get_Rep_Pragma (E, Name_Convention);
- A2 : Node_Id;
-
- begin
- if Present (Cprag) then
- A2 := Next (First (Pragma_Argument_Associations (Cprag)));
-
- if Convention (E) = Convention_C then
- Error_Msg_N
- ("?x?variant record has no direct equivalent in C",
- A2);
- else
- Error_Msg_N
- ("?x?variant record has no direct equivalent in C++",
- A2);
- end if;
-
- Error_Msg_NE
- ("\?x?use of convention for type& is dubious", A2, E);
- end if;
- end;
- end if;
-
-- See if Size is too small as is (and implicit packing might help)
if not Is_Packed (Rec)
-- for the case of a private type with record extension (we will do
-- that later when the full type is frozen).
- elsif Ekind_In (E, E_Record_Type, E_Record_Subtype)
- and then not (Present (Scope (E))
- and then Is_Generic_Unit (Scope (E)))
- then
- Freeze_Record_Type (E);
+ elsif Ekind_In (E, E_Record_Type, E_Record_Subtype) then
+ if not In_Generic_Scope (E) then
+ Freeze_Record_Type (E);
+ end if;
+
+ -- Report a warning if a discriminated record base type has a
+ -- convention with language C or C++ applied to it. This check is
+ -- done even within generic scopes (but not in instantiations),
+ -- which is why we don't do it as part of Freeze_Record_Type.
+
+ Check_Suspicious_Convention (E);
-- For a concurrent type, freeze corresponding record type. This does
-- not correspond to any specific rule in the RM, but the record type
* *
* C Header File *
* *
- * Copyright (C) 2002-2014, Free Software Foundation, Inc. *
+ * Copyright (C) 2002-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- *
#ifdef GNAT_UNICODE_SUPPORT
-extern UINT CurrentCodePage;
-extern UINT CurrentCCSEncoding;
+extern UINT __gnat_current_codepage;
+extern UINT __gnat_current_ccs_encoding;
-/* Macros to convert to/from the code page specified in CurrentCodePage. */
+/* Macros to convert to/from the code page specified in
+ __gnat_current_codepage. */
#define S2WSC(wstr,str,len) \
- MultiByteToWideChar (CurrentCodePage,0,str,-1,wstr,len)
+ MultiByteToWideChar (__gnat_current_codepage,0,str,-1,wstr,len)
#define WS2SC(str,wstr,len) \
- WideCharToMultiByte (CurrentCodePage,0,wstr,-1,str,len,NULL,NULL)
+ WideCharToMultiByte (__gnat_current_codepage,0,wstr,-1,str,len,NULL,NULL)
/* Macros to convert to/from UTF-8 code page. */
#define S2WSU(wstr,str,len) \
char *codepage = getenv ("GNAT_CODE_PAGE");
/* Default code page is UTF-8. */
- CurrentCodePage = CP_UTF8;
+ __gnat_current_codepage = CP_UTF8;
if (codepage != NULL)
{
if (strcmp (codepage, "CP_ACP") == 0)
- CurrentCodePage = CP_ACP;
+ __gnat_current_codepage = CP_ACP;
else if (strcmp (codepage, "CP_UTF8") == 0)
- CurrentCodePage = CP_UTF8;
+ __gnat_current_codepage = CP_UTF8;
}
}
char *ccsencoding = getenv ("GNAT_CCS_ENCODING");
/* Default CCS Encoding. */
- CurrentCCSEncoding = _O_TEXT;
+ __gnat_current_ccs_encoding = _O_TEXT;
__gnat_wide_text_translation_required = 0;
if (ccsencoding != NULL)
{
if (strcmp (ccsencoding, "U16TEXT") == 0)
{
- CurrentCCSEncoding = _O_U16TEXT;
+ __gnat_current_ccs_encoding = _O_U16TEXT;
__gnat_wide_text_translation_required = 1;
}
else if (strcmp (ccsencoding, "TEXT") == 0)
{
- CurrentCCSEncoding = _O_TEXT;
+ __gnat_current_ccs_encoding = _O_TEXT;
__gnat_wide_text_translation_required = 0;
}
else if (strcmp (ccsencoding, "WTEXT") == 0)
{
- CurrentCCSEncoding = _O_WTEXT;
+ __gnat_current_ccs_encoding = _O_WTEXT;
__gnat_wide_text_translation_required = 1;
}
else if (strcmp (ccsencoding, "U8TEXT") == 0)
{
- CurrentCCSEncoding = _O_U8TEXT;
+ __gnat_current_ccs_encoding = _O_U8TEXT;
__gnat_wide_text_translation_required = 1;
}
}
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+with System.Strings; use System.Strings;
+
+with System.Mmap.OS_Interface; use System.Mmap.OS_Interface;
+
+package body System.Mmap is
+
+ type Mapped_File_Record is record
+ Current_Region : Mapped_Region;
+ -- The legacy API enables only one region to be mapped, directly
+ -- associated with the mapped file. This references this region.
+
+ File : System_File;
+ -- Underlying OS-level file
+ end record;
+
+ type Mapped_Region_Record is record
+ File : Mapped_File;
+ -- The file this region comes from. Be careful: for reading file, it is
+ -- valid to have it closed before one of its regions is free'd.
+
+ Write : Boolean;
+ -- Whether the file this region comes from is open for writing.
+
+ Data : Str_Access;
+ -- Unbounded access to the mapped content.
+
+ System_Offset : File_Size;
+ -- Position in the file of the first byte actually mapped in memory
+
+ User_Offset : File_Size;
+ -- Position in the file of the first byte requested by the user
+
+ System_Size : File_Size;
+ -- Size of the region actually mapped in memory
+
+ User_Size : File_Size;
+ -- Size of the region requested by the user
+
+ Mapped : Boolean;
+ -- Whether this region is actually memory mapped
+
+ Mutable : Boolean;
+ -- If the file is opened for reading, wheter this region is writable
+
+ Buffer : System.Strings.String_Access;
+ -- When this region is not actually memory mapped, contains the
+ -- requested bytes.
+
+ Mapping : System_Mapping;
+ -- Underlying OS-level data for the mapping, if any
+ end record;
+
+ Invalid_Mapped_Region_Record : constant Mapped_Region_Record :=
+ (null, False, null, 0, 0, 0, 0, False, False, null,
+ Invalid_System_Mapping);
+ Invalid_Mapped_File_Record : constant Mapped_File_Record :=
+ (Invalid_Mapped_Region, Invalid_System_File);
+
+ Empty_String : constant String := "";
+ -- Used to provide a valid empty Data for empty files, for instanc.
+
+ procedure Dispose is new Ada.Unchecked_Deallocation
+ (Mapped_File_Record, Mapped_File);
+ procedure Dispose is new Ada.Unchecked_Deallocation
+ (Mapped_Region_Record, Mapped_Region);
+
+ function Convert is new Ada.Unchecked_Conversion
+ (Standard.System.Address, Str_Access);
+
+ procedure Compute_Data (Region : Mapped_Region);
+ -- Fill the Data field according to system and user offsets. The region
+ -- must actually be mapped or bufferized.
+
+ procedure From_Disk (Region : Mapped_Region);
+ -- Read a region of some file from the disk
+
+ procedure To_Disk (Region : Mapped_Region);
+ -- Write the region of the file back to disk if necessary, and free memory
+
+ ---------------
+ -- Open_Read --
+ ---------------
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File
+ is
+ File : constant System_File :=
+ Open_Read (Filename, Use_Mmap_If_Available);
+ begin
+ return new Mapped_File_Record'
+ (Current_Region => Invalid_Mapped_Region,
+ File => File);
+ end Open_Read;
+
+ ----------------
+ -- Open_Write --
+ ----------------
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File
+ is
+ File : constant System_File :=
+ Open_Write (Filename, Use_Mmap_If_Available);
+ begin
+ return new Mapped_File_Record'
+ (Current_Region => Invalid_Mapped_Region,
+ File => File);
+ end Open_Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out Mapped_File) is
+ begin
+ -- Closing a closed file is allowed and should do nothing
+
+ if File = Invalid_Mapped_File then
+ return;
+ end if;
+
+ if File.Current_Region /= null then
+ Free (File.Current_Region);
+ end if;
+
+ if File.File /= Invalid_System_File then
+ Close (File.File);
+ end if;
+
+ Dispose (File);
+ end Close;
+
+ ----------
+ -- Free --
+ ----------
+
+ procedure Free (Region : in out Mapped_Region) is
+ Ignored : Integer;
+ pragma Unreferenced (Ignored);
+ begin
+ -- Freeing an already free'd file is allowed and should do nothing
+
+ if Region = Invalid_Mapped_Region then
+ return;
+ end if;
+
+ if Region.Mapping /= Invalid_System_Mapping then
+ Dispose_Mapping (Region.Mapping);
+ end if;
+ To_Disk (Region);
+ Dispose (Region);
+ end Free;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (File : Mapped_File;
+ Region : in out Mapped_Region;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False)
+ is
+ File_Length : constant File_Size := Mmap.Length (File);
+
+ Req_Offset : constant File_Size := Offset;
+ Req_Length : File_Size := Length;
+ -- Offset and Length of the region to map, used to adjust mapping
+ -- bounds, reflecting what the user will see.
+
+ Region_Allocated : Boolean := False;
+ begin
+ -- If this region comes from another file, or simply if the file is
+ -- writeable, we cannot re-use this mapping: free it first.
+
+ if Region /= Invalid_Mapped_Region
+ and then
+ (Region.File /= File or else File.File.Write)
+ then
+ Free (Region);
+ end if;
+
+ if Region = Invalid_Mapped_Region then
+ Region := new Mapped_Region_Record'(Invalid_Mapped_Region_Record);
+ Region_Allocated := True;
+ end if;
+
+ Region.File := File;
+
+ if Req_Offset >= File_Length then
+ -- If the requested offset goes beyond file size, map nothing
+
+ Req_Length := 0;
+
+ elsif Length = 0
+ or else
+ Length > File_Length - Req_Offset
+ then
+ -- If Length is 0 or goes beyond file size, map till end of file
+
+ Req_Length := File_Length - Req_Offset;
+
+ else
+ Req_Length := Length;
+ end if;
+
+ -- Past this point, the offset/length the user will see is fixed. On the
+ -- other hand, the system offset/length is either already defined, from
+ -- a previous mapping, or it is set to 0. In the latter case, the next
+ -- step will set them according to the mapping.
+
+ Region.User_Offset := Req_Offset;
+ Region.User_Size := Req_Length;
+
+ -- If the requested region is inside an already mapped region, adjust
+ -- user-requested data and do nothing else.
+
+ if (File.File.Write or else Region.Mutable = Mutable)
+ and then
+ Req_Offset >= Region.System_Offset
+ and then
+ (Req_Offset + Req_Length
+ <= Region.System_Offset + Region.System_Size)
+ then
+ Region.User_Offset := Req_Offset;
+ Compute_Data (Region);
+ return;
+
+ elsif Region.Buffer /= null then
+ -- Otherwise, as we are not going to re-use the buffer, free it
+
+ System.Strings.Free (Region.Buffer);
+ Region.Buffer := null;
+
+ elsif Region.Mapping /= Invalid_System_Mapping then
+ -- Otherwise, there is a memory mapping that we need to unmap.
+ Dispose_Mapping (Region.Mapping);
+ end if;
+
+ -- mmap() will sometimes return NULL when the file exists but is empty,
+ -- which is not what we want, so in the case of a zero length file we
+ -- fall back to read(2)/write(2)-based mode.
+
+ if File_Length > 0 and then File.File.Mapped then
+
+ Region.System_Offset := Req_Offset;
+ Region.System_Size := Req_Length;
+ Create_Mapping
+ (File.File,
+ Region.System_Offset, Region.System_Size,
+ Mutable,
+ Region.Mapping);
+ Region.Mapped := True;
+ Region.Mutable := Mutable;
+
+ else
+ -- There is no alignment requirement when manually reading the file.
+
+ Region.System_Offset := Req_Offset;
+ Region.System_Size := Req_Length;
+ Region.Mapped := False;
+ Region.Mutable := True;
+ From_Disk (Region);
+ end if;
+
+ Region.Write := File.File.Write;
+ Compute_Data (Region);
+
+ exception
+ when others =>
+ -- Before propagating any exception, free any region we allocated
+ -- here.
+
+ if Region_Allocated then
+ Dispose (Region);
+ end if;
+ raise;
+ end Read;
+
+ ----------
+ -- Read --
+ ----------
+
+ procedure Read
+ (File : Mapped_File;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False)
+ is
+ begin
+ Read (File, File.Current_Region, Offset, Length, Mutable);
+ end Read;
+
+ ----------
+ -- Read --
+ ----------
+
+ function Read
+ (File : Mapped_File;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False) return Mapped_Region
+ is
+ Region : Mapped_Region := Invalid_Mapped_Region;
+ begin
+ Read (File, Region, Offset, Length, Mutable);
+ return Region;
+ end Read;
+
+ ------------
+ -- Length --
+ ------------
+
+ function Length (File : Mapped_File) return File_Size is
+ begin
+ return File.File.Length;
+ end Length;
+
+ ------------
+ -- Offset --
+ ------------
+
+ function Offset (Region : Mapped_Region) return File_Size is
+ begin
+ return Region.User_Offset;
+ end Offset;
+
+ ------------
+ -- Offset --
+ ------------
+
+ function Offset (File : Mapped_File) return File_Size is
+ begin
+ return Offset (File.Current_Region);
+ end Offset;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (Region : Mapped_Region) return Integer is
+ begin
+ return Integer (Region.User_Size);
+ end Last;
+
+ ----------
+ -- Last --
+ ----------
+
+ function Last (File : Mapped_File) return Integer is
+ begin
+ return Last (File.Current_Region);
+ end Last;
+
+ -------------------
+ -- To_Str_Access --
+ -------------------
+
+ function To_Str_Access
+ (Str : System.Strings.String_Access) return Str_Access is
+ begin
+ if Str = null then
+ return null;
+ else
+ return Convert (Str.all'Address);
+ end if;
+ end To_Str_Access;
+
+ ----------
+ -- Data --
+ ----------
+
+ function Data (Region : Mapped_Region) return Str_Access is
+ begin
+ return Region.Data;
+ end Data;
+
+ ----------
+ -- Data --
+ ----------
+
+ function Data (File : Mapped_File) return Str_Access is
+ begin
+ return Data (File.Current_Region);
+ end Data;
+
+ ----------------
+ -- Is_Mutable --
+ ----------------
+
+ function Is_Mutable (Region : Mapped_Region) return Boolean is
+ begin
+ return Region.Mutable or Region.Write;
+ end Is_Mutable;
+
+ ----------------
+ -- Is_Mmapped --
+ ----------------
+
+ function Is_Mmapped (File : Mapped_File) return Boolean is
+ begin
+ return File.File.Mapped;
+ end Is_Mmapped;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ function Get_Page_Size return Integer is
+ Result : constant File_Size := Get_Page_Size;
+ begin
+ return Integer (Result);
+ end Get_Page_Size;
+
+ ---------------------
+ -- Read_Whole_File --
+ ---------------------
+
+ function Read_Whole_File
+ (Filename : String;
+ Empty_If_Not_Found : Boolean := False)
+ return System.Strings.String_Access
+ is
+ File : Mapped_File := Open_Read (Filename);
+ Region : Mapped_Region renames File.Current_Region;
+ Result : String_Access;
+ begin
+ Read (File);
+
+ if Region.Data /= null then
+ Result := new String'(String
+ (Region.Data (1 .. Last (Region))));
+
+ elsif Region.Buffer /= null then
+ Result := Region.Buffer;
+ Region.Buffer := null; -- So that it is not deallocated
+ end if;
+
+ Close (File);
+
+ return Result;
+
+ exception
+ when Ada.IO_Exceptions.Name_Error =>
+ if Empty_If_Not_Found then
+ return new String'("");
+ else
+ return null;
+ end if;
+
+ when others =>
+ Close (File);
+ return null;
+ end Read_Whole_File;
+
+ ---------------
+ -- From_Disk --
+ ---------------
+
+ procedure From_Disk (Region : Mapped_Region) is
+ begin
+ pragma Assert (Region.File.all /= Invalid_Mapped_File_Record);
+ pragma Assert (Region.Buffer = null);
+
+ Region.Buffer := Read_From_Disk
+ (Region.File.File, Region.User_Offset, Region.User_Size);
+ Region.Mapped := False;
+ end From_Disk;
+
+ -------------
+ -- To_Disk --
+ -------------
+
+ procedure To_Disk (Region : Mapped_Region) is
+ begin
+ if Region.Write and then Region.Buffer /= null then
+ pragma Assert (Region.File.all /= Invalid_Mapped_File_Record);
+ Write_To_Disk
+ (Region.File.File,
+ Region.User_Offset, Region.User_Size,
+ Region.Buffer);
+ end if;
+
+ System.Strings.Free (Region.Buffer);
+ Region.Buffer := null;
+ end To_Disk;
+
+ ------------------
+ -- Compute_Data --
+ ------------------
+
+ procedure Compute_Data (Region : Mapped_Region) is
+ Base_Data : Str_Access;
+ -- Address of the first byte actually mapped in memory
+
+ Data_Shift : constant Integer :=
+ Integer (Region.User_Offset - Region.System_Offset);
+ begin
+ if Region.User_Size = 0 then
+ Region.Data := Convert (Empty_String'Address);
+ return;
+ elsif Region.Mapped then
+ Base_Data := Convert (Region.Mapping.Address);
+ else
+ Base_Data := Convert (Region.Buffer.all'Address);
+ end if;
+ Region.Data := Convert (Base_Data (Data_Shift + 1)'Address);
+ end Compute_Data;
+
+end System.Mmap;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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 memory mapping of files. Depending on your operating
+-- system, this might provide a more efficient method for accessing the
+-- contents of files.
+-- A description of memory-mapping is available on the sqlite page, at:
+-- http://www.sqlite.org/mmap.html
+--
+-- The traditional method for reading a file is to allocate a buffer in the
+-- application address space, then open the file and copy its contents. When
+-- memory mapping is available though, the application asks the operating
+-- system to return a pointer to the requested page, if possible. If the
+-- requested page has been or can be mapped into the application address
+-- space, the system returns a pointer to that page for the application to
+-- use without having to copy anything. Skipping the copy step is what makes
+-- memory mapped I/O faster.
+--
+-- When memory mapping is not available, this package automatically falls
+-- back to the traditional copy method.
+--
+-- Example of use for this package, when reading a file that can be fully
+-- mapped
+--
+-- declare
+-- File : Mapped_File;
+-- Str : Str_Access;
+-- begin
+-- File := Open_Read ("/tmp/file_on_disk");
+-- Read (File); -- read the whole file
+-- Str := Data (File);
+-- for S in 1 .. Last (File) loop
+-- Put (Str (S));
+-- end loop;
+-- Close (File);
+-- end;
+--
+-- When the file is big, or you only want to access part of it at a given
+-- time, you can use the following type of code.
+
+-- declare
+-- File : Mapped_File;
+-- Str : Str_Access;
+-- Offs : File_Size := 0;
+-- Page : constant Integer := Get_Page_Size;
+-- begin
+-- File := Open_Read ("/tmp/file_on_disk");
+-- while Offs < Length (File) loop
+-- Read (File, Offs, Length => Long_Integer (Page) * 4);
+-- Str := Data (File);
+--
+-- -- Print characters for this chunk:
+-- for S in Integer (Offs - Offset (File)) + 1 .. Last (File) loop
+-- Put (Str (S));
+-- end loop;
+--
+-- -- Since we are reading multiples of Get_Page_Size, we can simplify
+-- -- with
+-- -- for S in 1 .. Last (File) loop ...
+--
+-- Offs := Offs + Long_Integer (Last (File));
+-- end loop;
+
+with Interfaces.C;
+
+with System.Strings;
+
+package System.Mmap is
+
+ type Mapped_File is private;
+ -- File to be mapped in memory.
+
+ -- This package will use the fastest possible algorithm to load the
+ -- file in memory. On systems that support it, the file is not really
+ -- loaded in memory. Instead, a call to the mmap() system call (or
+ -- CreateFileMapping()) will keep the file on disk, but make it
+ -- accessible as if it was in memory.
+
+ -- When the system does not support it, the file is actually loaded in
+ -- memory through calls to read(), and written back with write() when you
+ -- close it. This is of course much slower.
+
+ -- Legacy: each mapped file has a "default" mapped region in it.
+
+ type Mapped_Region is private;
+ -- A representation of part of a file in memory. Actual reading/writing
+ -- is done through a mapped region. After being returned by Read, a mapped
+ -- region must be free'd when done. If the original Mapped_File was open
+ -- for reading, it can be closed before the mapped region is free'd.
+
+ Invalid_Mapped_File : constant Mapped_File;
+ Invalid_Mapped_Region : constant Mapped_Region;
+
+ type Unconstrained_String is new String (Positive);
+ type Str_Access is access all Unconstrained_String;
+ pragma No_Strict_Aliasing (Str_Access);
+
+ type File_Size is new Interfaces.C.size_t;
+
+ function To_Str_Access
+ (Str : System.Strings.String_Access) return Str_Access;
+ -- Convert Str. The returned value points to the same memory block, but no
+ -- longer includes the bounds, which you need to manage yourself
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File;
+ -- Open a file for reading. The same file can be shared by multiple
+ -- processes, that will see each others's changes as they occur.
+ -- Any attempt to write the data might result in a segmentation fault,
+ -- depending on how the file is open.
+ -- Name_Error is raised if the file does not exist.
+ -- Filename should be compatible with the filesystem.
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return Mapped_File;
+ -- Open a file for writing.
+ -- You cannot change the length of the file.
+ -- Name_Error is raised if the file does not exist
+ -- Filename should be compatible with the filesystem.
+
+ procedure Close (File : in out Mapped_File);
+ -- Close the file, and unmap the memory that is used for the region
+ -- contained in File. If the system does not support the unmmap() system
+ -- call or equivalent, or these were not available for the file itself,
+ -- then the file is written back to the disk if it was opened for writing.
+
+ procedure Free (Region : in out Mapped_Region);
+ -- Unmap the memory that is used for this region and deallocate the region
+
+ procedure Read
+ (File : Mapped_File;
+ Region : in out Mapped_Region;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False);
+ -- Read a specific part of File and set Region to the corresponding mapped
+ -- region, or re-use it if possible.
+ -- Offset is the number of bytes since the beginning of the file at which
+ -- we should start reading. Length is the number of bytes that should be
+ -- read. If set to 0, as much of the file as possible is read (presumably
+ -- the whole file unless you are reading a _huge_ file).
+ -- Note that no (un)mapping is is done if that part of the file is already
+ -- available through Region.
+ -- If the file was opened for writing, any modification you do to the
+ -- data stored in File will be stored on disk (either immediately when the
+ -- file is opened through a mmap() system call, or when the file is closed
+ -- otherwise).
+ -- Mutable is processed only for reading files. If set to True, the
+ -- data can be modified, even through it will not be carried through the
+ -- underlying file, nor it is guaranteed to be carried through remapping.
+ -- This function takes care of page size alignment issues. The accessors
+ -- below only expose the region that has been requested by this call, even
+ -- if more bytes were actually mapped by this function.
+ -- TODO??? Enable to have a private copy for readable files
+
+ function Read
+ (File : Mapped_File;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False) return Mapped_Region;
+ -- Likewise, return a new mapped region
+
+ procedure Read
+ (File : Mapped_File;
+ Offset : File_Size := 0;
+ Length : File_Size := 0;
+ Mutable : Boolean := False);
+ -- Likewise, use the legacy "default" region in File
+
+ function Length (File : Mapped_File) return File_Size;
+ -- Size of the file on the disk
+
+ function Offset (Region : Mapped_Region) return File_Size;
+ -- Return the offset, in the physical file on disk, corresponding to the
+ -- requested mapped region. The first byte in the file has offest 0.
+
+ function Offset (File : Mapped_File) return File_Size;
+ -- Likewise for the region contained in File
+
+ function Last (Region : Mapped_Region) return Integer;
+ -- Return the number of requested bytes mapped in this region. It is
+ -- erroneous to access Data for indices outside 1 .. Last (Region).
+ -- Such accesses may cause Storage_Error to be raised.
+
+ function Last (File : Mapped_File) return Integer;
+ -- Return the number of requested bytes mapped in the region contained in
+ -- File. It is erroneous to access Data for indices outside of 1 .. Last
+ -- (File); such accesses may cause Storage_Error to be raised.
+
+ function Data (Region : Mapped_Region) return Str_Access;
+ -- The data mapped in Region as requested. The result is an unconstrained
+ -- string, so you cannot use the usual 'First and 'Last attributes.
+ -- Instead, these are respectively 1 and Size.
+
+ function Data (File : Mapped_File) return Str_Access;
+ -- Likewise for the region contained in File
+
+ function Is_Mutable (Region : Mapped_Region) return Boolean;
+ -- Return whether it is safe to change bytes in Data (Region). This is true
+ -- for regions from writeable files, for regions mapped with the "Mutable"
+ -- flag set, and for regions that are copied in a buffer. Note that it is
+ -- not specified whether empty regions are mutable or not, since there is
+ -- no byte no modify.
+
+ function Is_Mmapped (File : Mapped_File) return Boolean;
+ -- Whether regions for this file are opened through an mmap() system call
+ -- or equivalent. This is in general irrelevant to your application, unless
+ -- the file can be accessed by multiple concurrent processes or tasks. In
+ -- such a case, and if the file is indeed mmap-ed, then the various parts
+ -- of the file can be written simulatenously, and thus you cannot ensure
+ -- the integrity of the file. If the file is not mmapped, the latest
+ -- process to Close it overwrite what other processes have done.
+
+ function Get_Page_Size return Integer;
+ -- Returns the number of bytes in a page. Once a file is mapped from the
+ -- disk, its offset and Length should be multiples of this page size (which
+ -- is ensured by this package in any case). Knowing this page size allows
+ -- you to map as much memory as possible at once, thus potentially reducing
+ -- the number of system calls to read the file by chunks.
+
+ function Read_Whole_File
+ (Filename : String;
+ Empty_If_Not_Found : Boolean := False)
+ return System.Strings.String_Access;
+ -- Returns the whole contents of the file.
+ -- The returned string must be freed by the user.
+ -- This is a convenience function, which is of course slower than the ones
+ -- above since we also need to allocate some memory, actually read the file
+ -- and copy the bytes.
+ -- If the file does not exist, null is returned. However, if
+ -- Empty_If_Not_Found is True, then the empty string is returned instead.
+ -- Filename should be compatible with the filesystem.
+
+private
+ pragma Inline (Data, Length, Last, Offset, Is_Mmapped, To_Str_Access);
+
+ type Mapped_File_Record;
+ type Mapped_File is access Mapped_File_Record;
+
+ type Mapped_Region_Record;
+ type Mapped_Region is access Mapped_Region_Record;
+
+ Invalid_Mapped_File : constant Mapped_File := null;
+ Invalid_Mapped_Region : constant Mapped_Region := null;
+
+end System.Mmap;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . U N I X --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- Declaration of off_t/mmap/munmap. This particular implementation
+-- supposes off_t is long.
+
+with System.OS_Lib;
+with Interfaces.C;
+
+package System.Mmap.Unix is
+
+ type Mmap_Prot is new Interfaces.C.int;
+-- PROT_NONE : constant Mmap_Prot := 16#00#;
+-- PROT_EXEC : constant Mmap_Prot := 16#04#;
+ PROT_READ : constant Mmap_Prot := 16#01#;
+ PROT_WRITE : constant Mmap_Prot := 16#02#;
+
+ type Mmap_Flags is new Interfaces.C.int;
+-- MAP_NONE : constant Mmap_Flags := 16#00#;
+-- MAP_FIXED : constant Mmap_Flags := 16#10#;
+ MAP_SHARED : constant Mmap_Flags := 16#01#;
+ MAP_PRIVATE : constant Mmap_Flags := 16#02#;
+
+ type off_t is new Long_Integer;
+
+ function Mmap (Start : Address := Null_Address;
+ Length : Interfaces.C.size_t;
+ Prot : Mmap_Prot := PROT_READ;
+ Flags : Mmap_Flags := MAP_PRIVATE;
+ Fd : System.OS_Lib.File_Descriptor;
+ Offset : off_t) return Address;
+ pragma Import (C, Mmap, "mmap");
+
+ function Munmap (Start : Address;
+ Length : Interfaces.C.size_t) return Integer;
+ pragma Import (C, Munmap, "munmap");
+
+ function Is_Mapping_Available return Boolean is (True);
+ -- Wheter memory mapping is actually available on this system. It is an
+ -- error to use Create_Mapping and Dispose_Mapping if this is False.
+end System.Mmap.Unix;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with System.Strings; use System.Strings;
+
+package body System.Mmap.OS_Interface is
+
+ use Win;
+
+ function Align
+ (Addr : File_Size) return File_Size;
+ -- Align some offset/length to the lowest page boundary
+
+ function Open_Common
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean;
+ Write : Boolean) return System_File;
+
+ function From_UTF8 (Path : String) return Wide_String;
+ -- Convert from UTF-8 to Wide_String
+
+ ---------------
+ -- From_UTF8 --
+ ---------------
+
+ function From_UTF8 (Path : String) return Wide_String is
+ function MultiByteToWideChar
+ (Codepage : Interfaces.C.unsigned;
+ Flags : Interfaces.C.unsigned;
+ Mbstr : Address;
+ Mb : Natural;
+ Wcstr : Address;
+ Wc : Natural) return Integer;
+ pragma Import (C, MultiByteToWideChar);
+
+ Current_Codepage : Interfaces.C.unsigned;
+ pragma Import (C, Current_Codepage, "__gnat_current_codepage");
+
+ Len : Natural;
+ begin
+ -- Compute length of the result
+ Len := MultiByteToWideChar
+ (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0);
+ if Len = 0 then
+ raise Constraint_Error;
+ end if;
+
+ declare
+ -- Declare result
+ Res : Wide_String (1 .. Len);
+ begin
+ -- And compute it
+ Len := MultiByteToWideChar
+ (Current_Codepage, 0,
+ Path'Address, Path'Length,
+ Res'Address, Len);
+ if Len = 0 then
+ raise Constraint_Error;
+ end if;
+ return Res;
+ end;
+ end From_UTF8;
+
+ -----------------
+ -- Open_Common --
+ -----------------
+
+ function Open_Common
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean;
+ Write : Boolean) return System_File
+ is
+ dwDesiredAccess, dwShareMode : DWORD;
+ PageFlags : DWORD;
+
+ W_Filename : constant Wide_String :=
+ From_UTF8 (Filename) & Wide_Character'Val (0);
+ File_Handle, Mapping_Handle : HANDLE;
+
+ SizeH : aliased DWORD;
+ Size : File_Size;
+ begin
+ if Write then
+ dwDesiredAccess := GENERIC_READ + GENERIC_WRITE;
+ dwShareMode := 0;
+ PageFlags := Win.PAGE_READWRITE;
+ else
+ dwDesiredAccess := GENERIC_READ;
+ dwShareMode := Win.FILE_SHARE_READ;
+ PageFlags := Win.PAGE_READONLY;
+ end if;
+
+ -- Actually open the file
+
+ File_Handle := CreateFile
+ (W_Filename'Address, dwDesiredAccess, dwShareMode,
+ null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0);
+
+ if File_Handle = Win.INVALID_HANDLE_VALUE then
+ raise Ada.IO_Exceptions.Name_Error
+ with "Cannot open " & Filename;
+ end if;
+
+ -- Compute its size
+
+ Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access));
+
+ if Size = Win.INVALID_FILE_SIZE then
+ raise Ada.IO_Exceptions.Use_Error;
+ end if;
+
+ if SizeH /= 0 and then File_Size'Size > 32 then
+ Size := Size + (File_Size (SizeH) * 2 ** 32);
+ end if;
+
+ -- Then create a mapping object, if needed. On Win32, file memory
+ -- mapping is always available.
+
+ if Use_Mmap_If_Available then
+ Mapping_Handle :=
+ Win.CreateFileMapping
+ (File_Handle, null, PageFlags,
+ 0, DWORD (Size), Standard.System.Null_Address);
+ else
+ Mapping_Handle := Win.INVALID_HANDLE_VALUE;
+ end if;
+
+ return
+ (Handle => File_Handle,
+ Mapped => Use_Mmap_If_Available,
+ Mapping_Handle => Mapping_Handle,
+ Write => Write,
+ Length => Size);
+ end Open_Common;
+
+ ---------------
+ -- Open_Read --
+ ---------------
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ begin
+ return Open_Common (Filename, Use_Mmap_If_Available, False);
+ end Open_Read;
+
+ ----------------
+ -- Open_Write --
+ ----------------
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ begin
+ return Open_Common (Filename, Use_Mmap_If_Available, True);
+ end Open_Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out System_File) is
+ Ignored : BOOL;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := CloseHandle (File.Mapping_Handle);
+ Ignored := CloseHandle (File.Handle);
+ File.Handle := Win.INVALID_HANDLE_VALUE;
+ File.Mapping_Handle := Win.INVALID_HANDLE_VALUE;
+ end Close;
+
+ --------------------
+ -- Read_From_Disk --
+ --------------------
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access
+ is
+ Buffer : String_Access := new String (1 .. Integer (Length));
+
+ Pos : DWORD;
+ NbRead : aliased DWORD;
+ pragma Unreferenced (Pos);
+ begin
+ Pos := Win.SetFilePointer
+ (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
+
+ if Win.ReadFile
+ (File.Handle, Buffer.all'Address,
+ DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE
+ then
+ System.Strings.Free (Buffer);
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ return Buffer;
+ end Read_From_Disk;
+
+ -------------------
+ -- Write_To_Disk --
+ -------------------
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access)
+ is
+ Pos : DWORD;
+ NbWritten : aliased DWORD;
+ pragma Unreferenced (Pos);
+ begin
+ pragma Assert (File.Write);
+ Pos := Win.SetFilePointer
+ (File.Handle, LONG (Offset), null, Win.FILE_BEGIN);
+
+ if Win.WriteFile
+ (File.Handle, Buffer.all'Address,
+ DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE
+ then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ end Write_To_Disk;
+
+ --------------------
+ -- Create_Mapping --
+ --------------------
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping)
+ is
+ Flags : DWORD;
+ begin
+ if File.Write then
+ Flags := Win.FILE_MAP_WRITE;
+ elsif Mutable then
+ Flags := Win.FILE_MAP_COPY;
+ else
+ Flags := Win.FILE_MAP_READ;
+ end if;
+
+ -- Adjust offset and mapping length to account for the required
+ -- alignment of offset on page boundary.
+
+ declare
+ Queried_Offset : constant File_Size := Offset;
+ begin
+ Offset := Align (Offset);
+
+ -- First extend the length to compensate the offset shift, then align
+ -- it on the upper page boundary, so that the whole queried area is
+ -- covered.
+
+ Length := Length + Queried_Offset - Offset;
+ Length := Align (Length + Get_Page_Size - 1);
+
+ -- But do not exceed the length of the file
+ if Offset + Length > File.Length then
+ Length := File.Length - Offset;
+ end if;
+ end;
+
+ if Length > File_Size (Integer'Last) then
+ raise Ada.IO_Exceptions.Device_Error;
+ else
+ Mapping := Invalid_System_Mapping;
+ Mapping.Address :=
+ Win.MapViewOfFile
+ (File.Mapping_Handle, Flags,
+ 0, DWORD (Offset), SIZE_T (Length));
+ Mapping.Length := Length;
+ end if;
+ end Create_Mapping;
+
+ ---------------------
+ -- Dispose_Mapping --
+ ---------------------
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping)
+ is
+ Ignored : BOOL;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := Win.UnmapViewOfFile (Mapping.Address);
+ Mapping := Invalid_System_Mapping;
+ end Dispose_Mapping;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ function Get_Page_Size return File_Size is
+ SystemInfo : aliased SYSTEM_INFO;
+ begin
+ GetSystemInfo (SystemInfo'Unchecked_Access);
+ return File_Size (SystemInfo.dwAllocationGranularity);
+ end Get_Page_Size;
+
+ -----------
+ -- Align --
+ -----------
+
+ function Align
+ (Addr : File_Size) return File_Size is
+ begin
+ return Addr - Addr mod Get_Page_Size;
+ end Align;
+
+end System.Mmap.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+-- OS pecularities abstraction package for Win32 systems.
+
+package System.Mmap.OS_Interface is
+
+ -- The Win package contains copy of definition found in recent System.Win32
+ -- unit provided with the GNAT compiler. The copy is needed to be able to
+ -- compile this unit with older compilers. Note that this internal Win
+ -- package can be removed when GNAT 6.1.0 is not supported anymore.
+
+ package Win is
+
+ subtype PVOID is Standard.System.Address;
+
+ type HANDLE is new Interfaces.C.ptrdiff_t;
+
+ type WORD is new Interfaces.C.unsigned_short;
+ type DWORD is new Interfaces.C.unsigned_long;
+ type LONG is new Interfaces.C.long;
+ type SIZE_T is new Interfaces.C.size_t;
+
+ type BOOL is new Interfaces.C.int;
+ for BOOL'Size use Interfaces.C.int'Size;
+
+ FALSE : constant := 0;
+
+ GENERIC_READ : constant := 16#80000000#;
+ GENERIC_WRITE : constant := 16#40000000#;
+ OPEN_EXISTING : constant := 3;
+
+ type OVERLAPPED is record
+ Internal : DWORD;
+ InternalHigh : DWORD;
+ Offset : DWORD;
+ OffsetHigh : DWORD;
+ hEvent : HANDLE;
+ end record;
+
+ type SECURITY_ATTRIBUTES is record
+ nLength : DWORD;
+ pSecurityDescriptor : PVOID;
+ bInheritHandle : BOOL;
+ end record;
+
+ type SYSTEM_INFO is record
+ dwOemId : DWORD;
+ dwPageSize : DWORD;
+ lpMinimumApplicationAddress : PVOID;
+ lpMaximumApplicationAddress : PVOID;
+ dwActiveProcessorMask : PVOID;
+ dwNumberOfProcessors : DWORD;
+ dwProcessorType : DWORD;
+ dwAllocationGranularity : DWORD;
+ wProcessorLevel : WORD;
+ wProcessorRevision : WORD;
+ end record;
+ type LP_SYSTEM_INFO is access all SYSTEM_INFO;
+
+ INVALID_HANDLE_VALUE : constant HANDLE := -1;
+ FILE_BEGIN : constant := 0;
+ FILE_SHARE_READ : constant := 16#00000001#;
+ FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#;
+ FILE_MAP_COPY : constant := 1;
+ FILE_MAP_READ : constant := 4;
+ FILE_MAP_WRITE : constant := 2;
+ PAGE_READONLY : constant := 16#0002#;
+ PAGE_READWRITE : constant := 16#0004#;
+ INVALID_FILE_SIZE : constant := 16#FFFFFFFF#;
+
+ function CreateFile
+ (lpFileName : Standard.System.Address;
+ dwDesiredAccess : DWORD;
+ dwShareMode : DWORD;
+ lpSecurityAttributes : access SECURITY_ATTRIBUTES;
+ dwCreationDisposition : DWORD;
+ dwFlagsAndAttributes : DWORD;
+ hTemplateFile : HANDLE) return HANDLE;
+ pragma Import (Stdcall, CreateFile, "CreateFileW");
+
+ function WriteFile
+ (hFile : HANDLE;
+ lpBuffer : Standard.System.Address;
+ nNumberOfBytesToWrite : DWORD;
+ lpNumberOfBytesWritten : access DWORD;
+ lpOverlapped : access OVERLAPPED) return BOOL;
+ pragma Import (Stdcall, WriteFile, "WriteFile");
+
+ function ReadFile
+ (hFile : HANDLE;
+ lpBuffer : Standard.System.Address;
+ nNumberOfBytesToRead : DWORD;
+ lpNumberOfBytesRead : access DWORD;
+ lpOverlapped : access OVERLAPPED) return BOOL;
+ pragma Import (Stdcall, ReadFile, "ReadFile");
+
+ function CloseHandle (hObject : HANDLE) return BOOL;
+ pragma Import (Stdcall, CloseHandle, "CloseHandle");
+
+ function GetFileSize
+ (hFile : HANDLE; lpFileSizeHigh : access DWORD) return DWORD;
+ pragma Import (Stdcall, GetFileSize, "GetFileSize");
+
+ function SetFilePointer
+ (hFile : HANDLE;
+ lDistanceToMove : LONG;
+ lpDistanceToMoveHigh : access LONG;
+ dwMoveMethod : DWORD) return DWORD;
+ pragma Import (Stdcall, SetFilePointer, "SetFilePointer");
+
+ function CreateFileMapping
+ (hFile : HANDLE;
+ lpSecurityAttributes : access SECURITY_ATTRIBUTES;
+ flProtect : DWORD;
+ dwMaximumSizeHigh : DWORD;
+ dwMaximumSizeLow : DWORD;
+ lpName : Standard.System.Address) return HANDLE;
+ pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingW");
+
+ function MapViewOfFile
+ (hFileMappingObject : HANDLE;
+ dwDesiredAccess : DWORD;
+ dwFileOffsetHigh : DWORD;
+ dwFileOffsetLow : DWORD;
+ dwNumberOfBytesToMap : SIZE_T) return Standard.System.Address;
+ pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile");
+
+ function UnmapViewOfFile
+ (lpBaseAddress : Standard.System.Address) return BOOL;
+ pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile");
+
+ procedure GetSystemInfo (lpSystemInfo : LP_SYSTEM_INFO);
+ pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo");
+
+ end Win;
+
+ type System_File is record
+ Handle : Win.HANDLE;
+
+ Mapped : Boolean;
+ -- Whether mapping is requested by the user and available on the system
+
+ Mapping_Handle : Win.HANDLE;
+
+ Write : Boolean;
+ -- Whether this file can be written to
+
+ Length : File_Size;
+ -- Length of the file. Used to know what can be mapped in the file
+ end record;
+
+ type System_Mapping is record
+ Address : Standard.System.Address;
+ Length : File_Size;
+ end record;
+
+ Invalid_System_File : constant System_File :=
+ (Win.INVALID_HANDLE_VALUE, False, Win.INVALID_HANDLE_VALUE, False, 0);
+ Invalid_System_Mapping : constant System_Mapping :=
+ (Standard.System.Null_Address, 0);
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Open a file for reading and return the corresponding System_File. Raise
+ -- a Ada.IO_Exceptions.Name_Error if unsuccessful.
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Likewise for writing to a file
+
+ procedure Close (File : in out System_File);
+ -- Close a system file
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access;
+ -- Read a fragment of a file. It is up to the caller to free the result
+ -- when done with it.
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access);
+ -- Write some content to a fragment of a file
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping);
+ -- Create a memory mapping for the given File, for the area starting at
+ -- Offset and containing Length bytes. Store it to Mapping.
+ -- Note that Offset and Length may be modified according to the system
+ -- needs (for boudaries, for instance). The caller must cope with actually
+ -- wider mapped areas.
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping);
+ -- Unmap a previously-created mapping
+
+ function Get_Page_Size return File_Size;
+ -- Return the number of bytes in a system page.
+
+end System.Mmap.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- B o d y --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+with Ada.IO_Exceptions;
+with System; use System;
+
+with System.OS_Lib; use System.OS_Lib;
+with System.Mmap.Unix; use System.Mmap.Unix;
+
+package body System.Mmap.OS_Interface is
+
+ function Align
+ (Addr : File_Size) return File_Size;
+ -- Align some offset/length to the lowest page boundary
+
+ function Is_Mapping_Available return Boolean renames
+ System.Mmap.Unix.Is_Mapping_Available;
+ -- Wheter memory mapping is actually available on this system. It is an
+ -- error to use Create_Mapping and Dispose_Mapping if this is False.
+
+ ---------------
+ -- Open_Read --
+ ---------------
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ Fd : constant File_Descriptor :=
+ Open_Read (Filename, Binary);
+ begin
+ if Fd = Invalid_FD then
+ raise Ada.IO_Exceptions.Name_Error
+ with "Cannot open " & Filename;
+ end if;
+ return
+ (Fd => Fd,
+ Mapped => Use_Mmap_If_Available and then Is_Mapping_Available,
+ Write => False,
+ Length => File_Size (File_Length (Fd)));
+ end Open_Read;
+
+ ----------------
+ -- Open_Write --
+ ----------------
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File is
+ Fd : constant File_Descriptor :=
+ Open_Read_Write (Filename, Binary);
+ begin
+ if Fd = Invalid_FD then
+ raise Ada.IO_Exceptions.Name_Error
+ with "Cannot open " & Filename;
+ end if;
+ return
+ (Fd => Fd,
+ Mapped => Use_Mmap_If_Available and then Is_Mapping_Available,
+ Write => True,
+ Length => File_Size (File_Length (Fd)));
+ end Open_Write;
+
+ -----------
+ -- Close --
+ -----------
+
+ procedure Close (File : in out System_File) is
+ begin
+ Close (File.Fd);
+ File.Fd := Invalid_FD;
+ end Close;
+
+ --------------------
+ -- Read_From_Disk --
+ --------------------
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access
+ is
+ Buffer : String_Access := new String (1 .. Integer (Length));
+ begin
+ -- ??? Lseek offset should be a size_t instead of a Long_Integer
+
+ Lseek (File.Fd, Long_Integer (Offset), Seek_Set);
+ if System.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length))
+ /= Integer (Length)
+ then
+ System.Strings.Free (Buffer);
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ return Buffer;
+ end Read_From_Disk;
+
+ -------------------
+ -- Write_To_Disk --
+ -------------------
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access) is
+ begin
+ pragma Assert (File.Write);
+ Lseek (File.Fd, Long_Integer (Offset), Seek_Set);
+ if System.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length))
+ /= Integer (Length)
+ then
+ raise Ada.IO_Exceptions.Device_Error;
+ end if;
+ end Write_To_Disk;
+
+ --------------------
+ -- Create_Mapping --
+ --------------------
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping)
+ is
+ Prot : Mmap_Prot;
+ Flags : Mmap_Flags;
+ begin
+ if File.Write then
+ Prot := PROT_READ + PROT_WRITE;
+ Flags := MAP_SHARED;
+ else
+ Prot := PROT_READ;
+ if Mutable then
+ Prot := Prot + PROT_WRITE;
+ end if;
+ Flags := MAP_PRIVATE;
+ end if;
+
+ -- Adjust offset and mapping length to account for the required
+ -- alignment of offset on page boundary.
+
+ declare
+ Queried_Offset : constant File_Size := Offset;
+ begin
+ Offset := Align (Offset);
+
+ -- First extend the length to compensate the offset shift, then align
+ -- it on the upper page boundary, so that the whole queried area is
+ -- covered.
+
+ Length := Length + Queried_Offset - Offset;
+ Length := Align (Length + Get_Page_Size - 1);
+ end;
+
+ if Length > File_Size (Integer'Last) then
+ raise Ada.IO_Exceptions.Device_Error;
+ else
+ Mapping :=
+ (Address => System.Mmap.Unix.Mmap
+ (Offset => off_t (Offset),
+ Length => Interfaces.C.size_t (Length),
+ Prot => Prot,
+ Flags => Flags,
+ Fd => File.Fd),
+ Length => Length);
+ end if;
+ end Create_Mapping;
+
+ ---------------------
+ -- Dispose_Mapping --
+ ---------------------
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping)
+ is
+ Ignored : Integer;
+ pragma Unreferenced (Ignored);
+ begin
+ Ignored := Munmap
+ (Mapping.Address, Interfaces.C.size_t (Mapping.Length));
+ Mapping := Invalid_System_Mapping;
+ end Dispose_Mapping;
+
+ -------------------
+ -- Get_Page_Size --
+ -------------------
+
+ function Get_Page_Size return File_Size is
+ function Internal return Integer;
+ pragma Import (C, Internal, "getpagesize");
+ begin
+ return File_Size (Internal);
+ end Get_Page_Size;
+
+ -----------
+ -- Align --
+ -----------
+
+ function Align
+ (Addr : File_Size) return File_Size is
+ begin
+ return Addr - Addr mod Get_Page_Size;
+ end Align;
+
+end System.Mmap.OS_Interface;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- GNAT RUN-TIME COMPONENTS --
+-- --
+-- S Y S T E M . M M A P . O S _ I N T E R F A C E --
+-- --
+-- S p e c --
+-- --
+-- Copyright (C) 2007-2016, AdaCore --
+-- --
+-- This library is free software; you can redistribute it and/or modify it --
+-- under terms of the GNU General Public License as published by the Free --
+-- Software Foundation; either version 3, or (at your option) any later --
+-- version. This library is distributed in the hope that it will be useful, --
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- --
+-- TABILITY 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. --
+-- --
+------------------------------------------------------------------------------
+
+with System.OS_Lib;
+
+-- OS pecularities abstraction package for Unix systems.
+
+package System.Mmap.OS_Interface is
+
+ type System_File is record
+ Fd : System.OS_Lib.File_Descriptor;
+
+ Mapped : Boolean;
+ -- Whether mapping is requested by the user and available on the system
+
+ Write : Boolean;
+ -- Whether this file can be written to
+
+ Length : File_Size;
+ -- Length of the file. Used to know what can be mapped in the file
+ end record;
+
+ type System_Mapping is record
+ Address : Standard.System.Address;
+ Length : File_Size;
+ end record;
+
+ Invalid_System_File : constant System_File :=
+ (System.OS_Lib.Invalid_FD, False, False, 0);
+ Invalid_System_Mapping : constant System_Mapping :=
+ (Standard.System.Null_Address, 0);
+
+ function Open_Read
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Open a file for reading and return the corresponding System_File. Raise
+ -- a Ada.IO_Exceptions.Name_Error if unsuccessful.
+
+ function Open_Write
+ (Filename : String;
+ Use_Mmap_If_Available : Boolean := True) return System_File;
+ -- Likewise for writing to a file
+
+ procedure Close (File : in out System_File);
+ -- Close a system file
+
+ function Read_From_Disk
+ (File : System_File;
+ Offset, Length : File_Size) return System.Strings.String_Access;
+ -- Read a fragment of a file. It is up to the caller to free the result
+ -- when done with it.
+
+ procedure Write_To_Disk
+ (File : System_File;
+ Offset, Length : File_Size;
+ Buffer : System.Strings.String_Access);
+ -- Write some content to a fragment of a file
+
+ procedure Create_Mapping
+ (File : System_File;
+ Offset, Length : in out File_Size;
+ Mutable : Boolean;
+ Mapping : out System_Mapping);
+ -- Create a memory mapping for the given File, for the area starting at
+ -- Offset and containing Length bytes. Store it to Mapping.
+ -- Note that Offset and Length may be modified according to the system
+ -- needs (for boudaries, for instance). The caller must cope with actually
+ -- wider mapped areas.
+
+ procedure Dispose_Mapping
+ (Mapping : in out System_Mapping);
+ -- Unmap a previously-created mapping
+
+ function Get_Page_Size return File_Size;
+ -- Return the number of bytes in a system page.
+
+end System.Mmap.OS_Interface;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;
+with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
-with Sinfo; use Sinfo;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
with Tbuild; use Tbuild;
Set_From_Aspect_Specification (Aitem);
end Make_Aitem_Pragma;
- -- Start of processing for Analyze_Aspect_Specifications
+ -- Start of processing for Analyze_One_Aspect
begin
-- Skip aspect if already analyzed, to avoid looping in some cases
Set_Analyzed (Aspect);
Set_Entity (Aspect, E);
+
+ -- Build the reference to E that will be used in the built pragmas
+
Ent := New_Occurrence_Of (E, Sloc (Id));
+ if A_Id = Aspect_Attach_Handler
+ or else A_Id = Aspect_Interrupt_Handler
+ then
+ -- Decorate the reference as comming from the sources and force
+ -- its reanalysis to generate the reference to E; required to
+ -- avoid reporting spurious warning on E as unreferenced entity
+ -- (because aspects are not fully analyzed).
+
+ Set_Comes_From_Source (Ent, Comes_From_Source (Id));
+ Set_Entity (Ent, Empty);
+
+ Analyze (Ent);
+ end if;
+
-- Check for duplicate aspect. Note that the Comes_From_Source
-- test allows duplicate Pre/Post's that we generate internally
-- to escape being flagged here.
end if;
end if;
- -- We similarly inherit predicates
+ -- We similarly inherit predicates. Note that for scalar derived types
+ -- the predicate is inherited from the first subtype, and not from its
+ -- (anonymous) base type.
- if Has_Predicates (Parent_Type) then
+ if Has_Predicates (Parent_Type)
+ or else Has_Predicates (First_Subtype (Parent_Type))
+ then
Set_Has_Predicates (Derived_Type);
end if;
elsif Is_Entity_Name (E1) and then Is_Entity_Name (E2) then
if Present (Entity (E1)) then
return Entity (E1) = Entity (E2)
+
+ -- One may be a discriminant that has been replaced by
+ -- the correspondding discriminal
+
or else (Chars (Entity (E1)) = Chars (Entity (E2))
and then Ekind (Entity (E1)) = E_Discriminant
- and then Ekind (Entity (E2)) = E_In_Parameter);
+ and then Ekind (Entity (E2)) = E_In_Parameter)
+
+ -- AI12-050 : the loop variables of quantified expressions
+ -- match if the have the same identifier, even though they
+ -- are different entities.
+
+ or else (Chars (Entity (E1)) = Chars (Entity (E2))
+ and then Ekind (Entity (E1)) = E_Loop_Parameter
+ and then Ekind (Entity (E2)) = E_Loop_Parameter);
elsif Nkind (E1) = N_Expanded_Name
and then Nkind (E2) = N_Expanded_Name
-- has already established its actual subtype. This is only relevant
-- if the renamed object is an explicit dereference.
- function In_Generic_Scope (E : Entity_Id) return Boolean;
- -- Determine whether entity E is inside a generic cope
-
------------------------------
-- Check_Constrained_Object --
------------------------------
end if;
end Check_Constrained_Object;
- ----------------------
- -- In_Generic_Scope --
- ----------------------
-
- function In_Generic_Scope (E : Entity_Id) return Boolean is
- S : Entity_Id;
-
- begin
- S := Scope (E);
- while Present (S) and then S /= Standard_Standard loop
- if Is_Generic_Unit (S) then
- return True;
- end if;
-
- S := Scope (S);
- end loop;
-
- return False;
- end In_Generic_Scope;
-
-- Start of processing for Analyze_Object_Renaming
begin
-- --
------------------------------------------------------------------------------
+with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
then
return False;
- elsif Has_Dynamic_Predicate_Aspect (Typ) then
+ -- If there is a dynamic predicate for the type (declared or inherited)
+ -- the expression is not static.
+
+ elsif Has_Dynamic_Predicate_Aspect (Typ)
+ or else (Is_Derived_Type (Typ)
+ and then Has_Aspect (Typ, Aspect_Dynamic_Predicate))
+ then
return False;
-- String types
and then Assertion_Expression_Pragma (Get_Pragma_Id (Prag));
end In_Assertion_Expression_Pragma;
+ ----------------------
+ -- In_Generic_Scope --
+ ----------------------
+
+ function In_Generic_Scope (E : Entity_Id) return Boolean is
+ S : Entity_Id;
+
+ begin
+ S := Scope (E);
+ while Present (S) and then S /= Standard_Standard loop
+ if Is_Generic_Unit (S) then
+ return True;
+ end if;
+
+ S := Scope (S);
+ end loop;
+
+ return False;
+ end In_Generic_Scope;
+
-----------------
-- In_Instance --
-----------------
-- Returns the declaration node enclosing N (including possibly N itself),
-- if any, or Empty otherwise.
- function Enclosing_Generic_Body
- (N : Node_Id) return Node_Id;
+ function Enclosing_Generic_Body (N : Node_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing generic
-- body, if any. If none, then returns Empty.
- function Enclosing_Generic_Unit
- (N : Node_Id) return Node_Id;
+ function Enclosing_Generic_Unit (N : Node_Id) return Node_Id;
-- Returns the Node_Id associated with the innermost enclosing generic
-- unit, if any. If none, then returns Empty.
-- Returns True if node N appears within a pragma that acts as an assertion
-- expression. See Sem_Prag for the list of qualifying pragmas.
+ function In_Generic_Scope (E : Entity_Id) return Boolean;
+ -- Returns True if entity E is inside a generic scope
+
function In_Instance return Boolean;
-- Returns True if the current scope is within a generic instance
* *
* C Implementation 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- *
switch (mode) {
case 0 : WIN_SETMODE (handle, _O_BINARY); break;
- case 1 : WIN_SETMODE (handle, CurrentCCSEncoding); break;
+ case 1 : WIN_SETMODE (handle, __gnat_current_ccs_encoding); break;
case 2 : WIN_SETMODE (handle, _O_TEXT); break;
case 3 : WIN_SETMODE (handle, _O_U8TEXT); break;
case 4 : WIN_SETMODE (handle, _O_WTEXT); break;
projects / gcc.git / commitdiff