mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-03 05:10:26 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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.

From-SVN: r244369
This commit is contained in:
Arnaud Charlet 2017-01-12 17:01:16 +01:00
parent 6611316649
commit ca0eb951e3
22 changed files with 2061 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
gcc/ada/ChangeLog
View File

@ -1,3 +1,65 @@
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.

4
gcc/ada/adaint.c
View File

@ -128,8 +128,8 @@ extern "C" {
#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>

38
gcc/ada/errout.adb
View File

@ -60,6 +60,13 @@ package body Errout is
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
@ -236,8 +243,17 @@ package body Errout is
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;
@ -1615,13 +1631,13 @@ package body Errout is
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;
@ -2357,6 +2373,18 @@ package body Errout is
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 --
----------------------

11
gcc/ada/errout.ads
View File

@ -803,6 +803,11 @@ package Errout is
-- 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
@ -852,9 +857,9 @@ package Errout is
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

108
gcc/ada/freeze.adb
View File

@ -2035,6 +2035,13 @@ package body Freeze is
-- 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
@ -2249,6 +2256,51 @@ package body Freeze is
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 --
------------------------------
@ -4348,46 +4400,6 @@ package body Freeze is
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)
@ -5643,11 +5655,17 @@ package body Freeze is
-- 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

13
gcc/ada/mingw32.h
View File

@ -6,7 +6,7 @@
* *
* 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- *
@ -78,14 +78,15 @@
#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) \

16
gcc/ada/rtinit.c
View File

@ -169,14 +169,14 @@ __gnat_runtime_initialize(int install_handler)
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;
}
}
@ -185,29 +185,29 @@ __gnat_runtime_initialize(int install_handler)
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;
}
}

548
gcc/ada/s-mmap.adb Normal file
View File

@ -0,0 +1,548 @@
------------------------------------------------------------------------------
-- --
-- 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;

276
gcc/ada/s-mmap.ads Normal file
View File

@ -0,0 +1,276 @@
------------------------------------------------------------------------------
-- --
-- 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;

69
gcc/ada/s-mmauni-long.ads Normal file
View File

@ -0,0 +1,69 @@
------------------------------------------------------------------------------
-- --
-- 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;

341
gcc/ada/s-mmosin-mingw.adb Normal file
View File

@ -0,0 +1,341 @@
------------------------------------------------------------------------------
-- --
-- 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;

235
gcc/ada/s-mmosin-mingw.ads Normal file
View File

@ -0,0 +1,235 @@
------------------------------------------------------------------------------
-- --
-- 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;

231
gcc/ada/s-mmosin-unix.adb Normal file
View File

@ -0,0 +1,231 @@
------------------------------------------------------------------------------
-- --
-- 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;

105
gcc/ada/s-mmosin-unix.ads Normal file
View File

@ -0,0 +1,105 @@
------------------------------------------------------------------------------
-- --
-- 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;

21
gcc/ada/sem_ch13.adb
View File

@ -59,10 +59,10 @@ with Sem_Res; use Sem_Res;
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;
@ -1888,7 +1888,7 @@ package body Sem_Ch13 is
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
@ -1934,8 +1934,25 @@ package body Sem_Ch13 is
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.

8
gcc/ada/sem_ch3.adb
View File

@ -9127,9 +9127,13 @@ package body Sem_Ch3 is
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;

14
gcc/ada/sem_ch6.adb
View File

@ -8476,9 +8476,21 @@ package body Sem_Ch6 is
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

23
gcc/ada/sem_ch8.adb
View File

@ -760,9 +760,6 @@ package body Sem_Ch8 is
-- 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 --
------------------------------
@ -824,26 +821,6 @@ package body Sem_Ch8 is
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

9
gcc/ada/sem_eval.adb
View File

@ -23,6 +23,7 @@
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@ -4989,7 +4990,13 @@ package body Sem_Eval is
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

20
gcc/ada/sem_util.adb
View File

@ -10518,6 +10518,26 @@ package body Sem_Util is
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 --
-----------------

9
gcc/ada/sem_util.ads
View File

@ -556,13 +556,11 @@ package Sem_Util is
-- 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.
@ -1193,6 +1191,9 @@ package Sem_Util is
-- 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

4
gcc/ada/sysdep.c
View File

@ -6,7 +6,7 @@
* *
* 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- *
@ -193,7 +193,7 @@ __gnat_set_mode (int handle, int mode)
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;