From: Arnaud Charlet Date: Thu, 12 Jan 2017 16:01:16 +0000 (+0100) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ca0eb951e3e6cbee039db654df513d823fa86c78;p=gcc.git [multiple changes] 2017-01-12 Tristan Gingold * 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 * 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 * 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 * 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 * 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 * 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 * 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 04e5b8ad45a..9af0589b60c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,65 @@ +2017-01-12 Tristan Gingold + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 + + * 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 * gcc-interface/Makefile.in: Clean up VxWorks targets. diff --git a/gcc/ada/adaint.c b/gcc/ada/adaint.c index 819ea47e449..54a1d6e25c3 100644 --- a/gcc/ada/adaint.c +++ b/gcc/ada/adaint.c @@ -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 diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 49aa2a7765f..001072d5b8f 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -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 -- ---------------------- diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index e2e7de4a67e..a8e4d6c15af 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 6c90bd39537..0cc588102e2 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 diff --git a/gcc/ada/mingw32.h b/gcc/ada/mingw32.h index 77caec26425..cf2d9de1715 100644 --- a/gcc/ada/mingw32.h +++ b/gcc/ada/mingw32.h @@ -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) \ diff --git a/gcc/ada/rtinit.c b/gcc/ada/rtinit.c index dcd0903db5d..42defa8ca13 100644 --- a/gcc/ada/rtinit.c +++ b/gcc/ada/rtinit.c @@ -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; } } diff --git a/gcc/ada/s-mmap.adb b/gcc/ada/s-mmap.adb new file mode 100644 index 00000000000..e9b2aff4201 --- /dev/null +++ b/gcc/ada/s-mmap.adb @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-mmap.ads b/gcc/ada/s-mmap.ads new file mode 100644 index 00000000000..8eed3666949 --- /dev/null +++ b/gcc/ada/s-mmap.ads @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-mmauni-long.ads b/gcc/ada/s-mmauni-long.ads new file mode 100644 index 00000000000..f7fa0bda6f9 --- /dev/null +++ b/gcc/ada/s-mmauni-long.ads @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-mmosin-mingw.adb b/gcc/ada/s-mmosin-mingw.adb new file mode 100644 index 00000000000..0785f3c89f6 --- /dev/null +++ b/gcc/ada/s-mmosin-mingw.adb @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-mmosin-mingw.ads b/gcc/ada/s-mmosin-mingw.ads new file mode 100644 index 00000000000..76874a8fd8f --- /dev/null +++ b/gcc/ada/s-mmosin-mingw.ads @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-mmosin-unix.adb b/gcc/ada/s-mmosin-unix.adb new file mode 100644 index 00000000000..a68c59f395e --- /dev/null +++ b/gcc/ada/s-mmosin-unix.adb @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/s-mmosin-unix.ads b/gcc/ada/s-mmosin-unix.ads new file mode 100644 index 00000000000..01576390b65 --- /dev/null +++ b/gcc/ada/s-mmosin-unix.ads @@ -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 -- +-- . -- +-- -- +-- 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; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 7a23005fae2..a88f8486d80 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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. diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 512615fe4b9..ec47142644e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index ec449c1efcb..b3e597f3d09 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -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 diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index ea868811e62..1a81cbfc449 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -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 diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index fce4643dfbf..531dd70a388 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index ead3efdd8db..58a157bdd5a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 -- ----------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index f1a12a9380e..a1e79b1c330 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 diff --git a/gcc/ada/sysdep.c b/gcc/ada/sysdep.c index 5390209fd16..679c70a77f7 100644 --- a/gcc/ada/sysdep.c +++ b/gcc/ada/sysdep.c @@ -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;