Elyes Haouas has uploaded this change for review. ( https://review.coreboot.org/c/coreboot/+/70283 )
Change subject: [test] Update libgnat ......................................................................
[test] Update libgnat
Change-Id: I7545be873ecd28dfb78c03ab39ba699f4af21979 Signed-off-by: Elyes Haouas ehaouas@noos.fr --- M gnat.adc M src/lib/gnat/Makefile.inc A src/lib/gnat/a-except.ads M src/lib/gnat/a-unccon.ads M src/lib/gnat/ada.ads M src/lib/gnat/g-souinf.ads M src/lib/gnat/gnat.ads M src/lib/gnat/i-c.adb M src/lib/gnat/i-c.ads M src/lib/gnat/interfac.ads M src/lib/gnat/s-atacco.ads A src/lib/gnat/s-exctab.ads A src/lib/gnat/s-imagen.adb A src/lib/gnat/s-imen16.ads A src/lib/gnat/s-imen32.ads D src/lib/gnat/s-imenne.adb D src/lib/gnat/s-imenne.ads A src/lib/gnat/s-imenu8.ads M src/lib/gnat/s-maccod.ads M src/lib/gnat/s-parame.ads A src/lib/gnat/s-stalib.ads M src/lib/gnat/s-stoele.adb M src/lib/gnat/s-stoele.ads A src/lib/gnat/s-traent.adb A src/lib/gnat/s-traent.ads M src/lib/gnat/s-unstyp.ads M src/lib/gnat/system.ads 27 files changed, 2,970 insertions(+), 273 deletions(-)
git pull ssh://review.coreboot.org:29418/coreboot refs/changes/83/70283/1
diff --git a/gnat.adc b/gnat.adc index 5a03406..b50510f 100644 --- a/gnat.adc +++ b/gnat.adc @@ -19,7 +19,6 @@ pragma Restrictions (No_Tasking); pragma Restrictions (No_Unchecked_Access); pragma Restrictions (No_Unchecked_Deallocation); -pragma Restrictions (No_Wide_Characters); pragma Restrictions (Static_Storage_Size); pragma Assertion_Policy (Statement_Assertions => Disable, diff --git a/src/lib/gnat/Makefile.inc b/src/lib/gnat/Makefile.inc index 065ba71..4c17105 100644 --- a/src/lib/gnat/Makefile.inc +++ b/src/lib/gnat/Makefile.inc @@ -15,6 +15,7 @@ -Werror \ -fno-pie \
+libgnat-$(1)-y += a-except.ads libgnat-$(1)-y += a-unccon.ads libgnat-$(1)-y += ada.ads libgnat-$(1)-y += g-souinf.ads @@ -23,12 +24,18 @@ libgnat-$(1)-y += i-c.ads libgnat-$(1)-y += interfac.ads libgnat-$(1)-y += s-atacco.ads +libgnat-$(1)-y += s-exctab.ads +libgnat-$(1)-y += s-imen16.ads +libgnat-$(1)-y += s-imen32.ads libgnat-$(1)-y += s-imenne.adb -libgnat-$(1)-y += s-imenne.ads +libgnat-$(1)-y += s-imenu8.ads libgnat-$(1)-y += s-maccod.ads libgnat-$(1)-y += s-parame.ads +libgnat-$(1)-y += s-stalib.ads libgnat-$(1)-y += s-stoele.adb libgnat-$(1)-y += s-stoele.ads +libgnat-$(1)-y += s-traent.adb +libgnat-$(1)-y += s-traent.ads libgnat-$(1)-y += s-unstyp.ads libgnat-$(1)-y += system.ads
diff --git a/src/lib/gnat/a-except.ads b/src/lib/gnat/a-except.ads new file mode 100644 index 0000000..af87d66 --- /dev/null +++ b/src/lib/gnat/a-except.ads @@ -0,0 +1,295 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version of this package. We also have cert and zfp +-- versions. + +with System; +with System.Parameters; +with System.Standard_Library; +with System.Traceback_Entries; + +package Ada.Exceptions is + pragma Preelaborate; + -- In accordance with Ada 2005 AI-362. + + type Exception_Id is private; + pragma Preelaborable_Initialization (Exception_Id); + + Null_Id : constant Exception_Id; + + type Exception_Occurrence is limited private; + pragma Preelaborable_Initialization (Exception_Occurrence); + + type Exception_Occurrence_Access is access all Exception_Occurrence; + + Null_Occurrence : constant Exception_Occurrence; + + function Exception_Name (Id : Exception_Id) return String; + + function Exception_Name (X : Exception_Occurrence) return String; + + function Wide_Exception_Name + (Id : Exception_Id) return Wide_String; + pragma Ada_05 (Wide_Exception_Name); + + function Wide_Exception_Name + (X : Exception_Occurrence) return Wide_String; + pragma Ada_05 (Wide_Exception_Name); + + function Wide_Wide_Exception_Name + (Id : Exception_Id) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Exception_Name); + + function Wide_Wide_Exception_Name + (X : Exception_Occurrence) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Exception_Name); + + procedure Raise_Exception (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception); + -- Note: In accordance with AI-466, CE is raised if E = Null_Id + + function Exception_Message (X : Exception_Occurrence) return String; + + procedure Reraise_Occurrence (X : Exception_Occurrence); + -- Note: it would be really nice to give a pragma No_Return for this + -- procedure, but it would be wrong, since Reraise_Occurrence does return + -- if the argument is the null exception occurrence. See also procedure + -- Reraise_Occurrence_Always in the private part of this package. + + function Exception_Identity (X : Exception_Occurrence) return Exception_Id; + + function Exception_Information (X : Exception_Occurrence) return String; + -- The format of the exception information is as follows: + -- + -- exception name (as in Exception_Name) + -- message (or a null line if no message) + -- PID=nnnn + -- 0xyyyyyyyy 0xyyyyyyyy ... + -- + -- The lines are separated by a ASCII.LF character + -- + -- The nnnn is the partition Id given as decimal digits + -- + -- The 0x... line represents traceback program counter locations, + -- in order with the first one being the exception location. + + -- Note on ordering: the compiler uses the Save_Occurrence procedure, but + -- not the function from Rtsfind, so it is important that the procedure + -- come first, since Rtsfind finds the first matching entity. + + procedure Save_Occurrence + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + + function Save_Occurrence + (Source : Exception_Occurrence) + return Exception_Occurrence_Access; + + -- Ada 2005 (AI-438): The language revision introduces the following + -- subprograms and attribute definitions. We do not provide them + -- explicitly. instead, the corresponding stream attributes are made + -- available through a pragma Stream_Convert in the private part. + + -- procedure Read_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : out Exception_Occurrence); + + -- procedure Write_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : Exception_Occurrence); + + -- for Exception_Occurrence'Read use Read_Exception_Occurrence; + -- for Exception_Occurrence'Write use Write_Exception_Occurrence; + +private + package SSL renames System.Standard_Library; + package SP renames System.Parameters; + + subtype EOA is Exception_Occurrence_Access; + + Exception_Msg_Max_Length : constant := SP.Default_Exception_Msg_Max_Length; + + ------------------ + -- Exception_Id -- + ------------------ + + subtype Code_Loc is System.Address; + -- Code location used in building exception tables and for call addresses + -- when propagating an exception. Values of this type are created by using + -- Label'Address or extracted from machine states using Get_Code_Loc. + + Null_Loc : constant Code_Loc := System.Null_Address; + -- Null code location, used to flag outer level frame + + type Exception_Id is new SSL.Exception_Data_Ptr; + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String); + -- Functions for implementing Exception_Id stream attributes + + Null_Id : constant Exception_Id := null; + + ------------------------- + -- Private Subprograms -- + ------------------------- + + function Exception_Name_Simple (X : Exception_Occurrence) return String; + -- Like Exception_Name, but returns the simple non-qualified name of the + -- exception. This is used to implement the Exception_Name function in + -- Current_Exceptions (the DEC compatible unit). It is called from the + -- compiler generated code (using Rtsfind, which does not respect the + -- private barrier, so we can place this function in the private part + -- where the compiler can find it, but the spec is unchanged.) + + procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception_Always); + pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); + -- This differs from Raise_Exception only in that the caller has determined + -- that for sure the parameter E is not null, and that therefore no check + -- for Null_Id is required. The expander converts Raise_Exception calls to + -- Raise_Exception_Always if it can determine this is the case. The Export + -- allows this routine to be accessed from Pure units. + + pragma Machine_Attribute (Raise_Exception_Always, + "strub", "callable"); + -- Make it callable from strub contexts + + procedure Raise_From_Controlled_Operation (X : Exception_Occurrence); + pragma No_Return (Raise_From_Controlled_Operation); + pragma Export + (Ada, Raise_From_Controlled_Operation, + "__gnat_raise_from_controlled_operation"); + -- Raise Program_Error, providing information about X (an exception raised + -- during a controlled operation) in the exception message. + + procedure Reraise_Library_Exception_If_Any; + pragma Export + (Ada, Reraise_Library_Exception_If_Any, + "__gnat_reraise_library_exception_if_any"); + -- If there was an exception raised during library-level finalization, + -- reraise the exception. + + procedure Reraise_Occurrence_Always (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_Always); + -- This differs from Raise_Occurrence only in that the caller guarantees + -- that for sure the parameter X is not the null occurrence, and that + -- therefore this procedure cannot return. The expander uses this routine + -- in the translation of a raise statement with no parameter (reraise). + + procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_No_Defer); + -- Exactly like Reraise_Occurrence, except that abort is not deferred + -- before the call and the parameter X is known not to be the null + -- occurrence. This is used in generated code when it is known that abort + -- is already deferred. + + function Triggered_By_Abort return Boolean; + -- Determine whether the current exception (if it exists) is an instance of + -- Standard'Abort_Signal. + + -------------------------- + -- Exception_Occurrence -- + -------------------------- + + package TBE renames System.Traceback_Entries; + + Max_Tracebacks : constant := 50; + -- Maximum number of trace backs stored in exception occurrence + + subtype Tracebacks_Array is TBE.Tracebacks_Array (1 .. Max_Tracebacks); + -- Traceback array stored in exception occurrence + + type Exception_Occurrence is record + Id : Exception_Id := Null_Id; + -- Exception_Identity for this exception occurrence + + Machine_Occurrence : System.Address; + -- The underlying machine occurrence. For GCC, this corresponds to the + -- _Unwind_Exception structure address. + + Msg_Length : Natural := 0; + -- Length of message (zero = no message) + + Msg : String (1 .. Exception_Msg_Max_Length); + -- Characters of message + + Exception_Raised : Boolean := False; + -- Set to true to indicate that this exception occurrence has actually + -- been raised. When an exception occurrence is first created, this is + -- set to False, then when it is processed by Raise_Current_Exception, + -- it is set to True. If Raise_Current_Exception is used to raise an + -- exception for which this flag is already True, then it knows that + -- it is dealing with the reraise case (which is useful to distinguish + -- for exception tracing purposes). + + Pid : Natural := 0; + -- Partition_Id for partition raising exception + + Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0; + -- Number of traceback entries stored + + Tracebacks : Tracebacks_Array; + -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) + end record; + + function "=" (Left, Right : Exception_Occurrence) return Boolean + is abstract; + -- Don't allow comparison on exception occurrences, we should not need + -- this, and it would not work right, because of the Msg and Tracebacks + -- fields which have unused entries not copied by Save_Occurrence. + + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address; + pragma Export (Ada, Get_Exception_Machine_Occurrence, + "__gnat_get_exception_machine_occurrence"); + -- Get the machine occurrence corresponding to an exception occurrence. + -- It is Null_Address if there is no machine occurrence (in runtimes that + -- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence + -- doesn't save the machine occurrence). + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); + -- Functions for implementing Exception_Occurrence stream attributes + + Null_Occurrence : constant Exception_Occurrence := + (Machine_Occurrence => System.Null_Address, + Msg => (others => '*'), + Tracebacks => (others => System.Traceback_Entries.Null_TB_Entry), + others => <>); + +end Ada.Exceptions; diff --git a/src/lib/gnat/a-unccon.ads b/src/lib/gnat/a-unccon.ads index ffa84d9..a8429c1 100644 --- a/src/lib/gnat/a-unccon.ads +++ b/src/lib/gnat/a-unccon.ads @@ -19,5 +19,6 @@
function Ada.Unchecked_Conversion (S : Source) return Target;
-pragma Pure (Unchecked_Conversion); -pragma Import (Intrinsic, Unchecked_Conversion); +pragma No_Elaboration_Code_All (Ada.Unchecked_Conversion); +pragma Pure (Ada.Unchecked_Conversion); +pragma Import (Intrinsic, Ada.Unchecked_Conversion); diff --git a/src/lib/gnat/ada.ads b/src/lib/gnat/ada.ads index 8c86011..4c2a3d0 100644 --- a/src/lib/gnat/ada.ads +++ b/src/lib/gnat/ada.ads @@ -14,6 +14,7 @@ ------------------------------------------------------------------------------
package Ada is + pragma No_Elaboration_Code_All; pragma Pure;
end Ada; diff --git a/src/lib/gnat/g-souinf.ads b/src/lib/gnat/g-souinf.ads index 610db23..6b72a64 100644 --- a/src/lib/gnat/g-souinf.ads +++ b/src/lib/gnat/g-souinf.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2022, 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- -- @@ -36,7 +36,13 @@ -- and logging purposes. For example, an exception handler can print out -- the name of the source file in which the exception is handled.
-package GNAT.Source_Info is +package GNAT.Source_Info with + SPARK_Mode, + Abstract_State => + (Source_Code_Information with + External => (Async_Writers, Async_Readers)), + Annotate => (GNATprove, Always_Return) +is pragma Preelaborate; -- Note that this unit is Preelaborate, but not Pure, that's because the -- functions here such as Line are clearly not pure functions, and normally @@ -47,6 +53,8 @@ -- intrinsics as not Pure, even in Pure units, so no problems arose.
function File return String with + Volatile_Function, + Global => Source_Code_Information, Import, Convention => Intrinsic; -- Return the name of the current file, not including the path information. -- The result is considered to be a static string constant. @@ -57,6 +65,8 @@ -- static expression.
function Source_Location return String with + Volatile_Function, + Global => Source_Code_Information, Import, Convention => Intrinsic; -- Return a string literal of the form "name:line", where name is the -- current source file name without path information, and line is the @@ -66,6 +76,8 @@ -- string constant.
function Enclosing_Entity return String with + Volatile_Function, + Global => Source_Code_Information, Import, Convention => Intrinsic; -- Return the name of the current subprogram, package, task, entry or -- protected subprogram. The string is in exactly the form used for the @@ -79,12 +91,22 @@ -- package itself. This is useful in identifying and logging information -- from within generic templates.
+ function Compilation_ISO_Date return String with + Volatile_Function, + Global => Source_Code_Information, + Import, Convention => Intrinsic; + -- Returns date of compilation as a static string "yyyy-mm-dd". + function Compilation_Date return String with + Volatile_Function, + Global => Source_Code_Information, Import, Convention => Intrinsic; -- Returns date of compilation as a static string "mmm dd yyyy". This is -- in local time form, and is exactly compatible with C macro __DATE__.
function Compilation_Time return String with + Volatile_Function, + Global => Source_Code_Information, Import, Convention => Intrinsic; -- Returns GMT time of compilation as a static string "hh:mm:ss". This is -- in local time form, and is exactly compatible with C macro __TIME__. diff --git a/src/lib/gnat/gnat.ads b/src/lib/gnat/gnat.ads index a0807b6..1471c50 100644 --- a/src/lib/gnat/gnat.ads +++ b/src/lib/gnat/gnat.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, AdaCore -- +-- Copyright (C) 1992-2022, AdaCore -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -31,7 +31,30 @@
-- This is the parent package for a library of useful units provided with GNAT
+-- Note: this unit is used during bootstrap, see ADA_GENERATED_FILES in +-- gcc-interface/Make-lang.in for details on the constraints. + package GNAT is pragma Pure;
+ -- The following type denotes the range of buckets for various hashed + -- data structures in the GNAT unit hierarchy. + + type Bucket_Range_Type is mod 2 ** 32; + + -- The following exception is raised whenever an attempt is made to mutate + -- the state of a data structure that is being iterated on. + + Iterated : exception; + + -- The following exception is raised when an iterator is exhausted and + -- further attempts are made to advance it. + + Iterator_Exhausted : exception; + + -- The following exception is raised whenever an attempt is made to mutate + -- the state of a data structure that has not been created yet. + + Not_Created : exception; + end GNAT; diff --git a/src/lib/gnat/i-c.adb b/src/lib/gnat/i-c.adb index 6926a9e..4b50d18 100644 --- a/src/lib/gnat/i-c.adb +++ b/src/lib/gnat/i-c.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2022, 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- -- @@ -29,7 +29,77 @@ -- -- ------------------------------------------------------------------------------
-package body Interfaces.C is +-- Ghost code, loop invariants and assertions in this unit are meant for +-- analysis only, not for run-time checking, as it would be too costly +-- otherwise. This is enforced by setting the assertion policy to Ignore. + +pragma Assertion_Policy (Ghost => Ignore, + Loop_Invariant => Ignore, + Assert => Ignore); + +package body Interfaces.C + with SPARK_Mode +is + + -------------------- + -- C_Length_Ghost -- + -------------------- + + function C_Length_Ghost (Item : char_array) return size_t is + begin + for J in Item'Range loop + if Item (J) = nul then + return J - Item'First; + end if; + + pragma Loop_Invariant + (for all K in Item'First .. J => Item (K) /= nul); + end loop; + + raise Program_Error; + end C_Length_Ghost; + + function C_Length_Ghost (Item : wchar_array) return size_t is + begin + for J in Item'Range loop + if Item (J) = wide_nul then + return J - Item'First; + end if; + + pragma Loop_Invariant + (for all K in Item'First .. J => Item (K) /= wide_nul); + end loop; + + raise Program_Error; + end C_Length_Ghost; + + function C_Length_Ghost (Item : char16_array) return size_t is + begin + for J in Item'Range loop + if Item (J) = char16_nul then + return J - Item'First; + end if; + + pragma Loop_Invariant + (for all K in Item'First .. J => Item (K) /= char16_nul); + end loop; + + raise Program_Error; + end C_Length_Ghost; + + function C_Length_Ghost (Item : char32_array) return size_t is + begin + for J in Item'Range loop + if Item (J) = char32_nul then + return J - Item'First; + end if; + + pragma Loop_Invariant + (for all K in Item'First .. J => Item (K) /= char32_nul); + end loop; + + raise Program_Error; + end C_Length_Ghost;
----------------------- -- Is_Nul_Terminated -- @@ -43,6 +113,57 @@ if Item (J) = nul then return True; end if; + + pragma Loop_Invariant + (for all K in Item'First .. J => Item (K) /= nul); + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of wchar_array + + function Is_Nul_Terminated (Item : wchar_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = wide_nul then + return True; + end if; + + pragma Loop_Invariant + (for all K in Item'First .. J => Item (K) /= wide_nul); + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of char16_array + + function Is_Nul_Terminated (Item : char16_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = char16_nul then + return True; + end if; + + pragma Loop_Invariant + (for all K in Item'First .. J => Item (K) /= char16_nul); + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of char32_array + + function Is_Nul_Terminated (Item : char32_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = char32_nul then + return True; + end if; + + pragma Loop_Invariant + (for all K in Item'First .. J => Item (K) /= char32_nul); end loop;
return False; @@ -59,6 +180,531 @@ return Character'Val (char'Pos (Item)); end To_Ada;
+ -- Convert char_array to String (function form) + + function To_Ada + (Item : char_array; + Trim_Nul : Boolean := True) return String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant + (for some J in From .. Item'Last => Item (J) = nul); + pragma Loop_Invariant + (for all J in Item'First .. From when J /= From => + Item (J) /= nul); + + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = nul then + exit; + else + From := From + 1; + end if; + end loop; + + pragma Assert (From = Item'First + C_Length_Ghost (Item)); + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + Count_Cst : constant Natural := Count; + R : String (1 .. Count_Cst) with Relaxed_Initialization; + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); + + pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => + R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char_array to String (procedure form) + + procedure To_Ada + (Item : char_array; + Target : out String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Integer; + + begin + if Trim_Nul then + From := Item'First; + loop + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant + (for some J in From .. Item'Last => Item (J) = nul); + pragma Loop_Invariant + (for all J in Item'First .. From when J /= From => + Item (J) /= nul); + + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := Character (Item (From)); + + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant (To in Target'Range); + pragma Loop_Invariant (To = Target'First + (J - 1)); + pragma Loop_Invariant (From = Item'First + size_t (J - 1)); + pragma Loop_Invariant + (for all J in Target'First .. To => Target (J)'Initialized); + pragma Loop_Invariant + (Target (Target'First .. To)'Initialized); + pragma Loop_Invariant + (for all K in Target'First .. To => + Target (K) = + To_Ada (Item (size_t (K - Target'First) + Item'First))); + + -- Avoid possible overflow when incrementing To in the last + -- iteration of the loop. + exit when J = Count; + + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + -- Convert wchar_t to Wide_Character + + function To_Ada (Item : wchar_t) return Wide_Character is + begin + return Wide_Character (Item); + end To_Ada; + + -- Convert wchar_array to Wide_String (function form) + + function To_Ada + (Item : wchar_array; + Trim_Nul : Boolean := True) return Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant + (for some J in From .. Item'Last => Item (J) = wide_nul); + pragma Loop_Invariant + (for all J in Item'First .. From when J /= From => + Item (J) /= wide_nul); + + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = wide_nul then + exit; + else + From := From + 1; + end if; + end loop; + + pragma Assert (From = Item'First + C_Length_Ghost (Item)); + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + Count_Cst : constant Natural := Count; + R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization; + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); + + pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => + R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert wchar_array to Wide_String (procedure form) + + procedure To_Ada + (Item : wchar_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Integer; + + begin + if Trim_Nul then + From := Item'First; + loop + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant + (for some J in From .. Item'Last => Item (J) = wide_nul); + pragma Loop_Invariant + (for all J in Item'First .. From when J /= From => + Item (J) /= wide_nul); + + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = wide_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant (To in Target'Range); + pragma Loop_Invariant (To = Target'First + (J - 1)); + pragma Loop_Invariant (From = Item'First + size_t (J - 1)); + pragma Loop_Invariant + (for all J in Target'First .. To => Target (J)'Initialized); + pragma Loop_Invariant + (Target (Target'First .. To)'Initialized); + pragma Loop_Invariant + (for all K in Target'First .. To => + Target (K) = + To_Ada (Item (size_t (K - Target'First) + Item'First))); + + -- Avoid possible overflow when incrementing To in the last + -- iteration of the loop. + exit when J = Count; + + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + -- Convert char16_t to Wide_Character + + function To_Ada (Item : char16_t) return Wide_Character is + begin + return Wide_Character'Val (char16_t'Pos (Item)); + end To_Ada; + + -- Convert char16_array to Wide_String (function form) + + function To_Ada + (Item : char16_array; + Trim_Nul : Boolean := True) return Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant + (for some J in From .. Item'Last => Item (J) = char16_nul); + pragma Loop_Invariant + (for all J in Item'First .. From when J /= From => + Item (J) /= char16_nul); + + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char16_nul then + exit; + else + From := From + 1; + end if; + end loop; + + pragma Assert (From = Item'First + C_Length_Ghost (Item)); + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + Count_Cst : constant Natural := Count; + R : Wide_String (1 .. Count_Cst) with Relaxed_Initialization; + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); + + pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => + R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char16_array to Wide_String (procedure form) + + procedure To_Ada + (Item : char16_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Integer; + + begin + if Trim_Nul then + From := Item'First; + loop + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant + (for some J in From .. Item'Last => Item (J) = char16_nul); + pragma Loop_Invariant + (for all J in Item'First .. From when J /= From => + Item (J) /= char16_nul); + + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char16_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant (To in Target'Range); + pragma Loop_Invariant (To = Target'First + (J - 1)); + pragma Loop_Invariant (From = Item'First + size_t (J - 1)); + pragma Loop_Invariant + (for all J in Target'First .. To => Target (J)'Initialized); + pragma Loop_Invariant + (Target (Target'First .. To)'Initialized); + pragma Loop_Invariant + (for all K in Target'First .. To => + Target (K) = + To_Ada (Item (size_t (K - Target'First) + Item'First))); + + -- Avoid possible overflow when incrementing To in the last + -- iteration of the loop. + exit when J = Count; + + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + -- Convert char32_t to Wide_Wide_Character + + function To_Ada (Item : char32_t) return Wide_Wide_Character is + begin + return Wide_Wide_Character'Val (char32_t'Pos (Item)); + end To_Ada; + + -- Convert char32_array to Wide_Wide_String (function form) + + function To_Ada + (Item : char32_array; + Trim_Nul : Boolean := True) return Wide_Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant + (for some J in From .. Item'Last => Item (J) = char32_nul); + pragma Loop_Invariant + (for all J in Item'First .. From when J /= From => + Item (J) /= char32_nul); + + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char32_nul then + exit; + else + From := From + 1; + end if; + end loop; + + pragma Assert (From = Item'First + C_Length_Ghost (Item)); + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + Count_Cst : constant Natural := Count; + R : Wide_Wide_String (1 .. Count_Cst) with Relaxed_Initialization; + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) - 1 + Item'First)); + + pragma Loop_Invariant (for all K in 1 .. J => R (K)'Initialized); + pragma Loop_Invariant + (for all K in 1 .. J => + R (K) = To_Ada (Item (size_t (K) - 1 + Item'First))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char32_array to Wide_Wide_String (procedure form) + + procedure To_Ada + (Item : char32_array; + Target : out Wide_Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Integer; + + begin + if Trim_Nul then + From := Item'First; + loop + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant + (for some J in From .. Item'Last => Item (J) = char32_nul); + pragma Loop_Invariant + (for all J in Item'First .. From when J /= From => + Item (J) /= char32_nul); + + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char32_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + + pragma Loop_Invariant (From in Item'Range); + pragma Loop_Invariant (To in Target'Range); + pragma Loop_Invariant (To = Target'First + (J - 1)); + pragma Loop_Invariant (From = Item'First + size_t (J - 1)); + pragma Loop_Invariant + (for all J in Target'First .. To => Target (J)'Initialized); + pragma Loop_Invariant + (Target (Target'First .. To)'Initialized); + pragma Loop_Invariant + (for all K in Target'First .. To => + Target (K) = + To_Ada (Item (size_t (K - Target'First) + Item'First))); + + -- Avoid possible overflow when incrementing To in the last + -- iteration of the loop. + exit when J = Count; + + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + ---------- -- To_C -- ---------- @@ -70,4 +716,511 @@ return char'Val (Character'Pos (Item)); end To_C;
+ -- Convert String to char_array (function form) + + function To_C + (Item : String; + Append_Nul : Boolean := True) return char_array + is + begin + if Append_Nul then + declare + R : char_array (0 .. Item'Length) with Relaxed_Initialization; + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + + pragma Loop_Invariant + (for all K in 0 .. size_t (J - Item'First) => + R (K)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + R (size_t (K - Item'First)) = To_C (Item (K))); + end loop; + + R (R'Last) := nul; + + pragma Assert + (for all J in Item'Range => + R (size_t (J - Item'First)) = To_C (Item (J))); + + return R; + end; + + -- Append_Nul False + + else + -- A nasty case, if the string is null, we must return a null + -- char_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + -- Normal case + + else + declare + R : char_array (0 .. Item'Length - 1) + with Relaxed_Initialization; + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + + pragma Loop_Invariant + (for all K in 0 .. size_t (J - Item'First) => + R (K)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + R (size_t (K - Item'First)) = To_C (Item (K))); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert String to char_array (procedure form) + + procedure To_C + (Item : String; + Target : out char_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := char (Item (From)); + + pragma Loop_Invariant (To in Target'Range); + pragma Loop_Invariant + (To - Target'First = size_t (From - Item'First)); + pragma Loop_Invariant + (for all J in Target'First .. To => Target (J)'Initialized); + pragma Loop_Invariant + (Target (Target'First .. To)'Initialized); + pragma Loop_Invariant + (for all J in Item'First .. From => + Target (Target'First + size_t (J - Item'First)) = + To_C (Item (J))); + + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to wchar_t + + function To_C (Item : Wide_Character) return wchar_t is + begin + return wchar_t (Item); + end To_C; + + -- Convert Wide_String to wchar_array (function form) + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return wchar_array + is + begin + if Append_Nul then + declare + R : wchar_array (0 .. Item'Length) with Relaxed_Initialization; + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + + pragma Loop_Invariant + (for all K in 0 .. size_t (J - Item'First) => + R (K)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + R (size_t (K - Item'First)) = To_C (Item (K))); + end loop; + + R (R'Last) := wide_nul; + + pragma Assert + (for all J in Item'Range => + R (size_t (J - Item'First)) = To_C (Item (J))); + + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- wchar_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : wchar_array (0 .. Item'Length - 1) + with Relaxed_Initialization; + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + + pragma Loop_Invariant + (for all K in 0 .. size_t (J - Item'First) => + R (K)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + R (size_t (K - Item'First)) = To_C (Item (K))); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_String to wchar_array (procedure form) + + procedure To_C + (Item : Wide_String; + Target : out wchar_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + + pragma Loop_Invariant (To in Target'Range); + pragma Loop_Invariant + (To - Target'First = size_t (From - Item'First)); + pragma Loop_Invariant + (for all J in Target'First .. To => Target (J)'Initialized); + pragma Loop_Invariant + (Target (Target'First .. To)'Initialized); + pragma Loop_Invariant + (for all J in Item'First .. From => + Target (Target'First + size_t (J - Item'First)) = + To_C (Item (J))); + + To := To + 1; + end loop; + + pragma Assert + (for all J in Item'Range => + Target (Target'First + size_t (J - Item'First)) = + To_C (Item (J))); + pragma Assert + (if Item'Length /= 0 then + Target (Target'First .. + Target'First + (Item'Length - 1))'Initialized); + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := wide_nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to char16_t + + function To_C (Item : Wide_Character) return char16_t is + begin + return char16_t'Val (Wide_Character'Pos (Item)); + end To_C; + + -- Convert Wide_String to char16_array (function form) + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return char16_array + is + begin + if Append_Nul then + declare + R : char16_array (0 .. Item'Length) with Relaxed_Initialization; + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + + pragma Loop_Invariant + (for all K in 0 .. size_t (J - Item'First) => + R (K)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + R (size_t (K - Item'First)) = To_C (Item (K))); + end loop; + + R (R'Last) := char16_nul; + + pragma Assert + (for all J in Item'Range => + R (size_t (J - Item'First)) = To_C (Item (J))); + + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- char16_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : char16_array (0 .. Item'Length - 1) + with Relaxed_Initialization; + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + + pragma Loop_Invariant + (for all K in 0 .. size_t (J - Item'First) => + R (K)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + R (size_t (K - Item'First)) = To_C (Item (K))); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_String to char16_array (procedure form) + + procedure To_C + (Item : Wide_String; + Target : out char16_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + + pragma Loop_Invariant (To in Target'Range); + pragma Loop_Invariant + (To - Target'First = size_t (From - Item'First)); + pragma Loop_Invariant + (for all J in Target'First .. To => Target (J)'Initialized); + pragma Loop_Invariant + (Target (Target'First .. To)'Initialized); + pragma Loop_Invariant + (for all J in Item'First .. From => + Target (Target'First + size_t (J - Item'First)) = + To_C (Item (J))); + + To := To + 1; + end loop; + + pragma Assert + (for all J in Item'Range => + Target (Target'First + size_t (J - Item'First)) = + To_C (Item (J))); + pragma Assert + (if Item'Length /= 0 then + Target (Target'First .. + Target'First + (Item'Length - 1))'Initialized); + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := char16_nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to char32_t + + function To_C (Item : Wide_Wide_Character) return char32_t is + begin + return char32_t'Val (Wide_Wide_Character'Pos (Item)); + end To_C; + + -- Convert Wide_Wide_String to char32_array (function form) + + function To_C + (Item : Wide_Wide_String; + Append_Nul : Boolean := True) return char32_array + is + begin + if Append_Nul then + declare + R : char32_array (0 .. Item'Length) with Relaxed_Initialization; + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + + pragma Loop_Invariant + (for all K in 0 .. size_t (J - Item'First) => + R (K)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + R (size_t (K - Item'First)) = To_C (Item (K))); + end loop; + + R (R'Last) := char32_nul; + + pragma Assert + (for all J in Item'Range => + R (size_t (J - Item'First)) = To_C (Item (J))); + + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- char32_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : char32_array (0 .. Item'Length - 1) + with Relaxed_Initialization; + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + + pragma Loop_Invariant + (for all K in 0 .. size_t (J - Item'First) => + R (K)'Initialized); + pragma Loop_Invariant + (for all K in Item'First .. J => + R (size_t (K - Item'First)) = To_C (Item (K))); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_Wide_String to char32_array (procedure form) + + procedure To_C + (Item : Wide_Wide_String; + Target : out char32_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + + pragma Loop_Invariant (To in Target'Range); + pragma Loop_Invariant + (To - Target'First = size_t (From - Item'First)); + pragma Loop_Invariant + (for all J in Target'First .. To => Target (J)'Initialized); + pragma Loop_Invariant + (Target (Target'First .. To)'Initialized); + pragma Loop_Invariant + (for all J in Item'First .. From => + Target (Target'First + size_t (J - Item'First)) = + To_C (Item (J))); + + To := To + 1; + end loop; + + pragma Assert + (for all J in Item'Range => + Target (Target'First + size_t (J - Item'First)) = + To_C (Item (J))); + pragma Assert + (if Item'Length /= 0 then + Target (Target'First .. + Target'First + (Item'Length - 1))'Initialized); + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := char32_nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + end Interfaces.C; diff --git a/src/lib/gnat/i-c.ads b/src/lib/gnat/i-c.ads index 7e90a60..7013902 100644 --- a/src/lib/gnat/i-c.ads +++ b/src/lib/gnat/i-c.ads @@ -13,10 +13,32 @@ -- -- ------------------------------------------------------------------------------
+-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised. This is enforced by +-- setting the corresponding assertion policy to Ignore. Postconditions and +-- contract cases should not be executed at runtime as well, in order not to +-- slow down the execution of these functions. + +pragma Assertion_Policy (Pre => Ignore, + Post => Ignore, + Contract_Cases => Ignore, + Ghost => Ignore); + with System.Parameters;
-package Interfaces.C is - pragma Pure; +package Interfaces.C + with SPARK_Mode, Pure +is + pragma Annotate (GNATprove, Always_Return, C); + + -- Each of the types declared in Interfaces.C is C-compatible. + + -- The types int, short, long, unsigned, ptrdiff_t, size_t, double, + -- char, wchar_t, char16_t, and char32_t correspond respectively to the + -- C types having the same names. The types signed_char, unsigned_short, + -- unsigned_long, unsigned_char, C_bool, C_float, and long_double + -- correspond respectively to the C types signed char, unsigned + -- short, unsigned long, unsigned char, bool, float, and long double.
-- Declaration's based on C's <limits.h>
@@ -36,18 +58,24 @@ type short is new Short_Integer; type long is range -(2 ** (System.Parameters.long_bits - Integer'(1))) .. +(2 ** (System.Parameters.long_bits - Integer'(1))) - 1; + type long_long is new Long_Long_Integer;
type signed_char is range SCHAR_MIN .. SCHAR_MAX; for signed_char'Size use CHAR_BIT;
- type unsigned is mod 2 ** int'Size; - type unsigned_short is mod 2 ** short'Size; - type unsigned_long is mod 2 ** long'Size; + type unsigned is mod 2 ** int'Size; + type unsigned_short is mod 2 ** short'Size; + type unsigned_long is mod 2 ** long'Size; + type unsigned_long_long is mod 2 ** long_long'Size;
type unsigned_char is mod (UCHAR_MAX + 1); for unsigned_char'Size use CHAR_BIT;
- subtype plain_char is unsigned_char; -- ??? should be parameterized + -- Note: Ada RM states that the type of the subtype plain_char is either + -- signed_char or unsigned_char, depending on the C implementation. GNAT + -- instead choses unsigned_char always. + + subtype plain_char is unsigned_char;
-- Note: the Integer qualifications used in the declaration of ptrdiff_t -- avoid ambiguities when compiling in the presence of s-auxdec.ads and @@ -59,8 +87,16 @@
type size_t is mod 2 ** System.Parameters.ptr_bits;
- -- For convenience, also provide an uintptr_t type - type uintptr_t is mod 2 ** System.Parameters.ptr_bits; + -- Boolean type + + type C_bool is new Boolean; + pragma Convention (C, C_bool); + + -- Floating-Point + + type C_float is new Float; + type double is new Standard.Long_Float; + type long_double is new Standard.Long_Long_Float;
---------------------------- -- Characters and Strings -- @@ -70,12 +106,492 @@
nul : constant char := char'First;
- function To_C (Item : Character) return char; - function To_Ada (Item : char) return Character; + -- The functions To_C and To_Ada map between the Ada type Character and the + -- C type char. + + function To_C (Item : Character) return char + with + Post => To_C'Result = char'Val (Character'Pos (Item)); + + function To_Ada (Item : char) return Character + with + Post => To_Ada'Result = Character'Val (char'Pos (Item));
type char_array is array (size_t range <>) of aliased char; for char_array'Component_Size use CHAR_BIT;
- function Is_Nul_Terminated (Item : char_array) return Boolean; + function Is_Nul_Terminated (Item : char_array) return Boolean + with + Post => Is_Nul_Terminated'Result = (for some C of Item => C = nul); + -- The result of Is_Nul_Terminated is True if Item contains nul, and is + -- False otherwise. + + function C_Length_Ghost (Item : char_array) return size_t + with + Ghost, + Pre => Is_Nul_Terminated (Item), + Post => C_Length_Ghost'Result <= Item'Last - Item'First + and then Item (Item'First + C_Length_Ghost'Result) = nul + and then (for all J in Item'First .. Item'First + C_Length_Ghost'Result + when J /= Item'First + C_Length_Ghost'Result => + Item (J) /= nul); + -- Ghost function to compute the length of a char_array up to the first nul + -- character. + + function To_C + (Item : String; + Append_Nul : Boolean := True) return char_array + with + Pre => not (Append_Nul = False and then Item'Length = 0), + Post => To_C'Result'First = 0 + and then To_C'Result'Length = + (if Append_Nul then Item'Length + 1 else Item'Length) + and then (for all J in Item'Range => + To_C'Result (size_t (J - Item'First)) = To_C (Item (J))) + and then (if Append_Nul then To_C'Result (To_C'Result'Last) = nul); + -- The result of To_C is a char_array value of length Item'Length (if + -- Append_Nul is False) or Item'Length+1 (if Append_Nul is True). The lower + -- bound is 0. For each component Item(I), the corresponding component + -- in the result is To_C applied to Item(I). The value nul is appended if + -- Append_Nul is True. If Append_Nul is False and Item'Length is 0, then + -- To_C propagates Constraint_Error. + + function To_Ada + (Item : char_array; + Trim_Nul : Boolean := True) return String + with + Pre => (if Trim_Nul then + Is_Nul_Terminated (Item) + and then C_Length_Ghost (Item) <= size_t (Natural'Last) + else + Item'Last - Item'First < size_t (Natural'Last)), + Post => To_Ada'Result'First = 1 + and then To_Ada'Result'Length = + (if Trim_Nul then C_Length_Ghost (Item) else Item'Length) + and then (for all J in To_Ada'Result'Range => + To_Ada'Result (J) = + To_Ada (Item (size_t (J) - 1 + Item'First))); + -- The result of To_Ada is a String whose length is Item'Length (if + -- Trim_Nul is False) or the length of the slice of Item preceding the + -- first nul (if Trim_Nul is True). The lower bound of the result is 1. + -- If Trim_Nul is False, then for each component Item(I) the corresponding + -- component in the result is To_Ada applied to Item(I). If Trim_Nul + -- is True, then for each component Item(I) before the first nul the + -- corresponding component in the result is To_Ada applied to Item(I). The + -- function propagates Terminator_Error if Trim_Nul is True and Item does + -- not contain nul. + + procedure To_C + (Item : String; + Target : out char_array; + Count : out size_t; + Append_Nul : Boolean := True) + with + Relaxed_Initialization => Target, + Pre => Target'Length >= + (if Append_Nul then Item'Length + 1 else Item'Length), + Post => Count = (if Append_Nul then Item'Length + 1 else Item'Length) + and then + (if Count /= 0 then + Target (Target'First .. Target'First + (Count - 1))'Initialized) + and then + (for all J in Item'Range => + Target (Target'First + size_t (J - Item'First)) = To_C (Item (J))) + and then + (if Append_Nul then Target (Target'First + (Count - 1)) = nul); + -- For procedure To_C, each element of Item is converted (via the To_C + -- function) to a char, which is assigned to the corresponding element of + -- Target. If Append_Nul is True, nul is then assigned to the next element + -- of Target. In either case, Count is set to the number of Target elements + -- assigned. If Target is not long enough, Constraint_Error is propagated. + + procedure To_Ada + (Item : char_array; + Target : out String; + Count : out Natural; + Trim_Nul : Boolean := True) + with + Relaxed_Initialization => Target, + Pre => (if Trim_Nul then + Is_Nul_Terminated (Item) + and then C_Length_Ghost (Item) <= size_t (Target'Length) + else + Item'Last - Item'First < size_t (Target'Length)), + Post => Count = + (if Trim_Nul then Natural (C_Length_Ghost (Item)) else Item'Length) + and then + (if Count /= 0 then + Target (Target'First .. Target'First + (Count - 1))'Initialized) + and then + (for all J in Target'First .. Target'First + (Count - 1) => + Target (J) = + To_Ada (Item (size_t (J - Target'First) + Item'First))); + -- For procedure To_Ada, each element of Item (if Trim_Nul is False) or + -- each element of Item preceding the first nul (if Trim_Nul is True) is + -- converted (via the To_Ada function) to a Character, which is assigned + -- to the corresponding element of Target. Count is set to the number of + -- Target elements assigned. If Target is not long enough, Constraint_Error + -- is propagated. If Trim_Nul is True and Item does not contain nul, then + -- Terminator_Error is propagated. + + ------------------------------------ + -- Wide Character and Wide String -- + ------------------------------------ + + type wchar_t is new Wide_Character; + for wchar_t'Size use Standard'Wchar_T_Size; + + wide_nul : constant wchar_t := wchar_t'First; + + -- To_C and To_Ada provide the mappings between the Ada and C wide + -- character types. + + function To_C (Item : Wide_Character) return wchar_t + with + Post => To_C'Result = wchar_t (Item); + + function To_Ada (Item : wchar_t) return Wide_Character + with + Post => To_Ada'Result = Wide_Character (Item); + + type wchar_array is array (size_t range <>) of aliased wchar_t; + + function Is_Nul_Terminated (Item : wchar_array) return Boolean + with + Post => Is_Nul_Terminated'Result = (for some C of Item => C = wide_nul); + -- The result of Is_Nul_Terminated is True if Item contains wide_nul, and + -- is False otherwise. + + -- The To_C and To_Ada subprograms that convert between Wide_String and + -- wchar_array have analogous effects to the To_C and To_Ada subprograms + -- that convert between String and char_array, except that wide_nul is + -- used instead of nul. + + function C_Length_Ghost (Item : wchar_array) return size_t + with + Ghost, + Pre => Is_Nul_Terminated (Item), + Post => C_Length_Ghost'Result <= Item'Last - Item'First + and then Item (Item'First + C_Length_Ghost'Result) = wide_nul + and then (for all J in Item'First .. Item'First + C_Length_Ghost'Result + when J /= Item'First + C_Length_Ghost'Result => + Item (J) /= wide_nul); + -- Ghost function to compute the length of a wchar_array up to the first + -- wide_nul character. + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return wchar_array + with + Pre => not (Append_Nul = False and then Item'Length = 0), + Post => To_C'Result'First = 0 + and then To_C'Result'Length = + (if Append_Nul then Item'Length + 1 else Item'Length) + and then (for all J in Item'Range => + To_C'Result (size_t (J - Item'First)) = To_C (Item (J))) + and then (if Append_Nul then To_C'Result (To_C'Result'Last) = wide_nul); + + function To_Ada + (Item : wchar_array; + Trim_Nul : Boolean := True) return Wide_String + with + Pre => (if Trim_Nul then + Is_Nul_Terminated (Item) + and then C_Length_Ghost (Item) <= size_t (Natural'Last) + else + Item'Last - Item'First < size_t (Natural'Last)), + Post => To_Ada'Result'First = 1 + and then To_Ada'Result'Length = + (if Trim_Nul then C_Length_Ghost (Item) else Item'Length) + and then (for all J in To_Ada'Result'Range => + To_Ada'Result (J) = + To_Ada (Item (size_t (J) - 1 + Item'First))); + + procedure To_C + (Item : Wide_String; + Target : out wchar_array; + Count : out size_t; + Append_Nul : Boolean := True) + with + Relaxed_Initialization => Target, + Pre => Target'Length >= + (if Append_Nul then Item'Length + 1 else Item'Length), + Post => Count = (if Append_Nul then Item'Length + 1 else Item'Length) + and then + (if Count /= 0 then + Target (Target'First .. Target'First + (Count - 1))'Initialized) + and then + (for all J in Item'Range => + Target (Target'First + size_t (J - Item'First)) = To_C (Item (J))) + and then + (if Append_Nul then Target (Target'First + (Count - 1)) = wide_nul); + + procedure To_Ada + (Item : wchar_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + with + Relaxed_Initialization => Target, + Pre => (if Trim_Nul then + Is_Nul_Terminated (Item) + and then C_Length_Ghost (Item) <= size_t (Target'Length) + else + Item'Last - Item'First < size_t (Target'Length)), + Post => Count = + (if Trim_Nul then Natural (C_Length_Ghost (Item)) else Item'Length) + and then + (if Count /= 0 then + Target (Target'First .. Target'First + (Count - 1))'Initialized) + and then + (for all J in Target'First .. Target'First + (Count - 1) => + Target (J) = + To_Ada (Item (size_t (J - Target'First) + Item'First))); + + Terminator_Error : exception; + + -- The remaining declarations are for Ada 2005 (AI-285) + + -- ISO/IEC 10646:2003 compatible types defined by SC22/WG14 document N1010 + + type char16_t is new Wide_Character; + pragma Ada_05 (char16_t); + + char16_nul : constant char16_t := char16_t'Val (0); + pragma Ada_05 (char16_nul); + + -- To_C and To_Ada provide mappings between the Ada and C 16-bit character + -- types. + + function To_C (Item : Wide_Character) return char16_t + with + Post => To_C'Result = char16_t (Item); + pragma Ada_05 (To_C); + + function To_Ada (Item : char16_t) return Wide_Character + with + Post => To_Ada'Result = Wide_Character (Item); + pragma Ada_05 (To_Ada); + + type char16_array is array (size_t range <>) of aliased char16_t; + pragma Ada_05 (char16_array); + + function Is_Nul_Terminated (Item : char16_array) return Boolean + with + Post => Is_Nul_Terminated'Result = (for some C of Item => C = char16_nul); + pragma Ada_05 (Is_Nul_Terminated); + -- The result of Is_Nul_Terminated is True if Item contains char16_nul, and + -- is False otherwise. + + -- The To_C and To_Ada subprograms that convert between Wide_String and + -- char16_array have analogous effects to the To_C and To_Ada subprograms + -- that convert between String and char_array, except that char16_nul is + -- used instead of nul. + + function C_Length_Ghost (Item : char16_array) return size_t + with + Ghost, + Pre => Is_Nul_Terminated (Item), + Post => C_Length_Ghost'Result <= Item'Last - Item'First + and then Item (Item'First + C_Length_Ghost'Result) = char16_nul + and then (for all J in Item'First .. Item'First + C_Length_Ghost'Result + when J /= Item'First + C_Length_Ghost'Result => + Item (J) /= char16_nul); + -- Ghost function to compute the length of a char16_array up to the first + -- char16_nul character. + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return char16_array + with + Pre => not (Append_Nul = False and then Item'Length = 0), + Post => To_C'Result'First = 0 + and then To_C'Result'Length = + (if Append_Nul then Item'Length + 1 else Item'Length) + and then (for all J in Item'Range => + To_C'Result (size_t (J - Item'First)) = To_C (Item (J))) + and then + (if Append_Nul then To_C'Result (To_C'Result'Last) = char16_nul); + pragma Ada_05 (To_C); + + function To_Ada + (Item : char16_array; + Trim_Nul : Boolean := True) return Wide_String + with + Pre => (if Trim_Nul then + Is_Nul_Terminated (Item) + and then C_Length_Ghost (Item) <= size_t (Natural'Last) + else + Item'Last - Item'First < size_t (Natural'Last)), + Post => To_Ada'Result'First = 1 + and then To_Ada'Result'Length = + (if Trim_Nul then C_Length_Ghost (Item) else Item'Length) + and then (for all J in To_Ada'Result'Range => + To_Ada'Result (J) = + To_Ada (Item (size_t (J) - 1 + Item'First))); + pragma Ada_05 (To_Ada); + + procedure To_C + (Item : Wide_String; + Target : out char16_array; + Count : out size_t; + Append_Nul : Boolean := True) + with + Relaxed_Initialization => Target, + Pre => Target'Length >= + (if Append_Nul then Item'Length + 1 else Item'Length), + Post => Count = (if Append_Nul then Item'Length + 1 else Item'Length) + and then + (if Count /= 0 then + Target (Target'First .. Target'First + (Count - 1))'Initialized) + and then + (for all J in Item'Range => + Target (Target'First + size_t (J - Item'First)) = To_C (Item (J))) + and then + (if Append_Nul then Target (Target'First + (Count - 1)) = char16_nul); + pragma Ada_05 (To_C); + + procedure To_Ada + (Item : char16_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + with + Relaxed_Initialization => Target, + Pre => (if Trim_Nul then + Is_Nul_Terminated (Item) + and then C_Length_Ghost (Item) <= size_t (Target'Length) + else + Item'Last - Item'First < size_t (Target'Length)), + Post => Count = + (if Trim_Nul then Natural (C_Length_Ghost (Item)) else Item'Length) + and then + (if Count /= 0 then + Target (Target'First .. Target'First + (Count - 1))'Initialized) + and then + (for all J in Target'First .. Target'First + (Count - 1) => + Target (J) = + To_Ada (Item (size_t (J - Target'First) + Item'First))); + pragma Ada_05 (To_Ada); + + type char32_t is new Wide_Wide_Character; + pragma Ada_05 (char32_t); + + char32_nul : constant char32_t := char32_t'Val (0); + pragma Ada_05 (char32_nul); + + -- To_C and To_Ada provide mappings between the Ada and C 32-bit character + -- types. + + function To_C (Item : Wide_Wide_Character) return char32_t + with + Post => To_C'Result = char32_t (Item); + pragma Ada_05 (To_C); + + function To_Ada (Item : char32_t) return Wide_Wide_Character + with + Post => To_Ada'Result = Wide_Wide_Character (Item); + pragma Ada_05 (To_Ada); + + type char32_array is array (size_t range <>) of aliased char32_t; + pragma Ada_05 (char32_array); + + function Is_Nul_Terminated (Item : char32_array) return Boolean + with + Post => Is_Nul_Terminated'Result = (for some C of Item => C = char32_nul); + pragma Ada_05 (Is_Nul_Terminated); + -- The result of Is_Nul_Terminated is True if Item contains char32_nul, and + -- is False otherwise. + + function C_Length_Ghost (Item : char32_array) return size_t + with + Ghost, + Pre => Is_Nul_Terminated (Item), + Post => C_Length_Ghost'Result <= Item'Last - Item'First + and then Item (Item'First + C_Length_Ghost'Result) = char32_nul + and then (for all J in Item'First .. Item'First + C_Length_Ghost'Result + when J /= Item'First + C_Length_Ghost'Result => + Item (J) /= char32_nul); + -- Ghost function to compute the length of a char32_array up to the first + -- char32_nul character. + + -- The To_C and To_Ada subprograms that convert between Wide_Wide_String + -- and char32_array have analogous effects to the To_C and To_Ada + -- subprograms that convert between String and char_array, except + -- that char32_nul is used instead of nul. + + function To_C + (Item : Wide_Wide_String; + Append_Nul : Boolean := True) return char32_array + with + Pre => not (Append_Nul = False and then Item'Length = 0), + Post => To_C'Result'First = 0 + and then To_C'Result'Length = + (if Append_Nul then Item'Length + 1 else Item'Length) + and then (for all J in Item'Range => + To_C'Result (size_t (J - Item'First)) = To_C (Item (J))) + and then + (if Append_Nul then To_C'Result (To_C'Result'Last) = char32_nul); + pragma Ada_05 (To_C); + + function To_Ada + (Item : char32_array; + Trim_Nul : Boolean := True) return Wide_Wide_String + with + Pre => (if Trim_Nul then + Is_Nul_Terminated (Item) + and then C_Length_Ghost (Item) <= size_t (Natural'Last) + else + Item'Last - Item'First < size_t (Natural'Last)), + Post => To_Ada'Result'First = 1 + and then To_Ada'Result'Length = + (if Trim_Nul then C_Length_Ghost (Item) else Item'Length) + and then (for all J in To_Ada'Result'Range => + To_Ada'Result (J) = + To_Ada (Item (size_t (J) - 1 + Item'First))); + pragma Ada_05 (To_Ada); + + procedure To_C + (Item : Wide_Wide_String; + Target : out char32_array; + Count : out size_t; + Append_Nul : Boolean := True) + with + Relaxed_Initialization => Target, + Pre => Target'Length >= + (if Append_Nul then Item'Length + 1 else Item'Length), + Post => Count = (if Append_Nul then Item'Length + 1 else Item'Length) + and then + (if Count /= 0 then + Target (Target'First .. Target'First + (Count - 1))'Initialized) + and then + (for all J in Item'Range => + Target (Target'First + size_t (J - Item'First)) = To_C (Item (J))) + and then + (if Append_Nul then Target (Target'First + (Count - 1)) = char32_nul); + pragma Ada_05 (To_C); + + procedure To_Ada + (Item : char32_array; + Target : out Wide_Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + with + Relaxed_Initialization => Target, + Pre => (if Trim_Nul then + Is_Nul_Terminated (Item) + and then C_Length_Ghost (Item) <= size_t (Target'Length) + else + Item'Last - Item'First < size_t (Target'Length)), + Post => Count = + (if Trim_Nul then Natural (C_Length_Ghost (Item)) else Item'Length) + and then + (if Count /= 0 then + Target (Target'First .. Target'First + (Count - 1))'Initialized) + and then + (for all J in Target'First .. Target'First + (Count - 1) => + Target (J) = + To_Ada (Item (size_t (J - Target'First) + Item'First))); + pragma Ada_05 (To_Ada);
end Interfaces.C; diff --git a/src/lib/gnat/interfac.ads b/src/lib/gnat/interfac.ads index 96f4b47..b269869 100644 --- a/src/lib/gnat/interfac.ads +++ b/src/lib/gnat/interfac.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2022, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -33,8 +33,12 @@ -- -- ------------------------------------------------------------------------------
+-- This is the compiler version of this unit + package Interfaces is + pragma No_Elaboration_Code_All; pragma Pure; + pragma Annotate (GNATprove, Always_Return, Interfaces);
-- All identifiers in this unit are implementation defined
@@ -63,6 +67,11 @@ type Unsigned_16 is mod 2 ** 16; for Unsigned_16'Size use 16;
+ type Unsigned_24 is mod 2 ** 24; + for Unsigned_24'Size use 24; + -- Declare this type for compatibility with legacy Ada compilers. + -- This is particularly useful in the context of CodePeer analysis. + type Unsigned_32 is mod 2 ** 32; for Unsigned_32'Size use 32;
@@ -156,4 +165,21 @@ pragma Import (Intrinsic, Rotate_Left); pragma Import (Intrinsic, Rotate_Right);
+ -- IEEE Floating point types + + type IEEE_Float_32 is digits 6; + for IEEE_Float_32'Size use 32; + + type IEEE_Float_64 is digits 15; + for IEEE_Float_64'Size use 64; + + -- If there is an IEEE extended float available on the machine, we assume + -- that it is available as Long_Long_Float. + + -- Note: it is harmless, and explicitly permitted, to include additional + -- types in interfaces, so it is not wrong to have IEEE_Extended_Float + -- defined even if the extended format is not available. + + type IEEE_Extended_Float is new Long_Long_Float; + end Interfaces; diff --git a/src/lib/gnat/s-atacco.ads b/src/lib/gnat/s-atacco.ads index fb6232d..a928d47 100644 --- a/src/lib/gnat/s-atacco.ads +++ b/src/lib/gnat/s-atacco.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -54,8 +54,12 @@ -- optimizations that may cause unexpected results based on the assumption -- of no strict aliasing.
- function To_Pointer (Value : Address) return Object_Pointer; - function To_Address (Value : Object_Pointer) return Address; + function To_Pointer (Value : Address) return Object_Pointer with + Global => null, + Annotate => (GNATprove, Always_Return); + function To_Address (Value : Object_Pointer) return Address with + SPARK_Mode => Off, + Annotate => (GNATprove, Always_Return);
pragma Import (Intrinsic, To_Pointer); pragma Import (Intrinsic, To_Address); diff --git a/src/lib/gnat/s-exctab.ads b/src/lib/gnat/s-exctab.ads new file mode 100644 index 0000000..07a12c1 --- /dev/null +++ b/src/lib/gnat/s-exctab.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N _ T A B L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2022, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements the interface used to maintain a table of +-- registered exception names, for the implementation of the mapping +-- of names to exceptions (used for exception streams and attributes) + +with System.Standard_Library; + +package System.Exception_Table is + pragma Elaborate_Body; + + package SSL renames System.Standard_Library; + + procedure Register_Exception (X : SSL.Exception_Data_Ptr); + pragma Inline (Register_Exception); + -- Register an exception in the hash table mapping. This function is + -- called during elaboration of library packages. For exceptions that + -- are declared within subprograms, the registration occurs the first + -- time that an exception is elaborated during a call of the subprogram. + -- + -- Note: all calls to Register_Exception other than those to register the + -- predefined exceptions are suppressed if the application is compiled + -- with pragma Restrictions (No_Exception_Registration). + + function Internal_Exception + (X : String; + Create_If_Not_Exist : Boolean := True) return SSL.Exception_Data_Ptr; + -- Given an exception_name X, returns a pointer to the actual internal + -- exception data. A new entry is created in the table if X does not + -- exist yet and Create_If_Not_Exist is True. If it is false and X + -- does not exist yet, null is returned. + + function Registered_Exceptions_Count return Natural; + -- Return the number of currently registered exceptions + + type Exception_Data_Array is array (Natural range <>) + of SSL.Exception_Data_Ptr; + + procedure Get_Registered_Exceptions + (List : out Exception_Data_Array; + Last : out Integer); + -- Return the list of registered exceptions + +end System.Exception_Table; diff --git a/src/lib/gnat/s-imagen.adb b/src/lib/gnat/s-imagen.adb new file mode 100644 index 0000000..cd8e170 --- /dev/null +++ b/src/lib/gnat/s-imagen.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M A G E _ N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2021-2022, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body System.Image_N is + + ----------------------- + -- Image_Enumeration -- + ----------------------- + + procedure Image_Enumeration + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + is + pragma Assert (S'First = 1); + + subtype Names_Index is + Index_Type range Index_Type (Names'First) + .. Index_Type (Names'Last) + 1; + subtype Index is Natural range Natural'First .. Names'Length; + type Index_Table is array (Index) of Names_Index; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + pragma Assert (Pos in IndexesT'Range); + pragma Assert (Pos + 1 in IndexesT'Range); + + Start : constant Natural := Natural (IndexesT (Pos)); + Next : constant Natural := Natural (IndexesT (Pos + 1)); + + pragma Assert (Next - 1 >= Start); + pragma Assert (Start >= Names'First); + pragma Assert (Next - 1 <= Names'Last); + + pragma Assert (Next - Start <= S'Last); + -- The caller should guarantee that S is large enough to contain the + -- enumeration image. + begin + S (1 .. Next - Start) := Names (Start .. Next - 1); + P := Next - Start; + end Image_Enumeration; + +end System.Image_N; diff --git a/src/lib/gnat/s-imen16.ads b/src/lib/gnat/s-imen16.ads new file mode 100644 index 0000000..b7192c2 --- /dev/null +++ b/src/lib/gnat/s-imen16.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M _ 1 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021-2022, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Image_N for enumeration types whose names table +-- has a length that fits in a 16-bit but not a 8-bit integer. + +with Interfaces; +with System.Image_N; + +package System.Img_Enum_16 is + pragma Pure; + + package Impl is new Image_N (Interfaces.Integer_16); + + procedure Image_Enumeration_16 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + renames Impl.Image_Enumeration; + +end System.Img_Enum_16; diff --git a/src/lib/gnat/s-imen32.ads b/src/lib/gnat/s-imen32.ads new file mode 100644 index 0000000..96a1b34 --- /dev/null +++ b/src/lib/gnat/s-imen32.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021-2022, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Image_N for enumeration types whose names table +-- has a length that fits in a 32-bit but not a 16-bit integer. + +with Interfaces; +with System.Image_N; + +package System.Img_Enum_32 is + pragma Pure; + + package Impl is new Image_N (Interfaces.Integer_32); + + procedure Image_Enumeration_32 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + renames Impl.Image_Enumeration; + +end System.Img_Enum_32; diff --git a/src/lib/gnat/s-imenne.adb b/src/lib/gnat/s-imenne.adb deleted file mode 100644 index de57766..0000000 --- a/src/lib/gnat/s-imenne.adb +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ E N U M _ N E W -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- http://www.gnu.org/licenses/. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Assertion_Policy (Statement_Assertions => Ignore); - -with Ada.Unchecked_Conversion; - -package body System.Img_Enum_New is - - ------------------------- - -- Image_Enumeration_8 -- - ------------------------- - - procedure Image_Enumeration_8 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - is - pragma Assert (S'First = 1); - - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - begin - S (1 .. Next - Start) := Names (Start .. Next - 1); - P := Next - Start; - end Image_Enumeration_8; - - -------------------------- - -- Image_Enumeration_16 -- - -------------------------- - - procedure Image_Enumeration_16 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - is - pragma Assert (S'First = 1); - - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - begin - S (1 .. Next - Start) := Names (Start .. Next - 1); - P := Next - Start; - end Image_Enumeration_16; - - -------------------------- - -- Image_Enumeration_32 -- - -------------------------- - - procedure Image_Enumeration_32 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - is - pragma Assert (S'First = 1); - - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - begin - S (1 .. Next - Start) := Names (Start .. Next - 1); - P := Next - Start; - end Image_Enumeration_32; - -end System.Img_Enum_New; diff --git a/src/lib/gnat/s-imenne.ads b/src/lib/gnat/s-imenne.ads deleted file mode 100644 index ce470fd..0000000 --- a/src/lib/gnat/s-imenne.ads +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ E N U M _ N E W -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- http://www.gnu.org/licenses/. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Enumeration_Type'Image for all enumeration types except those in package --- Standard (where we have no opportunity to build image tables), and in --- package System (where it is too early to start building image tables). --- Special routines exist for the enumeration types in these packages. - --- This is the new version of the package, for use by compilers built after --- Nov 21st, 2007, which provides procedures that avoid using the secondary --- stack. The original package System.Img_Enum is maintained in the sources --- for bootstrapping with older versions of the compiler which expect to find --- functions in this package. - -package System.Img_Enum_New is - pragma Pure; - - procedure Image_Enumeration_8 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Used to compute Enum'Image (Str) where Enum is some enumeration type - -- other than those defined in package Standard. Names is a string with - -- a lower bound of 1 containing the characters of all the enumeration - -- literals concatenated together in sequence. Indexes is the address of - -- an array of type array (0 .. N) of Natural_8, where N is the number of - -- enumeration literals in the type. The Indexes values are the starting - -- subscript of each enumeration literal, indexed by Pos values, with an - -- extra entry at the end containing Names'Length + 1. The reason that - -- Indexes is passed by address is that the actual type is created on the - -- fly by the expander. The desired 'Image value is stored in S (1 .. P) - -- and P is set on return. The caller guarantees that S is long enough to - -- hold the result and that the lower bound is 1. - - procedure Image_Enumeration_16 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Identical to Set_Image_Enumeration_8 except that it handles types using - -- array (0 .. Num) of Natural_16 for the Indexes table. - - procedure Image_Enumeration_32 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Identical to Set_Image_Enumeration_8 except that it handles types using - -- array (0 .. Num) of Natural_32 for the Indexes table. - -end System.Img_Enum_New; diff --git a/src/lib/gnat/s-imenu8.ads b/src/lib/gnat/s-imenu8.ads new file mode 100644 index 0000000..cdd5a5f --- /dev/null +++ b/src/lib/gnat/s-imenu8.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M _ 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2021-2022, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Instantiation of System.Image_N for enumeration types whose names table +-- has a length that fits in a 8-bit integer. + +with Interfaces; +with System.Image_N; + +package System.Img_Enum_8 is + pragma Pure; + + package Impl is new Image_N (Interfaces.Integer_8); + + procedure Image_Enumeration_8 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + renames Impl.Image_Enumeration; + +end System.Img_Enum_8; diff --git a/src/lib/gnat/s-maccod.ads b/src/lib/gnat/s-maccod.ads index a95e319..df7c7df 100644 --- a/src/lib/gnat/s-maccod.ads +++ b/src/lib/gnat/s-maccod.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2022, 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- -- @@ -33,7 +33,10 @@ -- operations, and also for machine code statements. See GNAT documentation -- for full details.
-package System.Machine_Code is +package System.Machine_Code + with SPARK_Mode => Off +is + pragma No_Elaboration_Code_All; pragma Pure;
-- All identifiers in this unit are implementation defined diff --git a/src/lib/gnat/s-parame.ads b/src/lib/gnat/s-parame.ads index b3682ba..4b81114 100644 --- a/src/lib/gnat/s-parame.ads +++ b/src/lib/gnat/s-parame.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2022, 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- -- @@ -49,6 +49,62 @@ package System.Parameters is pragma Pure;
+ --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Size_Type is range + -(2 ** (Integer'(Standard'Address_Size) - 1)) .. + +(2 ** (Integer'(Standard'Address_Size) - 1)) - 1; + -- Type used to provide task stack sizes to the runtime. Sized to permit + -- stack sizes of up to half the total addressable memory space. This may + -- seem excessively large (even for 32-bit systems), however there are many + -- instances of users requiring large stack sizes (for example string + -- processing). + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information is + -- available. This value is used when stack checking is enabled and + -- no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + Runtime_Default_Sec_Stack_Size : constant Size_Type := 10 * 1024; + -- The run-time chosen default size for secondary stacks that may be + -- overridden by the user with the use of binder -D switch. + + Sec_Stack_Dynamic : constant Boolean := True; + -- Indicates if secondary stacks can grow and shrink at run-time. If False, + -- the size of a secondary stack is fixed at the point of its creation. + + ------------------------------------ + -- Characteristics of time_t type -- + ------------------------------------ + + time_t_bits : constant := Long_Integer'Size; + -- Number of bits in type time_t + ---------------------------------------------- -- Characteristics of types in Interfaces.C -- ---------------------------------------------- @@ -59,6 +115,76 @@ -- of all targets.
ptr_bits : constant := Standard'Address_Size; + subtype C_Address is System.Address; -- Number of bits in Interfaces.C pointers, normally a standard address
+ C_Malloc_Linkname : constant String := "__gnat_malloc"; + -- Name of runtime function used to allocate such a pointer + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Max_Attribute_Count : constant := 32; + -- Number of task attributes stored in the task control block + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 200; + -- This constant specifies the default number of characters to allow + -- in an exception message (200 is minimum required by RM 11.4.1(18)). + end System.Parameters; diff --git a/src/lib/gnat/s-stalib.ads b/src/lib/gnat/s-stalib.ads new file mode 100644 index 0000000..9182c67 --- /dev/null +++ b/src/lib/gnat/s-stalib.ads @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T A N D A R D _ L I B R A R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2022, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is included in all programs. It contains declarations that +-- are required to be part of every Ada program. A special mechanism is +-- required to ensure that these are loaded, since it may be the case in +-- some programs that the only references to these required packages are +-- from C code or from code generated directly by Gigi, and in both cases +-- the binder is not aware of such references. + +-- System.Standard_Library also includes data that must be present in every +-- program, in particular data for all the standard exceptions, and also some +-- subprograms that must be present in every program. + +-- The binder unconditionally includes s-stalib.ali, which ensures that this +-- package and the packages it references are included in all Ada programs, +-- together with the included data. + +with Ada.Unchecked_Conversion; + +package System.Standard_Library is + + -- Historical note: pragma Preelaborate was surrounded by a pair of pragma + -- Warnings (Off/On) to circumvent a bootstrap issue. + + pragma Preelaborate; + + subtype Big_String is String (1 .. Positive'Last); + pragma Suppress_Initialization (Big_String); + -- Type used to obtain string access to given address. Initialization is + -- suppressed, since we never want to have variables of this type, and + -- we never want to attempt initialiazation of virtual variables of this + -- type (e.g. when pragma Normalize_Scalars is used). + + type Big_String_Ptr is access all Big_String; + for Big_String_Ptr'Storage_Size use 0; + -- We use this access type to pass a pointer to an area of storage to be + -- accessed as a string. Of course when this pointer is used, it is the + -- responsibility of the accessor to ensure proper bounds. The storage + -- size clause ensures we do not allocate variables of this type. + + function To_Ptr is + new Ada.Unchecked_Conversion (System.Address, Big_String_Ptr); + + ------------------------------------- + -- Exception Declarations and Data -- + ------------------------------------- + + type Raise_Action is access procedure; + pragma Favor_Top_Level (Raise_Action); + -- A pointer to a procedure used in the Raise_Hook field + + type Exception_Data; + type Exception_Data_Ptr is access all Exception_Data; + -- An equivalent of Exception_Id that is public + + -- The following record defines the underlying representation of exceptions + + -- WARNING: Any change to the record needs to be reflected in the following + -- locations in the compiler and runtime code: + + -- 1. The construction of the exception type in Cstand + -- 2. Expand_N_Exception_Declaration in Exp_Ch11 + -- 3. Expand_Pragma_Import_Or_Interface in Exp_Prag + -- 4. The processing in gigi that tests Not_Handled_By_Others + -- 5. The Internal_Exception routine in s-exctab.adb + -- 6. The declaration of the corresponding C type in raise.h + + type Exception_Data is record + Not_Handled_By_Others : aliased Boolean; + -- Normally set False, indicating that the exception is handled in the + -- usual way by others (i.e. an others handler handles the exception). + -- Set True to indicate that this exception is not caught by others + -- handlers, but must be explicitly named in a handler. This latter + -- setting is currently used by the Abort_Signal. + + Lang : aliased Character; + -- A character indicating the language raising the exception. + -- Set to "A" for exceptions defined by an Ada program. + -- Set to "C" for imported C++ exceptions. + + Name_Length : aliased Natural; + -- Length of fully expanded name of exception + + Full_Name : aliased System.Address; + -- Fully expanded name of exception, null terminated + -- You can use To_Ptr to convert this to a string. + + HTable_Ptr : aliased Exception_Data_Ptr; + -- Hash table pointer used to link entries together in the hash table + -- built (by Register_Exception in s-exctab.adb) for converting between + -- identities and names. + + Foreign_Data : aliased System.Address; + -- Data for imported exceptions. Not used in the Ada case. This + -- represents the address of the RTTI for the C++ case. + + Raise_Hook : aliased Raise_Action; + -- This field can be used to place a "hook" on an exception. If the + -- value is non-null, then it points to a procedure which is called + -- whenever the exception is raised. This call occurs immediately, + -- before any other actions taken by the raise (and in particular + -- before any unwinding of the stack occurs). + end record; + + -- Definitions for standard predefined exceptions defined in Standard, + + -- Why are the NULs necessary here, seems like they should not be + -- required, since Gigi is supposed to add a Nul to each name ??? + + Constraint_Error_Name : constant String := "CONSTRAINT_ERROR" & ASCII.NUL; + Program_Error_Name : constant String := "PROGRAM_ERROR" & ASCII.NUL; + Storage_Error_Name : constant String := "STORAGE_ERROR" & ASCII.NUL; + Tasking_Error_Name : constant String := "TASKING_ERROR" & ASCII.NUL; + Abort_Signal_Name : constant String := "_ABORT_SIGNAL" & ASCII.NUL; + + Numeric_Error_Name : constant String := "NUMERIC_ERROR" & ASCII.NUL; + -- This is used only in the Ada 83 case, but it is not worth having a + -- separate version of s-stalib.ads for use in Ada 83 mode. + + Constraint_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Constraint_Error_Name'Length, + Full_Name => Constraint_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Numeric_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Numeric_Error_Name'Length, + Full_Name => Numeric_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Program_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Program_Error_Name'Length, + Full_Name => Program_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Storage_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Storage_Error_Name'Length, + Full_Name => Storage_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Tasking_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Tasking_Error_Name'Length, + Full_Name => Tasking_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Abort_Signal_Def : aliased Exception_Data := + (Not_Handled_By_Others => True, + Lang => 'A', + Name_Length => Abort_Signal_Name'Length, + Full_Name => Abort_Signal_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + pragma Export (C, Constraint_Error_Def, "constraint_error"); + pragma Export (C, Numeric_Error_Def, "numeric_error"); + pragma Export (C, Program_Error_Def, "program_error"); + pragma Export (C, Storage_Error_Def, "storage_error"); + pragma Export (C, Tasking_Error_Def, "tasking_error"); + pragma Export (C, Abort_Signal_Def, "_abort_signal"); + + Local_Partition_ID : Natural := 0; + -- This variable contains the local Partition_ID that will be used when + -- building exception occurrences. In distributed mode, it will be + -- set by each partition to the correct value during the elaboration. + + type Exception_Trace_Kind is + (RM_Convention, + -- No particular trace is requested, only unhandled exceptions + -- in the environment task (following the RM) will be printed. + -- This is the default behavior. + + Every_Raise, + -- Denotes the initial raise event for any exception occurrence, either + -- explicit or due to a specific language rule, within the context of a + -- task or not. + + Unhandled_Raise, + -- Denotes the raise events corresponding to exceptions for which there + -- is no user defined handler. This includes unhandled exceptions in + -- task bodies. + + Unhandled_Raise_In_Main + -- Same as Unhandled_Raise, except exceptions in task bodies are not + -- included. Same as RM_Convention, except (1) the message is printed as + -- soon as the environment task completes due to an unhandled exception + -- (before awaiting the termination of dependent tasks, and before + -- library-level finalization), and (2) a symbolic traceback is given + -- if possible. This is the default behavior if the binder switch -E is + -- used. + ); + -- Provide a way to denote different kinds of automatic traces related + -- to exceptions that can be requested. + + Exception_Trace : Exception_Trace_Kind := RM_Convention; + pragma Atomic (Exception_Trace); + -- By default, follow the RM convention + + ----------------- + -- Subprograms -- + ----------------- + + procedure Abort_Undefer_Direct; + pragma Inline (Abort_Undefer_Direct); + -- A little procedure that just calls Abort_Undefer.all, for use in + -- clean up procedures, which only permit a simple subprogram name. + + procedure Adafinal; + -- Performs the Ada Runtime finalization the first time it is invoked. + -- All subsequent calls are ignored. + +end System.Standard_Library; diff --git a/src/lib/gnat/s-stoele.adb b/src/lib/gnat/s-stoele.adb index 77faa53..f804e6d 100644 --- a/src/lib/gnat/s-stoele.adb +++ b/src/lib/gnat/s-stoele.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2022, 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- -- diff --git a/src/lib/gnat/s-stoele.ads b/src/lib/gnat/s-stoele.ads index 78faa1d..d047368 100644 --- a/src/lib/gnat/s-stoele.ads +++ b/src/lib/gnat/s-stoele.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 2002-2022, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -43,6 +43,8 @@ -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada 2005, -- this is Pure in any case (AI-362).
+ pragma Annotate (GNATprove, Always_Return, Storage_Elements); + -- We also add the pragma Pure_Function to the operations in this package, -- because otherwise functions with parameters derived from Address are -- treated as non-pure by the back-end (see exp_ch6.adb). This is because @@ -54,8 +56,7 @@ +(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1); -- Note: the reason for the Long_Long_Integer qualification here is to -- avoid a bogus ambiguity when this unit is analyzed in an rtsfind - -- context. It may be possible to remove this in the future, but it is - -- certainly harmless in any case ??? + -- context.
subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last;
diff --git a/src/lib/gnat/s-traent.adb b/src/lib/gnat/s-traent.adb new file mode 100644 index 0000000..6f615b0 --- /dev/null +++ b/src/lib/gnat/s-traent.adb @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K _ E N T R I E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2022, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Traceback_Entries is + + ------------ + -- PC_For -- + ------------ + + function PC_For (TB_Entry : Traceback_Entry) return System.Address is + begin + return TB_Entry; + end PC_For; + + ------------------ + -- TB_Entry_For -- + ------------------ + + function TB_Entry_For (PC : System.Address) return Traceback_Entry is + begin + return PC; + end TB_Entry_For; + +end System.Traceback_Entries; diff --git a/src/lib/gnat/s-traent.ads b/src/lib/gnat/s-traent.ads new file mode 100644 index 0000000..23e327c --- /dev/null +++ b/src/lib/gnat/s-traent.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K _ E N T R I E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2022, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the contents of the part following the private keyword. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- http://www.gnu.org/licenses/. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package offers an abstraction of what is stored in traceback arrays +-- for call-chain computation purposes. By default, as defined in this +-- version of the package, an entry is a mere code location representing the +-- address of a call instruction part of the call-chain. + +package System.Traceback_Entries is + pragma Preelaborate; + + subtype Traceback_Entry is System.Address; + -- This subtype defines what each traceback array entry contains + + Null_TB_Entry : constant Traceback_Entry := System.Null_Address; + -- This is the value to be used when initializing an entry + + type Tracebacks_Array is array (Positive range <>) of Traceback_Entry; + + function PC_For (TB_Entry : Traceback_Entry) return System.Address; + pragma Inline (PC_For); + -- Returns the address of the call instruction associated with the + -- provided entry. + + function TB_Entry_For (PC : System.Address) return Traceback_Entry; + pragma Inline (TB_Entry_For); + -- Returns an entry representing a frame for a call instruction at PC + +end System.Traceback_Entries; diff --git a/src/lib/gnat/s-unstyp.ads b/src/lib/gnat/s-unstyp.ads index de4affc..2a700a0 100644 --- a/src/lib/gnat/s-unstyp.ads +++ b/src/lib/gnat/s-unstyp.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2022, 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- -- @@ -37,19 +37,18 @@
package System.Unsigned_Types is pragma Pure; + pragma No_Elaboration_Code_All;
- type Short_Short_Unsigned is mod 2 ** Short_Short_Integer'Size; - type Short_Unsigned is mod 2 ** Short_Integer'Size; - type Unsigned is mod 2 ** Integer'Size; - type Long_Unsigned is mod 2 ** Long_Integer'Size; - type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size; - - type Float_Unsigned is mod 2 ** Float'Size; - -- Used in the implementation of Is_Negative intrinsic (see Exp_Intr) + type Short_Short_Unsigned is mod 2 ** Short_Short_Integer'Size; + type Short_Unsigned is mod 2 ** Short_Integer'Size; + type Unsigned is mod 2 ** Integer'Size; + type Long_Unsigned is mod 2 ** Long_Integer'Size; + type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size; + type Long_Long_Long_Unsigned is mod Max_Binary_Modulus;
type Packed_Byte is mod 2 ** 8; - pragma Universal_Aliasing (Packed_Byte); for Packed_Byte'Size use 8; + pragma Universal_Aliasing (Packed_Byte); -- Component type for Packed_Bytes1, Packed_Bytes2 and Packed_Byte4 arrays. -- As this type is used by the compiler to implement operations on user -- packed array, it needs to be able to alias any type. @@ -57,6 +56,7 @@ type Packed_Bytes1 is array (Natural range <>) of aliased Packed_Byte; for Packed_Bytes1'Alignment use 1; for Packed_Bytes1'Component_Size use Packed_Byte'Size; + pragma Suppress_Initialization (Packed_Bytes1); -- This is the type used to implement packed arrays where no alignment -- is required. This includes the cases of 1,2,4 (where we use direct -- masking operations), and all odd component sizes (where the clusters @@ -65,6 +65,7 @@
type Packed_Bytes2 is new Packed_Bytes1; for Packed_Bytes2'Alignment use Integer'Min (2, Standard'Maximum_Alignment); + pragma Suppress_Initialization (Packed_Bytes2); -- This is the type used to implement packed arrays where an alignment -- of 2 (is possible) is helpful for maximum efficiency of the get and -- set routines in the corresponding library unit. This is true of all @@ -75,6 +76,7 @@
type Packed_Bytes4 is new Packed_Bytes1; for Packed_Bytes4'Alignment use Integer'Min (4, Standard'Maximum_Alignment); + pragma Suppress_Initialization (Packed_Bytes4); -- This is the type used to implement packed arrays where an alignment -- of 4 (if possible) is helpful for maximum efficiency of the get and -- set routines in the corresponding library unit. This is true of all @@ -83,6 +85,24 @@ -- cases the clusters can be assumed to be 4-byte aligned if the array -- is aligned (see System.Pack_12 in file s-pack12 as an example).
+ type Rev_Packed_Bytes1 is new Packed_Bytes1; + pragma Suppress_Initialization (Rev_Packed_Bytes1); + -- This is equivalent to Packed_Bytes1, but for packed arrays with reverse + -- scalar storage order. But the Scalar_Storage_Order attribute cannot be + -- set directly here, see Exp_Pakd for more details. + + type Rev_Packed_Bytes2 is new Packed_Bytes2; + pragma Suppress_Initialization (Rev_Packed_Bytes2); + -- This is equivalent to Packed_Bytes2, but for packed arrays with reverse + -- scalar storage order. But the Scalar_Storage_Order attribute cannot be + -- set directly here, see Exp_Pakd for more details. + + type Rev_Packed_Bytes4 is new Packed_Bytes4; + pragma Suppress_Initialization (Rev_Packed_Bytes4); + -- This is equivalent to Packed_Bytes4, but for packed arrays with reverse + -- scalar storage order. But the Scalar_Storage_Order attribute cannot be + -- set directly here, see Exp_Pakd for more details. + type Bits_1 is mod 2**1; type Bits_2 is mod 2**2; type Bits_4 is mod 2**4; @@ -191,6 +211,26 @@ (Value : Long_Long_Unsigned; Amount : Natural) return Long_Long_Unsigned;
+ function Shift_Left + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + + function Shift_Right + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + + function Shift_Right_Arithmetic + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + + function Rotate_Left + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + + function Rotate_Right + (Value : Long_Long_Long_Unsigned; + Amount : Natural) return Long_Long_Long_Unsigned; + pragma Import (Intrinsic, Shift_Left); pragma Import (Intrinsic, Shift_Right); pragma Import (Intrinsic, Shift_Right_Arithmetic); diff --git a/src/lib/gnat/system.ads b/src/lib/gnat/system.ads index 74ced54..879c89f 100644 --- a/src/lib/gnat/system.ads +++ b/src/lib/gnat/system.ads @@ -5,9 +5,9 @@ -- S Y S T E M -- -- -- -- S p e c -- --- (LSH Version) -- +-- (Compiler Version) -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -34,11 +34,25 @@ -- -- ------------------------------------------------------------------------------
-pragma Restrictions (No_Exception_Registration); +-- This version of System is a generic version that is used in building the +-- compiler. Right now, we have a host/target problem if we try to use the +-- "proper" System, and since the compiler itself does not care about most +-- System parameters, this generic version works fine.
pragma Restrictions (No_Implicit_Dynamic_Code); +-- We want to avoid trampolines in the compiler, so it can be used in systems +-- which prevent execution of code on the stack, e.g. in windows environments +-- with DEP (Data Execution Protection) enabled. + pragma Restrictions (No_Finalization); +-- Use restriction No_Finalization to avoid pulling finalization (not allowed +-- in GNAT) inside sem_spark.adb, when defining type Perm_Tree_Access as an +-- access type on incomplete type Perm_Tree_Wrapper (which is required for +-- defining a recursive type). + pragma Restrictions (No_Tasking); +-- Make it explicit that tasking is not used in the compiler, which also +-- allows generating simpler and more efficient code.
package System is pragma Pure; @@ -137,16 +151,13 @@ -- parameters is not too critical for the compiler version (e.g. we -- do not use floating-point anyway in the compiler).
- AAMP : constant Boolean := False; Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - Command_Line_Args : constant Boolean := False; - Configurable_Run_Time : constant Boolean := True; + Backend_Overflow_Checks : constant Boolean := False; + Command_Line_Args : constant Boolean := True; + Configurable_Run_Time : constant Boolean := False; Denorm : constant Boolean := True; Duration_32_Bits : constant Boolean := False; - Exit_Status_Supported : constant Boolean := False; - Fractional_Fixed_Ops : constant Boolean := False; - Frontend_Layout : constant Boolean := False; + Exit_Status_Supported : constant Boolean := True; Machine_Overflows : constant Boolean := False; Machine_Rounds : constant Boolean := True; Preallocated_Stacks : constant Boolean := False; @@ -159,17 +170,9 @@ Support_Composite_Compare : constant Boolean := True; Support_Long_Shifts : constant Boolean := True; Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; Use_Ada_Main_Program_Name : constant Boolean := False; - ZCX_By_Default : constant Boolean := False; - - -- Obsolete entries, to be removed eventually (bootstrap issues) - - Front_End_ZCX_Support : constant Boolean := False; - High_Integrity_Mode : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - Functions_Return_By_DSP : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True;
end System;