From: Arnaud Charlet Date: Mon, 11 Sep 2017 10:12:05 +0000 (+0200) Subject: libgnat: Rename ?-[a-z]*-* into ?-[a-z]*__* X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a0713cb6beb00ca850e7c20f287d32f1e1a14a49;p=gcc.git libgnat: Rename ?-[a-z]*-* into ?-[a-z]*__* 2017-09-11 Jerome Lambourg * libgnat: Rename ?-[a-z]*-* into ?-[a-z]*__* * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Take this renaming into account. From-SVN: r251968 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 93d9f6a5429..84608b3e5df 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,13 @@ +2017-09-11 Yannick Moy + + * lib-xref-spark_specific.adb: Minor rewrite. + +2017-09-11 Jerome Lambourg + + * libgnat: Rename ?-[a-z]*-* into ?-[a-z]*__* + * gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Take this + renaming into account. + 2017-09-11 Jerome Lambourg * libgnarl: Rename ?-[a-z]*-* into ?-[a-z]*__* diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index b9d06b025ad..65826952d31 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -636,11 +636,11 @@ CFLAGS-ada/raise-gcc.o += -I$(srcdir)/../libgcc -DEH_MECHANISM_$(EH_MECHANISM) ada/libgnat/s-excmac.o: ada/libgnat/s-excmac.ads ada/libgnat/s-excmac.adb -ada/libgnat/s-excmac.ads: $(srcdir)/ada/libgnat/s-excmac-$(EH_MECHANISM).ads +ada/libgnat/s-excmac.ads: $(srcdir)/ada/libgnat/s-excmac__$(EH_MECHANISM).ads mkdir -p ada/libgnat $(CP) $< $@ -ada/libgnat/s-excmac.adb: $(srcdir)/ada/libgnat/s-excmac-$(EH_MECHANISM).adb +ada/libgnat/s-excmac.adb: $(srcdir)/ada/libgnat/s-excmac__$(EH_MECHANISM).adb mkdir -p ada/libgnat $(CP) $< $@ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index d30028dab55..c05395ad6d6 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -359,7 +359,7 @@ a-intnam.ads. -- ------------------------------------------------------------------------------- - --- Note: special attention must be paid to the case of simultaneous access --- to internal shared objects and elements by different tasks. The Reference --- counter of internal shared object is the only component protected using --- atomic operations; other components and elements can be modified only when --- reference counter is equal to one (so there are no other references to this --- internal shared object and element). - -with Ada.Unchecked_Deallocation; - -package body Ada.Containers.Indefinite_Holders is - - procedure Free is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - procedure Detach (Container : Holder); - -- Detach data from shared copy if necessary. This is necessary to prepare - -- container to be modified. - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Holder) return Boolean is - begin - if Left.Reference = Right.Reference then - - -- Covers both null and not null but the same shared object cases - - return True; - - elsif Left.Reference /= null and Right.Reference /= null then - return Left.Reference.Element.all = Right.Reference.Element.all; - - else - return False; - end if; - end "="; - - ------------ - -- Adjust -- - ------------ - - overriding procedure Adjust (Container : in out Holder) is - begin - if Container.Reference /= null then - if Container.Busy = 0 then - - -- Container is not locked, reuse existing internal shared object - - Reference (Container.Reference); - else - -- Otherwise, create copy of both internal shared object and - -- element. - - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => - new Element_Type'(Container.Reference.Element.all)); - end if; - end if; - - Container.Busy := 0; - end Adjust; - - overriding procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Reference (Control.Container.Reference); - Control.Container.Busy := Control.Container.Busy + 1; - end if; - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Holder; Source : Holder) is - begin - if Target.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Target.Reference /= Source.Reference then - if Target.Reference /= null then - Unreference (Target.Reference); - end if; - - Target.Reference := Source.Reference; - - if Source.Reference /= null then - Reference (Target.Reference); - end if; - end if; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Holder) is - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Container.Reference /= null then - Unreference (Container.Reference); - Container.Reference := null; - end if; - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Holder) return Constant_Reference_Type is - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - end if; - - Detach (Container); - - declare - Ref : constant Constant_Reference_Type := - (Element => Container.Reference.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)); - begin - Reference (Ref.Control.Container.Reference); - Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; - return Ref; - end; - end Constant_Reference; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Holder) return Holder is - begin - if Source.Reference = null then - return (Controlled with null, 0); - - elsif Source.Busy = 0 then - - -- Container is not locked, reuse internal shared object - - Reference (Source.Reference); - - return (Controlled with Source.Reference, 0); - - else - -- Otherwise, create copy of both internal shared object and element - - return - (Controlled with - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(Source.Reference.Element.all)), - 0); - end if; - end Copy; - - ------------ - -- Detach -- - ------------ - - procedure Detach (Container : Holder) is - begin - if Container.Busy = 0 - and then not System.Atomic_Counters.Is_One - (Container.Reference.Counter) - then - -- Container is not locked and internal shared object is used by - -- other container, create copy of both internal shared object and - -- element. - - declare - Old : constant Shared_Holder_Access := Container.Reference; - - begin - Container'Unrestricted_Access.Reference := - new Shared_Holder' - (Counter => <>, - Element => - new Element_Type'(Container.Reference.Element.all)); - Unreference (Old); - end; - end if; - end Detach; - - ------------- - -- Element -- - ------------- - - function Element (Container : Holder) return Element_Type is - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - else - return Container.Reference.Element.all; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Container : in out Holder) is - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Container.Reference /= null then - Unreference (Container.Reference); - Container.Reference := null; - end if; - end Finalize; - - overriding procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Unreference (Control.Container.Reference); - Control.Container.Busy := Control.Container.Busy - 1; - Control.Container := null; - end if; - end Finalize; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Holder) return Boolean is - begin - return Container.Reference = null; - end Is_Empty; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Holder; Source : in out Holder) is - begin - if Target.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Source.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Target.Reference /= Source.Reference then - if Target.Reference /= null then - Unreference (Target.Reference); - end if; - - Target.Reference := Source.Reference; - Source.Reference := null; - end if; - end Move; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Holder; - Process : not null access procedure (Element : Element_Type)) - is - B : Natural renames Container'Unrestricted_Access.Busy; - - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - end if; - - Detach (Container); - - B := B + 1; - - begin - Process (Container.Reference.Element.all); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : out Holder) - is - begin - Clear (Container); - - if not Boolean'Input (Stream) then - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(Element_Type'Input (Stream))); - end if; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - procedure Reference (Item : not null Shared_Holder_Access) is - begin - System.Atomic_Counters.Increment (Item.Counter); - end Reference; - - function Reference - (Container : aliased in out Holder) return Reference_Type - is - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - end if; - - Detach (Container); - - declare - Ref : constant Reference_Type := - (Element => Container.Reference.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)); - begin - Reference (Ref.Control.Container.Reference); - Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; - return Ref; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Holder; - New_Item : Element_Type) - is - -- Element allocator may need an accessibility check in case actual type - -- is class-wide or has access discriminants (RM 4.8(10.1) and - -- AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Container.Reference = null then - -- Holder is empty, allocate new Shared_Holder. - - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(New_Item)); - - elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then - -- Shared_Holder can be reused. - - Free (Container.Reference.Element); - Container.Reference.Element := new Element_Type'(New_Item); - - else - Unreference (Container.Reference); - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(New_Item)); - end if; - end Replace_Element; - - --------------- - -- To_Holder -- - --------------- - - function To_Holder (New_Item : Element_Type) return Holder is - -- The element allocator may need an accessibility check in the case the - -- actual type is class-wide or has access discriminants (RM 4.8(10.1) - -- and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - return - (Controlled with - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(New_Item)), 0); - end To_Holder; - - ----------------- - -- Unreference -- - ----------------- - - procedure Unreference (Item : not null Shared_Holder_Access) is - - procedure Free is - new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access); - - Aux : Shared_Holder_Access := Item; - - begin - if System.Atomic_Counters.Decrement (Aux.Counter) then - Free (Aux.Element); - Free (Aux); - end if; - end Unreference; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Holder; - Process : not null access procedure (Element : in out Element_Type)) - is - B : Natural renames Container.Busy; - - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - end if; - - Detach (Container); - - B := B + 1; - - begin - Process (Container.Reference.Element.all); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : Holder) - is - begin - Boolean'Output (Stream, Container.Reference = null); - - if Container.Reference /= null then - Element_Type'Output (Stream, Container.Reference.Element.all); - end if; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/libgnat/a-coinho-shared.ads b/gcc/ada/libgnat/a-coinho-shared.ads deleted file mode 100644 index 3faab9b84e6..00000000000 --- a/gcc/ada/libgnat/a-coinho-shared.ads +++ /dev/null @@ -1,192 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2013-2017, 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 -- --- . -- ------------------------------------------------------------------------------- - --- This is an optimized version of Indefinite_Holders using copy-on-write. --- It is used on platforms that support atomic built-ins. - -private with Ada.Finalization; -private with Ada.Streams; - -private with System.Atomic_Counters; - -generic - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Holders is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate (Indefinite_Holders); - pragma Remote_Types (Indefinite_Holders); - - type Holder is tagged private; - pragma Preelaborable_Initialization (Holder); - - Empty_Holder : constant Holder; - - function "=" (Left, Right : Holder) return Boolean; - - function To_Holder (New_Item : Element_Type) return Holder; - - function Is_Empty (Container : Holder) return Boolean; - - procedure Clear (Container : in out Holder); - - function Element (Container : Holder) return Element_Type; - - procedure Replace_Element - (Container : in out Holder; - New_Item : Element_Type); - - procedure Query_Element - (Container : Holder; - Process : not null access procedure (Element : Element_Type)); - procedure Update_Element - (Container : in out Holder; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Holder) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Holder) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Holder; Source : Holder); - - function Copy (Source : Holder) return Holder; - - procedure Move (Target : in out Holder; Source : in out Holder); - -private - - use Ada.Finalization; - use Ada.Streams; - - type Element_Access is access all Element_Type; - type Holder_Access is access all Holder; - - type Shared_Holder is record - Counter : System.Atomic_Counters.Atomic_Counter; - Element : Element_Access; - end record; - - type Shared_Holder_Access is access all Shared_Holder; - - procedure Reference (Item : not null Shared_Holder_Access); - -- Increment reference counter - - procedure Unreference (Item : not null Shared_Holder_Access); - -- Decrement reference counter, deallocate Item when counter goes to zero - - procedure Read - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : out Holder); - - procedure Write - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : Holder); - - type Holder is new Ada.Finalization.Controlled with record - Reference : Shared_Holder_Access; - Busy : Natural := 0; - end record; - for Holder'Read use Read; - for Holder'Write use Write; - - overriding procedure Adjust (Container : in out Holder); - overriding procedure Finalize (Container : in out Holder); - - type Reference_Control_Type is new Controlled with record - Container : Holder_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - Empty_Holder : constant Holder := (Controlled with null, 0); - -end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/libgnat/a-coinho__shared.adb b/gcc/ada/libgnat/a-coinho__shared.adb new file mode 100644 index 00000000000..e4da421cec5 --- /dev/null +++ b/gcc/ada/libgnat/a-coinho__shared.adb @@ -0,0 +1,528 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, 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 -- +-- . -- +------------------------------------------------------------------------------ + +-- Note: special attention must be paid to the case of simultaneous access +-- to internal shared objects and elements by different tasks. The Reference +-- counter of internal shared object is the only component protected using +-- atomic operations; other components and elements can be modified only when +-- reference counter is equal to one (so there are no other references to this +-- internal shared object and element). + +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Indefinite_Holders is + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + procedure Detach (Container : Holder); + -- Detach data from shared copy if necessary. This is necessary to prepare + -- container to be modified. + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Holder) return Boolean is + begin + if Left.Reference = Right.Reference then + + -- Covers both null and not null but the same shared object cases + + return True; + + elsif Left.Reference /= null and Right.Reference /= null then + return Left.Reference.Element.all = Right.Reference.Element.all; + + else + return False; + end if; + end "="; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Container : in out Holder) is + begin + if Container.Reference /= null then + if Container.Busy = 0 then + + -- Container is not locked, reuse existing internal shared object + + Reference (Container.Reference); + else + -- Otherwise, create copy of both internal shared object and + -- element. + + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => + new Element_Type'(Container.Reference.Element.all)); + end if; + end if; + + Container.Busy := 0; + end Adjust; + + overriding procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Reference (Control.Container.Reference); + Control.Container.Busy := Control.Container.Busy + 1; + end if; + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Holder; Source : Holder) is + begin + if Target.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Target.Reference /= Source.Reference then + if Target.Reference /= null then + Unreference (Target.Reference); + end if; + + Target.Reference := Source.Reference; + + if Source.Reference /= null then + Reference (Target.Reference); + end if; + end if; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Holder) is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Container.Reference /= null then + Unreference (Container.Reference); + Container.Reference := null; + end if; + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Holder) return Constant_Reference_Type is + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + Detach (Container); + + declare + Ref : constant Constant_Reference_Type := + (Element => Container.Reference.Element.all'Access, + Control => (Controlled with Container'Unrestricted_Access)); + begin + Reference (Ref.Control.Container.Reference); + Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; + return Ref; + end; + end Constant_Reference; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Holder) return Holder is + begin + if Source.Reference = null then + return (Controlled with null, 0); + + elsif Source.Busy = 0 then + + -- Container is not locked, reuse internal shared object + + Reference (Source.Reference); + + return (Controlled with Source.Reference, 0); + + else + -- Otherwise, create copy of both internal shared object and element + + return + (Controlled with + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Source.Reference.Element.all)), + 0); + end if; + end Copy; + + ------------ + -- Detach -- + ------------ + + procedure Detach (Container : Holder) is + begin + if Container.Busy = 0 + and then not System.Atomic_Counters.Is_One + (Container.Reference.Counter) + then + -- Container is not locked and internal shared object is used by + -- other container, create copy of both internal shared object and + -- element. + + declare + Old : constant Shared_Holder_Access := Container.Reference; + + begin + Container'Unrestricted_Access.Reference := + new Shared_Holder' + (Counter => <>, + Element => + new Element_Type'(Container.Reference.Element.all)); + Unreference (Old); + end; + end if; + end Detach; + + ------------- + -- Element -- + ------------- + + function Element (Container : Holder) return Element_Type is + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + else + return Container.Reference.Element.all; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Container : in out Holder) is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Container.Reference /= null then + Unreference (Container.Reference); + Container.Reference := null; + end if; + end Finalize; + + overriding procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Unreference (Control.Container.Reference); + Control.Container.Busy := Control.Container.Busy - 1; + Control.Container := null; + end if; + end Finalize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Holder) return Boolean is + begin + return Container.Reference = null; + end Is_Empty; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Holder; Source : in out Holder) is + begin + if Target.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Source.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Target.Reference /= Source.Reference then + if Target.Reference /= null then + Unreference (Target.Reference); + end if; + + Target.Reference := Source.Reference; + Source.Reference := null; + end if; + end Move; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Holder; + Process : not null access procedure (Element : Element_Type)) + is + B : Natural renames Container'Unrestricted_Access.Busy; + + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + Detach (Container); + + B := B + 1; + + begin + Process (Container.Reference.Element.all); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : out Holder) + is + begin + Clear (Container); + + if not Boolean'Input (Stream) then + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Element_Type'Input (Stream))); + end if; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Holder_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + function Reference + (Container : aliased in out Holder) return Reference_Type + is + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + Detach (Container); + + declare + Ref : constant Reference_Type := + (Element => Container.Reference.Element.all'Access, + Control => (Controlled with Container'Unrestricted_Access)); + begin + Reference (Ref.Control.Container.Reference); + Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; + return Ref; + end; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Holder; + New_Item : Element_Type) + is + -- Element allocator may need an accessibility check in case actual type + -- is class-wide or has access discriminants (RM 4.8(10.1) and + -- AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Container.Reference = null then + -- Holder is empty, allocate new Shared_Holder. + + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)); + + elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then + -- Shared_Holder can be reused. + + Free (Container.Reference.Element); + Container.Reference.Element := new Element_Type'(New_Item); + + else + Unreference (Container.Reference); + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)); + end if; + end Replace_Element; + + --------------- + -- To_Holder -- + --------------- + + function To_Holder (New_Item : Element_Type) return Holder is + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + return + (Controlled with + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)), 0); + end To_Holder; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Holder_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access); + + Aux : Shared_Holder_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + Free (Aux.Element); + Free (Aux); + end if; + end Unreference; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Holder; + Process : not null access procedure (Element : in out Element_Type)) + is + B : Natural renames Container.Busy; + + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + Detach (Container); + + B := B + 1; + + begin + Process (Container.Reference.Element.all); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : Holder) + is + begin + Boolean'Output (Stream, Container.Reference = null); + + if Container.Reference /= null then + Element_Type'Output (Stream, Container.Reference.Element.all); + end if; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/libgnat/a-coinho__shared.ads b/gcc/ada/libgnat/a-coinho__shared.ads new file mode 100644 index 00000000000..3faab9b84e6 --- /dev/null +++ b/gcc/ada/libgnat/a-coinho__shared.ads @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013-2017, 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 -- +-- . -- +------------------------------------------------------------------------------ + +-- This is an optimized version of Indefinite_Holders using copy-on-write. +-- It is used on platforms that support atomic built-ins. + +private with Ada.Finalization; +private with Ada.Streams; + +private with System.Atomic_Counters; + +generic + type Element_Type (<>) is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Holders is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate (Indefinite_Holders); + pragma Remote_Types (Indefinite_Holders); + + type Holder is tagged private; + pragma Preelaborable_Initialization (Holder); + + Empty_Holder : constant Holder; + + function "=" (Left, Right : Holder) return Boolean; + + function To_Holder (New_Item : Element_Type) return Holder; + + function Is_Empty (Container : Holder) return Boolean; + + procedure Clear (Container : in out Holder); + + function Element (Container : Holder) return Element_Type; + + procedure Replace_Element + (Container : in out Holder; + New_Item : Element_Type); + + procedure Query_Element + (Container : Holder; + Process : not null access procedure (Element : Element_Type)); + procedure Update_Element + (Container : in out Holder; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Holder) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Holder) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Holder; Source : Holder); + + function Copy (Source : Holder) return Holder; + + procedure Move (Target : in out Holder; Source : in out Holder); + +private + + use Ada.Finalization; + use Ada.Streams; + + type Element_Access is access all Element_Type; + type Holder_Access is access all Holder; + + type Shared_Holder is record + Counter : System.Atomic_Counters.Atomic_Counter; + Element : Element_Access; + end record; + + type Shared_Holder_Access is access all Shared_Holder; + + procedure Reference (Item : not null Shared_Holder_Access); + -- Increment reference counter + + procedure Unreference (Item : not null Shared_Holder_Access); + -- Decrement reference counter, deallocate Item when counter goes to zero + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : out Holder); + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : Holder); + + type Holder is new Ada.Finalization.Controlled with record + Reference : Shared_Holder_Access; + Busy : Natural := 0; + end record; + for Holder'Read use Read; + for Holder'Write use Write; + + overriding procedure Adjust (Container : in out Holder); + overriding procedure Finalize (Container : in out Holder); + + type Reference_Control_Type is new Controlled with record + Container : Holder_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + Empty_Holder : constant Holder := (Controlled with null, 0); + +end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/libgnat/a-dirval-mingw.adb b/gcc/ada/libgnat/a-dirval-mingw.adb deleted file mode 100644 index b0a9cc35c1d..00000000000 --- a/gcc/ada/libgnat/a-dirval-mingw.adb +++ /dev/null @@ -1,175 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S . V A L I D I T Y -- --- -- --- B o d y -- --- (Windows Version) -- --- -- --- Copyright (C) 2004-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Windows version of this package - -with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; - -package body Ada.Directories.Validity is - - Invalid_Character : constant array (Character) of Boolean := - (NUL .. US | '\' => True, - '/' | ':' | '*' | '?' => True, - '"' | '<' | '>' | '|' => True, - DEL => True, - others => False); - -- Note that a valid file-name or path-name is implementation defined. - -- To support UTF-8 file and directory names, we do not want to be too - -- restrictive here. - - --------------------------------- - -- Is_Path_Name_Case_Sensitive -- - --------------------------------- - - function Is_Path_Name_Case_Sensitive return Boolean is - begin - return False; - end Is_Path_Name_Case_Sensitive; - - ------------------------ - -- Is_Valid_Path_Name -- - ------------------------ - - function Is_Valid_Path_Name (Name : String) return Boolean is - Start : Positive := Name'First; - Last : Natural; - - begin - -- A path name cannot be empty, cannot contain more than 256 characters, - -- cannot contain invalid characters and each directory/file name need - -- to be valid. - - if Name'Length = 0 or else Name'Length > 256 then - return False; - - else - -- A drive letter may be specified at the beginning - - if Name'Length >= 2 - and then Name (Start + 1) = ':' - and then - (Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z') - then - Start := Start + 2; - - -- A drive letter followed by a colon and followed by nothing or - -- by a relative path is an ambiguous path name on Windows, so we - -- don't accept it. - - if Start > Name'Last - or else (Name (Start) /= '/' and then Name (Start) /= '\') - then - return False; - end if; - end if; - - loop - -- Look for the start of the next directory or file name - - while Start <= Name'Last - and then (Name (Start) = '\' or Name (Start) = '/') - loop - Start := Start + 1; - end loop; - - -- If all directories/file names are OK, return True - - exit when Start > Name'Last; - - Last := Start; - - -- Look for the end of the directory/file name - - while Last < Name'Last loop - exit when Name (Last + 1) = '\' or Name (Last + 1) = '/'; - Last := Last + 1; - end loop; - - -- Check if the directory/file name is valid - - if not Is_Valid_Simple_Name (Name (Start .. Last)) then - return False; - end if; - - -- Move to the next name - - Start := Last + 1; - end loop; - end if; - - -- If Name follows the rules, it is valid - - return True; - end Is_Valid_Path_Name; - - -------------------------- - -- Is_Valid_Simple_Name -- - -------------------------- - - function Is_Valid_Simple_Name (Name : String) return Boolean is - Only_Spaces : Boolean; - - begin - -- A file name cannot be empty, cannot contain more than 256 characters, - -- and cannot contain invalid characters. - - if Name'Length = 0 or else Name'Length > 256 then - return False; - - -- Name length is OK - - else - Only_Spaces := True; - for J in Name'Range loop - if Invalid_Character (Name (J)) then - return False; - elsif Name (J) /= ' ' then - Only_Spaces := False; - end if; - end loop; - - -- If no invalid chars, and not all spaces, file name is valid - - return not Only_Spaces; - end if; - end Is_Valid_Simple_Name; - - ------------- - -- Windows -- - ------------- - - function Windows return Boolean is - begin - return True; - end Windows; - -end Ada.Directories.Validity; diff --git a/gcc/ada/libgnat/a-dirval__mingw.adb b/gcc/ada/libgnat/a-dirval__mingw.adb new file mode 100644 index 00000000000..b0a9cc35c1d --- /dev/null +++ b/gcc/ada/libgnat/a-dirval__mingw.adb @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S . V A L I D I T Y -- +-- -- +-- B o d y -- +-- (Windows Version) -- +-- -- +-- Copyright (C) 2004-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows version of this package + +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; + +package body Ada.Directories.Validity is + + Invalid_Character : constant array (Character) of Boolean := + (NUL .. US | '\' => True, + '/' | ':' | '*' | '?' => True, + '"' | '<' | '>' | '|' => True, + DEL => True, + others => False); + -- Note that a valid file-name or path-name is implementation defined. + -- To support UTF-8 file and directory names, we do not want to be too + -- restrictive here. + + --------------------------------- + -- Is_Path_Name_Case_Sensitive -- + --------------------------------- + + function Is_Path_Name_Case_Sensitive return Boolean is + begin + return False; + end Is_Path_Name_Case_Sensitive; + + ------------------------ + -- Is_Valid_Path_Name -- + ------------------------ + + function Is_Valid_Path_Name (Name : String) return Boolean is + Start : Positive := Name'First; + Last : Natural; + + begin + -- A path name cannot be empty, cannot contain more than 256 characters, + -- cannot contain invalid characters and each directory/file name need + -- to be valid. + + if Name'Length = 0 or else Name'Length > 256 then + return False; + + else + -- A drive letter may be specified at the beginning + + if Name'Length >= 2 + and then Name (Start + 1) = ':' + and then + (Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z') + then + Start := Start + 2; + + -- A drive letter followed by a colon and followed by nothing or + -- by a relative path is an ambiguous path name on Windows, so we + -- don't accept it. + + if Start > Name'Last + or else (Name (Start) /= '/' and then Name (Start) /= '\') + then + return False; + end if; + end if; + + loop + -- Look for the start of the next directory or file name + + while Start <= Name'Last + and then (Name (Start) = '\' or Name (Start) = '/') + loop + Start := Start + 1; + end loop; + + -- If all directories/file names are OK, return True + + exit when Start > Name'Last; + + Last := Start; + + -- Look for the end of the directory/file name + + while Last < Name'Last loop + exit when Name (Last + 1) = '\' or Name (Last + 1) = '/'; + Last := Last + 1; + end loop; + + -- Check if the directory/file name is valid + + if not Is_Valid_Simple_Name (Name (Start .. Last)) then + return False; + end if; + + -- Move to the next name + + Start := Last + 1; + end loop; + end if; + + -- If Name follows the rules, it is valid + + return True; + end Is_Valid_Path_Name; + + -------------------------- + -- Is_Valid_Simple_Name -- + -------------------------- + + function Is_Valid_Simple_Name (Name : String) return Boolean is + Only_Spaces : Boolean; + + begin + -- A file name cannot be empty, cannot contain more than 256 characters, + -- and cannot contain invalid characters. + + if Name'Length = 0 or else Name'Length > 256 then + return False; + + -- Name length is OK + + else + Only_Spaces := True; + for J in Name'Range loop + if Invalid_Character (Name (J)) then + return False; + elsif Name (J) /= ' ' then + Only_Spaces := False; + end if; + end loop; + + -- If no invalid chars, and not all spaces, file name is valid + + return not Only_Spaces; + end if; + end Is_Valid_Simple_Name; + + ------------- + -- Windows -- + ------------- + + function Windows return Boolean is + begin + return True; + end Windows; + +end Ada.Directories.Validity; diff --git a/gcc/ada/libgnat/a-elchha-vxworks-ppc-full.adb b/gcc/ada/libgnat/a-elchha-vxworks-ppc-full.adb deleted file mode 100644 index 1b03a186468..00000000000 --- a/gcc/ada/libgnat/a-elchha-vxworks-ppc-full.adb +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Warnings (Off); -with System.Standard_Library; -pragma Warnings (On); - -with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; -with GNAT.IO; use GNAT.IO; - --- Default last chance handler for use with the full VxWorks 653 partition OS --- Ada run-time library. - --- Logs error with health monitor, and dumps exception identity and argument --- string for vxaddr2line for generation of a symbolic stack backtrace. - -procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) is - - ---------------------- - -- APEX definitions -- - ---------------------- - - pragma Warnings (Off); - type Error_Code_Type is ( - Deadline_Missed, - Application_Error, - Numeric_Error, - Illegal_Request, - Stack_Overflow, - Memory_Violation, - Hardware_Fault, - Power_Fail); - pragma Warnings (On); - pragma Convention (C, Error_Code_Type); - -- APEX Health Management error codes - - type Message_Addr_Type is new System.Address; - - type Apex_Integer is range -(2 ** 31) .. (2 ** 31) - 1; - pragma Convention (C, Apex_Integer); - - Max_Error_Message_Size : constant := 64; - - type Error_Message_Size_Type is new Apex_Integer range - 1 .. Max_Error_Message_Size; - - pragma Warnings (Off); - type Return_Code_Type is ( - No_Error, -- request valid and operation performed - No_Action, -- status of system unaffected by request - Not_Available, -- resource required by request unavailable - Invalid_Param, -- invalid parameter specified in request - Invalid_Config, -- parameter incompatible with configuration - Invalid_Mode, -- request incompatible with current mode - Timed_Out); -- time-out tied up with request has expired - pragma Warnings (On); - pragma Convention (C, Return_Code_Type); - -- APEX return codes - - procedure Raise_Application_Error - (Error_Code : Error_Code_Type; - Message_Addr : Message_Addr_Type; - Length : Error_Message_Size_Type; - Return_Code : out Return_Code_Type); - pragma Import (C, Raise_Application_Error, "RAISE_APPLICATION_ERROR"); - - procedure Unhandled_Terminate; - pragma No_Return (Unhandled_Terminate); - pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); - -- Perform system dependent shutdown code - - procedure Adainit; - pragma Import (Ada, Adainit, "adainit"); - - Adainit_Addr : constant System.Address := Adainit'Code_Address; - -- Part of arguments to vxaddr2line - - Result : Return_Code_Type; - - Message : String := - Exception_Name (Except) & ": " & ASCII.LF & - Exception_Message (Except) & ASCII.NUL; - - Message_Length : Error_Message_Size_Type; - -begin - New_Line; - Put_Line ("In last chance handler"); - Put_Line (Message (1 .. Message'Length - 1)); - New_Line; - - Put_Line ("adainit and traceback addresses for vxaddr2line:"); - - Put (Image_C (Adainit_Addr)); Put (" "); - - for J in 1 .. Except.Num_Tracebacks loop - Put (Image_C (Except.Tracebacks (J))); - Put (" "); - end loop; - - New_Line; - - if Message'Length > Error_Message_Size_Type'Last then - Message_Length := Error_Message_Size_Type'Last; - else - Message_Length := Message'Length; - end if; - - Raise_Application_Error - (Error_Code => Application_Error, - Message_Addr => Message_Addr_Type (Message (1)'Address), - Length => Message_Length, - Return_Code => Result); - - -- Shutdown the run-time library now. The rest of the procedure needs to be - -- careful not to use anything that would require runtime support. In - -- particular, functions returning strings are banned since the sec stack - -- is no longer functional. - - System.Standard_Library.Adafinal; - Unhandled_Terminate; -end Ada.Exceptions.Last_Chance_Handler; diff --git a/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb b/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb new file mode 100644 index 00000000000..1b03a186468 --- /dev/null +++ b/gcc/ada/libgnat/a-elchha__vxworks-ppc-full.adb @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +with System.Standard_Library; +pragma Warnings (On); + +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; +with GNAT.IO; use GNAT.IO; + +-- Default last chance handler for use with the full VxWorks 653 partition OS +-- Ada run-time library. + +-- Logs error with health monitor, and dumps exception identity and argument +-- string for vxaddr2line for generation of a symbolic stack backtrace. + +procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) is + + ---------------------- + -- APEX definitions -- + ---------------------- + + pragma Warnings (Off); + type Error_Code_Type is ( + Deadline_Missed, + Application_Error, + Numeric_Error, + Illegal_Request, + Stack_Overflow, + Memory_Violation, + Hardware_Fault, + Power_Fail); + pragma Warnings (On); + pragma Convention (C, Error_Code_Type); + -- APEX Health Management error codes + + type Message_Addr_Type is new System.Address; + + type Apex_Integer is range -(2 ** 31) .. (2 ** 31) - 1; + pragma Convention (C, Apex_Integer); + + Max_Error_Message_Size : constant := 64; + + type Error_Message_Size_Type is new Apex_Integer range + 1 .. Max_Error_Message_Size; + + pragma Warnings (Off); + type Return_Code_Type is ( + No_Error, -- request valid and operation performed + No_Action, -- status of system unaffected by request + Not_Available, -- resource required by request unavailable + Invalid_Param, -- invalid parameter specified in request + Invalid_Config, -- parameter incompatible with configuration + Invalid_Mode, -- request incompatible with current mode + Timed_Out); -- time-out tied up with request has expired + pragma Warnings (On); + pragma Convention (C, Return_Code_Type); + -- APEX return codes + + procedure Raise_Application_Error + (Error_Code : Error_Code_Type; + Message_Addr : Message_Addr_Type; + Length : Error_Message_Size_Type; + Return_Code : out Return_Code_Type); + pragma Import (C, Raise_Application_Error, "RAISE_APPLICATION_ERROR"); + + procedure Unhandled_Terminate; + pragma No_Return (Unhandled_Terminate); + pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); + -- Perform system dependent shutdown code + + procedure Adainit; + pragma Import (Ada, Adainit, "adainit"); + + Adainit_Addr : constant System.Address := Adainit'Code_Address; + -- Part of arguments to vxaddr2line + + Result : Return_Code_Type; + + Message : String := + Exception_Name (Except) & ": " & ASCII.LF & + Exception_Message (Except) & ASCII.NUL; + + Message_Length : Error_Message_Size_Type; + +begin + New_Line; + Put_Line ("In last chance handler"); + Put_Line (Message (1 .. Message'Length - 1)); + New_Line; + + Put_Line ("adainit and traceback addresses for vxaddr2line:"); + + Put (Image_C (Adainit_Addr)); Put (" "); + + for J in 1 .. Except.Num_Tracebacks loop + Put (Image_C (Except.Tracebacks (J))); + Put (" "); + end loop; + + New_Line; + + if Message'Length > Error_Message_Size_Type'Last then + Message_Length := Error_Message_Size_Type'Last; + else + Message_Length := Message'Length; + end if; + + Raise_Application_Error + (Error_Code => Application_Error, + Message_Addr => Message_Addr_Type (Message (1)'Address), + Length => Message_Length, + Return_Code => Result); + + -- Shutdown the run-time library now. The rest of the procedure needs to be + -- careful not to use anything that would require runtime support. In + -- particular, functions returning strings are banned since the sec stack + -- is no longer functional. + + System.Standard_Library.Adafinal; + Unhandled_Terminate; +end Ada.Exceptions.Last_Chance_Handler; diff --git a/gcc/ada/libgnat/a-excpol-abort.adb b/gcc/ada/libgnat/a-excpol-abort.adb deleted file mode 100644 index 8ed2e667197..00000000000 --- a/gcc/ada/libgnat/a-excpol-abort.adb +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . P O L L -- --- (version supporting asynchronous abort test) -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for targets that do not support per-thread asynchronous --- signals. On such targets, we require compilation with the -gnatP switch --- that activates periodic polling. Then in the body of the polling routine --- we test for asynchronous abort. - --- Windows and HPUX 10 currently use this file - -pragma Warnings (Off); --- Allow withing of non-Preelaborated units in Ada 2005 mode where this --- package will be categorized as Preelaborate. See AI-362 for details. --- It is safe in the context of the run-time to violate the rules. - -with System.Soft_Links; - -pragma Warnings (On); - -separate (Ada.Exceptions) - ----------- --- Poll -- ----------- - -procedure Poll is -begin - -- Test for asynchronous abort on each poll - - if System.Soft_Links.Check_Abort_Status.all /= 0 then - raise Standard'Abort_Signal; - end if; -end Poll; diff --git a/gcc/ada/libgnat/a-excpol__abort.adb b/gcc/ada/libgnat/a-excpol__abort.adb new file mode 100644 index 00000000000..8ed2e667197 --- /dev/null +++ b/gcc/ada/libgnat/a-excpol__abort.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . P O L L -- +-- (version supporting asynchronous abort test) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for targets that do not support per-thread asynchronous +-- signals. On such targets, we require compilation with the -gnatP switch +-- that activates periodic polling. Then in the body of the polling routine +-- we test for asynchronous abort. + +-- Windows and HPUX 10 currently use this file + +pragma Warnings (Off); +-- Allow withing of non-Preelaborated units in Ada 2005 mode where this +-- package will be categorized as Preelaborate. See AI-362 for details. +-- It is safe in the context of the run-time to violate the rules. + +with System.Soft_Links; + +pragma Warnings (On); + +separate (Ada.Exceptions) + +---------- +-- Poll -- +---------- + +procedure Poll is +begin + -- Test for asynchronous abort on each poll + + if System.Soft_Links.Check_Abort_Status.all /= 0 then + raise Standard'Abort_Signal; + end if; +end Poll; diff --git a/gcc/ada/libgnat/a-numaux-darwin.adb b/gcc/ada/libgnat/a-numaux-darwin.adb deleted file mode 100644 index 88e9e7c2a2d..00000000000 --- a/gcc/ada/libgnat/a-numaux-darwin.adb +++ /dev/null @@ -1,211 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- B o d y -- --- (Apple OS X Version) -- --- -- --- Copyright (C) 1998-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Numerics.Aux is - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Is_Nan (X : Double) return Boolean; - -- Return True iff X is a IEEE NaN value - - procedure Reduce (X : in out Double; Q : out Natural); - -- Implement reduction of X by Pi/2. Q is the quadrant of the final - -- result in the range 0..3. The absolute value of X is at most Pi/4. - -- It is needed to avoid a loss of accuracy for sin near Pi and cos - -- near Pi/2 due to the use of an insufficiently precise value of Pi - -- in the range reduction. - - -- The following two functions implement Chebishev approximations - -- of the trigonometric functions in their reduced domain. - -- These approximations have been computed using Maple. - - function Sine_Approx (X : Double) return Double; - function Cosine_Approx (X : Double) return Double; - - pragma Inline (Reduce); - pragma Inline (Sine_Approx); - pragma Inline (Cosine_Approx); - - ------------------- - -- Cosine_Approx -- - ------------------- - - function Cosine_Approx (X : Double) return Double is - XX : constant Double := X * X; - begin - return (((((16#8.DC57FBD05F640#E-08 * XX - - 16#4.9F7D00BF25D80#E-06) * XX - + 16#1.A019F7FDEFCC2#E-04) * XX - - 16#5.B05B058F18B20#E-03) * XX - + 16#A.AAAAAAAA73FA8#E-02) * XX - - 16#7.FFFFFFFFFFDE4#E-01) * XX - - 16#3.655E64869ECCE#E-14 + 1.0; - end Cosine_Approx; - - ----------------- - -- Sine_Approx -- - ----------------- - - function Sine_Approx (X : Double) return Double is - XX : constant Double := X * X; - begin - return (((((16#A.EA2D4ABE41808#E-09 * XX - - 16#6.B974C10F9D078#E-07) * XX - + 16#2.E3BC673425B0E#E-05) * XX - - 16#D.00D00CCA7AF00#E-04) * XX - + 16#2.222222221B190#E-02) * XX - - 16#2.AAAAAAAAAAA44#E-01) * (XX * X) + X; - end Sine_Approx; - - ------------ - -- Is_Nan -- - ------------ - - function Is_Nan (X : Double) return Boolean is - begin - -- The IEEE NaN values are the only ones that do not equal themselves - - return X /= X; - end Is_Nan; - - ------------ - -- Reduce -- - ------------ - - procedure Reduce (X : in out Double; Q : out Natural) is - Half_Pi : constant := Pi / 2.0; - Two_Over_Pi : constant := 2.0 / Pi; - - HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); - M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant - P1 : constant Double := Double'Leading_Part (Half_Pi, HM); - P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); - P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); - P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); - P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 - - P4, HM); - P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); - K : Double; - R : Integer; - - begin - -- For X < 2.0**HM, all products below are computed exactly. - -- Due to cancellation effects all subtractions are exact as well. - -- As no double extended floating-point number has more than 75 - -- zeros after the binary point, the result will be the correctly - -- rounded result of X - K * (Pi / 2.0). - - K := X * Two_Over_Pi; - while abs K >= 2.0**HM loop - K := K * M - (K * M - K); - X := - (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - K := X * Two_Over_Pi; - end loop; - - -- If K is not a number (because X was not finite) raise exception - - if Is_Nan (K) then - raise Constraint_Error; - end if; - - -- Go through an integer temporary so as to use machine instructions - - R := Integer (Double'Rounding (K)); - Q := R mod 4; - K := Double (R); - X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - end Reduce; - - --------- - -- Cos -- - --------- - - function Cos (X : Double) return Double is - Reduced_X : Double := abs X; - Quadrant : Natural range 0 .. 3; - - begin - if Reduced_X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - return Cosine_Approx (Reduced_X); - - when 1 => - return Sine_Approx (-Reduced_X); - - when 2 => - return -Cosine_Approx (Reduced_X); - - when 3 => - return Sine_Approx (Reduced_X); - end case; - end if; - - return Cosine_Approx (Reduced_X); - end Cos; - - --------- - -- Sin -- - --------- - - function Sin (X : Double) return Double is - Reduced_X : Double := X; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - return Sine_Approx (Reduced_X); - - when 1 => - return Cosine_Approx (Reduced_X); - - when 2 => - return Sine_Approx (-Reduced_X); - - when 3 => - return -Cosine_Approx (Reduced_X); - end case; - end if; - - return Sine_Approx (Reduced_X); - end Sin; - -end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-darwin.ads b/gcc/ada/libgnat/a-numaux-darwin.ads deleted file mode 100644 index 5767f4d563c..00000000000 --- a/gcc/ada/libgnat/a-numaux-darwin.ads +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (Apple OS X Version) -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for use on OS X. It uses the normal Unix math functions, --- except for sine/cosine which have been implemented directly in Ada to get --- the required accuracy. - -package Ada.Numerics.Aux is - pragma Pure; - - pragma Linker_Options ("-lm"); - - type Double is new Long_Float; - -- Type Double is the type used to call the C routines - - -- The following functions have been implemented in Ada, since - -- the OS X math library didn't meet accuracy requirements for - -- argument reduction. The implementation here has been tailored - -- to match Ada strict mode Numerics requirements while maintaining - -- maximum efficiency. - function Sin (X : Double) return Double; - pragma Inline (Sin); - - function Cos (X : Double) return Double; - pragma Inline (Cos); - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-libc-x86.ads b/gcc/ada/libgnat/a-numaux-libc-x86.ads deleted file mode 100644 index e6adf210597..00000000000 --- a/gcc/ada/libgnat/a-numaux-libc-x86.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (C Library Version for x86) -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for the x86 using the 80-bit x86 long double format - -package Ada.Numerics.Aux is - pragma Pure; - - pragma Linker_Options ("-lm"); - - type Double is new Long_Long_Float; - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sinl"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cosl"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tanl"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "expl"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrtl"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "logl"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acosl"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asinl"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atanl"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinhl"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "coshl"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanhl"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "powl"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-vxworks.ads b/gcc/ada/libgnat/a-numaux-vxworks.ads deleted file mode 100644 index 31f57c071e2..00000000000 --- a/gcc/ada/libgnat/a-numaux-vxworks.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (C Library Version, VxWorks) -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version for use on VxWorks (where we have no libm.a library), so the pragma --- Linker_Options ("-lm") is omitted in this version. - -package Ada.Numerics.Aux is - pragma Pure; - - type Double is new Long_Float; - -- Type Double is the type used to call the C routines - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sin"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cos"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-x86.adb b/gcc/ada/libgnat/a-numaux-x86.adb deleted file mode 100644 index 303b7293c2c..00000000000 --- a/gcc/ada/libgnat/a-numaux-x86.adb +++ /dev/null @@ -1,577 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- B o d y -- --- (Machine Version for x86) -- --- -- --- Copyright (C) 1998-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Machine_Code; use System.Machine_Code; - -package body Ada.Numerics.Aux is - - NL : constant String := ASCII.LF & ASCII.HT; - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Is_Nan (X : Double) return Boolean; - -- Return True iff X is a IEEE NaN value - - function Logarithmic_Pow (X, Y : Double) return Double; - -- Implementation of X**Y using Exp and Log functions (binary base) - -- to calculate the exponentiation. This is used by Pow for values - -- for values of Y in the open interval (-0.25, 0.25) - - procedure Reduce (X : in out Double; Q : out Natural); - -- Implement reduction of X by Pi/2. Q is the quadrant of the final - -- result in the range 0..3. The absolute value of X is at most Pi/4. - -- It is needed to avoid a loss of accuracy for sin near Pi and cos - -- near Pi/2 due to the use of an insufficiently precise value of Pi - -- in the range reduction. - - pragma Inline (Is_Nan); - pragma Inline (Reduce); - - -------------------------------- - -- Basic Elementary Functions -- - -------------------------------- - - -- This section implements a few elementary functions that are used to - -- build the more complex ones. This ordering enables better inlining. - - ---------- - -- Atan -- - ---------- - - function Atan (X : Double) return Double is - Result : Double; - - begin - Asm (Template => - "fld1" & NL - & "fpatan", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - - -- The result value is NaN iff input was invalid - - if not (Result = Result) then - raise Argument_Error; - end if; - - return Result; - end Atan; - - --------- - -- Exp -- - --------- - - function Exp (X : Double) return Double is - Result : Double; - begin - Asm (Template => - "fldl2e " & NL - & "fmulp %%st, %%st(1)" & NL -- X * log2 (E) - & "fld %%st(0) " & NL - & "frndint " & NL -- Integer (X * Log2 (E)) - & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E)) - & "fxch " & NL - & "f2xm1 " & NL -- 2**(...) - 1 - & "fld1 " & NL - & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E))) - & "fscale " & NL -- E ** X - & "fstp %%st(1) ", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - return Result; - end Exp; - - ------------ - -- Is_Nan -- - ------------ - - function Is_Nan (X : Double) return Boolean is - begin - -- The IEEE NaN values are the only ones that do not equal themselves - - return X /= X; - end Is_Nan; - - --------- - -- Log -- - --------- - - function Log (X : Double) return Double is - Result : Double; - - begin - Asm (Template => - "fldln2 " & NL - & "fxch " & NL - & "fyl2x " & NL, - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - return Result; - end Log; - - ------------ - -- Reduce -- - ------------ - - procedure Reduce (X : in out Double; Q : out Natural) is - Half_Pi : constant := Pi / 2.0; - Two_Over_Pi : constant := 2.0 / Pi; - - HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); - M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant - P1 : constant Double := Double'Leading_Part (Half_Pi, HM); - P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); - P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); - P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); - P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 - - P4, HM); - P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); - K : Double; - R : Integer; - - begin - -- For X < 2.0**HM, all products below are computed exactly. - -- Due to cancellation effects all subtractions are exact as well. - -- As no double extended floating-point number has more than 75 - -- zeros after the binary point, the result will be the correctly - -- rounded result of X - K * (Pi / 2.0). - - K := X * Two_Over_Pi; - while abs K >= 2.0**HM loop - K := K * M - (K * M - K); - X := - (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - K := X * Two_Over_Pi; - end loop; - - -- If K is not a number (because X was not finite) raise exception - - if Is_Nan (K) then - raise Constraint_Error; - end if; - - -- Go through an integer temporary so as to use machine instructions - - R := Integer (Double'Rounding (K)); - Q := R mod 4; - K := Double (R); - X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - end Reduce; - - ---------- - -- Sqrt -- - ---------- - - function Sqrt (X : Double) return Double is - Result : Double; - - begin - if X < 0.0 then - raise Argument_Error; - end if; - - Asm (Template => "fsqrt", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - - return Result; - end Sqrt; - - -------------------------------- - -- Other Elementary Functions -- - -------------------------------- - - -- These are built using the previously implemented basic functions - - ---------- - -- Acos -- - ---------- - - function Acos (X : Double) return Double is - Result : Double; - - begin - Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X))); - - -- The result value is NaN iff input was invalid - - if Is_Nan (Result) then - raise Argument_Error; - end if; - - return Result; - end Acos; - - ---------- - -- Asin -- - ---------- - - function Asin (X : Double) return Double is - Result : Double; - - begin - Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X))); - - -- The result value is NaN iff input was invalid - - if Is_Nan (Result) then - raise Argument_Error; - end if; - - return Result; - end Asin; - - --------- - -- Cos -- - --------- - - function Cos (X : Double) return Double is - Reduced_X : Double := abs X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if Reduced_X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 1 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", -Reduced_X)); - - when 2 => - Asm (Template => "fcos ; fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 3 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end case; - - else - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Cos; - - --------------------- - -- Logarithmic_Pow -- - --------------------- - - function Logarithmic_Pow (X, Y : Double) return Double is - Result : Double; - begin - Asm (Template => "" -- X : Y - & "fyl2x " & NL -- Y * Log2 (X) - & "fld %%st(0) " & NL -- Y * Log2 (X) : Y * Log2 (X) - & "frndint " & NL -- Int (...) : Y * Log2 (X) - & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...) - & "fxch " & NL -- Fract (...) : Int (...) - & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...) - & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...) - & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...) - & "fscale ", -- 2**(Fract (...) + Int (...)) - Outputs => Double'Asm_Output ("=t", Result), - Inputs => - (Double'Asm_Input ("0", X), - Double'Asm_Input ("u", Y))); - return Result; - end Logarithmic_Pow; - - --------- - -- Pow -- - --------- - - function Pow (X, Y : Double) return Double is - type Mantissa_Type is mod 2**Double'Machine_Mantissa; - -- Modular type that can hold all bits of the mantissa of Double - - -- For negative exponents, do divide at the end of the processing - - Negative_Y : constant Boolean := Y < 0.0; - Abs_Y : constant Double := abs Y; - - -- During this function the following invariant is kept: - -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor - - Base : Double := X; - - Exp_High : Double := Double'Floor (Abs_Y); - Exp_Mid : Double; - Exp_Low : Double; - Exp_Int : Mantissa_Type; - - Factor : Double := 1.0; - - begin - -- Select algorithm for calculating Pow (integer cases fall through) - - if Exp_High >= 2.0**Double'Machine_Mantissa then - - -- In case of Y that is IEEE infinity, just raise constraint error - - if Exp_High > Double'Safe_Last then - raise Constraint_Error; - end if; - - -- Large values of Y are even integers and will stay integer - -- after division by two. - - loop - -- Exp_Mid and Exp_Low are zero, so - -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2) - - Exp_High := Exp_High / 2.0; - Base := Base * Base; - exit when Exp_High < 2.0**Double'Machine_Mantissa; - end loop; - - elsif Exp_High /= Abs_Y then - Exp_Low := Abs_Y - Exp_High; - Factor := 1.0; - - if Exp_Low /= 0.0 then - - -- Exp_Low now is in interval (0.0, 1.0) - -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0; - - Exp_Mid := 0.0; - Exp_Low := Exp_Low - Exp_Mid; - - if Exp_Low >= 0.5 then - Factor := Sqrt (X); - Exp_Low := Exp_Low - 0.5; -- exact - - if Exp_Low >= 0.25 then - Factor := Factor * Sqrt (Factor); - Exp_Low := Exp_Low - 0.25; -- exact - end if; - - elsif Exp_Low >= 0.25 then - Factor := Sqrt (Sqrt (X)); - Exp_Low := Exp_Low - 0.25; -- exact - end if; - - -- Exp_Low now is in interval (0.0, 0.25) - - -- This means it is safe to call Logarithmic_Pow - -- for the remaining part. - - Factor := Factor * Logarithmic_Pow (X, Exp_Low); - end if; - - elsif X = 0.0 then - return 0.0; - end if; - - -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa - - Exp_Int := Mantissa_Type (Exp_High); - - -- Standard way for processing integer powers > 0 - - while Exp_Int > 1 loop - if (Exp_Int and 1) = 1 then - - -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0 - - Factor := Factor * Base; - end if; - - -- Exp_Int is even and Exp_Int > 0, so - -- Base**Y = (Base**2)**(Exp_Int / 2) - - Base := Base * Base; - Exp_Int := Exp_Int / 2; - end loop; - - -- Exp_Int = 1 or Exp_Int = 0 - - if Exp_Int = 1 then - Factor := Base * Factor; - end if; - - if Negative_Y then - Factor := 1.0 / Factor; - end if; - - return Factor; - end Pow; - - --------- - -- Sin -- - --------- - - function Sin (X : Double) return Double is - Reduced_X : Double := X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 1 => - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 2 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", -Reduced_X)); - - when 3 => - Asm (Template => "fcos ; fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end case; - - else - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Sin; - - --------- - -- Tan -- - --------- - - function Tan (X : Double) return Double is - Reduced_X : Double := X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - if Quadrant mod 2 = 0 then - Asm (Template => "fptan" & NL - & "ffree %%st(0)" & NL - & "fincstp", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - else - Asm (Template => "fsincos" & NL - & "fdivp %%st, %%st(1)" & NL - & "fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - else - Asm (Template => - "fptan " & NL - & "ffree %%st(0) " & NL - & "fincstp ", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Tan; - - ---------- - -- Sinh -- - ---------- - - function Sinh (X : Double) return Double is - begin - -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0 - - if abs X < 25.0 then - return (Exp (X) - Exp (-X)) / 2.0; - else - return Exp (X) / 2.0; - end if; - end Sinh; - - ---------- - -- Cosh -- - ---------- - - function Cosh (X : Double) return Double is - begin - -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0 - - if abs X < 22.0 then - return (Exp (X) + Exp (-X)) / 2.0; - else - return Exp (X) / 2.0; - end if; - end Cosh; - - ---------- - -- Tanh -- - ---------- - - function Tanh (X : Double) return Double is - begin - -- Return the Hyperbolic Tangent of x - - -- x -x - -- e - e Sinh (X) - -- Tanh (X) is defined to be ----------- = -------- - -- x -x Cosh (X) - -- e + e - - if abs X > 23.0 then - return Double'Copy_Sign (1.0, X); - end if; - - return 1.0 / (1.0 + Exp (-(2.0 * X))) - 1.0 / (1.0 + Exp (2.0 * X)); - end Tanh; - -end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-x86.ads b/gcc/ada/libgnat/a-numaux-x86.ads deleted file mode 100644 index 2002ccdbca2..00000000000 --- a/gcc/ada/libgnat/a-numaux-x86.ads +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (Machine Version for x86) -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for the x86 using the 80-bit x86 long double format with --- inline asm statements. - -package Ada.Numerics.Aux is - pragma Pure; - - type Double is new Long_Long_Float; - - function Sin (X : Double) return Double; - - function Cos (X : Double) return Double; - - function Tan (X : Double) return Double; - - function Exp (X : Double) return Double; - - function Sqrt (X : Double) return Double; - - function Log (X : Double) return Double; - - function Atan (X : Double) return Double; - - function Acos (X : Double) return Double; - - function Asin (X : Double) return Double; - - function Sinh (X : Double) return Double; - - function Cosh (X : Double) return Double; - - function Tanh (X : Double) return Double; - - function Pow (X, Y : Double) return Double; - -private - pragma Inline (Atan); - pragma Inline (Cos); - pragma Inline (Tan); - pragma Inline (Exp); - pragma Inline (Log); - pragma Inline (Sin); - pragma Inline (Sqrt); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__darwin.adb b/gcc/ada/libgnat/a-numaux__darwin.adb new file mode 100644 index 00000000000..88e9e7c2a2d --- /dev/null +++ b/gcc/ada/libgnat/a-numaux__darwin.adb @@ -0,0 +1,211 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- B o d y -- +-- (Apple OS X Version) -- +-- -- +-- Copyright (C) 1998-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Numerics.Aux is + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Is_Nan (X : Double) return Boolean; + -- Return True iff X is a IEEE NaN value + + procedure Reduce (X : in out Double; Q : out Natural); + -- Implement reduction of X by Pi/2. Q is the quadrant of the final + -- result in the range 0..3. The absolute value of X is at most Pi/4. + -- It is needed to avoid a loss of accuracy for sin near Pi and cos + -- near Pi/2 due to the use of an insufficiently precise value of Pi + -- in the range reduction. + + -- The following two functions implement Chebishev approximations + -- of the trigonometric functions in their reduced domain. + -- These approximations have been computed using Maple. + + function Sine_Approx (X : Double) return Double; + function Cosine_Approx (X : Double) return Double; + + pragma Inline (Reduce); + pragma Inline (Sine_Approx); + pragma Inline (Cosine_Approx); + + ------------------- + -- Cosine_Approx -- + ------------------- + + function Cosine_Approx (X : Double) return Double is + XX : constant Double := X * X; + begin + return (((((16#8.DC57FBD05F640#E-08 * XX + - 16#4.9F7D00BF25D80#E-06) * XX + + 16#1.A019F7FDEFCC2#E-04) * XX + - 16#5.B05B058F18B20#E-03) * XX + + 16#A.AAAAAAAA73FA8#E-02) * XX + - 16#7.FFFFFFFFFFDE4#E-01) * XX + - 16#3.655E64869ECCE#E-14 + 1.0; + end Cosine_Approx; + + ----------------- + -- Sine_Approx -- + ----------------- + + function Sine_Approx (X : Double) return Double is + XX : constant Double := X * X; + begin + return (((((16#A.EA2D4ABE41808#E-09 * XX + - 16#6.B974C10F9D078#E-07) * XX + + 16#2.E3BC673425B0E#E-05) * XX + - 16#D.00D00CCA7AF00#E-04) * XX + + 16#2.222222221B190#E-02) * XX + - 16#2.AAAAAAAAAAA44#E-01) * (XX * X) + X; + end Sine_Approx; + + ------------ + -- Is_Nan -- + ------------ + + function Is_Nan (X : Double) return Boolean is + begin + -- The IEEE NaN values are the only ones that do not equal themselves + + return X /= X; + end Is_Nan; + + ------------ + -- Reduce -- + ------------ + + procedure Reduce (X : in out Double; Q : out Natural) is + Half_Pi : constant := Pi / 2.0; + Two_Over_Pi : constant := 2.0 / Pi; + + HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); + M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant + P1 : constant Double := Double'Leading_Part (Half_Pi, HM); + P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); + P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); + P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); + P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 + - P4, HM); + P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); + K : Double; + R : Integer; + + begin + -- For X < 2.0**HM, all products below are computed exactly. + -- Due to cancellation effects all subtractions are exact as well. + -- As no double extended floating-point number has more than 75 + -- zeros after the binary point, the result will be the correctly + -- rounded result of X - K * (Pi / 2.0). + + K := X * Two_Over_Pi; + while abs K >= 2.0**HM loop + K := K * M - (K * M - K); + X := + (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; + K := X * Two_Over_Pi; + end loop; + + -- If K is not a number (because X was not finite) raise exception + + if Is_Nan (K) then + raise Constraint_Error; + end if; + + -- Go through an integer temporary so as to use machine instructions + + R := Integer (Double'Rounding (K)); + Q := R mod 4; + K := Double (R); + X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; + end Reduce; + + --------- + -- Cos -- + --------- + + function Cos (X : Double) return Double is + Reduced_X : Double := abs X; + Quadrant : Natural range 0 .. 3; + + begin + if Reduced_X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + return Cosine_Approx (Reduced_X); + + when 1 => + return Sine_Approx (-Reduced_X); + + when 2 => + return -Cosine_Approx (Reduced_X); + + when 3 => + return Sine_Approx (Reduced_X); + end case; + end if; + + return Cosine_Approx (Reduced_X); + end Cos; + + --------- + -- Sin -- + --------- + + function Sin (X : Double) return Double is + Reduced_X : Double := X; + Quadrant : Natural range 0 .. 3; + + begin + if abs X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + return Sine_Approx (Reduced_X); + + when 1 => + return Cosine_Approx (Reduced_X); + + when 2 => + return Sine_Approx (-Reduced_X); + + when 3 => + return -Cosine_Approx (Reduced_X); + end case; + end if; + + return Sine_Approx (Reduced_X); + end Sin; + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__darwin.ads b/gcc/ada/libgnat/a-numaux__darwin.ads new file mode 100644 index 00000000000..5767f4d563c --- /dev/null +++ b/gcc/ada/libgnat/a-numaux__darwin.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (Apple OS X Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for use on OS X. It uses the normal Unix math functions, +-- except for sine/cosine which have been implemented directly in Ada to get +-- the required accuracy. + +package Ada.Numerics.Aux is + pragma Pure; + + pragma Linker_Options ("-lm"); + + type Double is new Long_Float; + -- Type Double is the type used to call the C routines + + -- The following functions have been implemented in Ada, since + -- the OS X math library didn't meet accuracy requirements for + -- argument reduction. The implementation here has been tailored + -- to match Ada strict mode Numerics requirements while maintaining + -- maximum efficiency. + function Sin (X : Double) return Double; + pragma Inline (Sin); + + function Cos (X : Double) return Double; + pragma Inline (Cos); + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__libc-x86.ads b/gcc/ada/libgnat/a-numaux__libc-x86.ads new file mode 100644 index 00000000000..e6adf210597 --- /dev/null +++ b/gcc/ada/libgnat/a-numaux__libc-x86.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (C Library Version for x86) -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for the x86 using the 80-bit x86 long double format + +package Ada.Numerics.Aux is + pragma Pure; + + pragma Linker_Options ("-lm"); + + type Double is new Long_Long_Float; + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sinl"); + pragma Pure_Function (Sin); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cosl"); + pragma Pure_Function (Cos); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tanl"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "expl"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrtl"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "logl"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acosl"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asinl"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atanl"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinhl"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "coshl"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanhl"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "powl"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__vxworks.ads b/gcc/ada/libgnat/a-numaux__vxworks.ads new file mode 100644 index 00000000000..31f57c071e2 --- /dev/null +++ b/gcc/ada/libgnat/a-numaux__vxworks.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (C Library Version, VxWorks) -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version for use on VxWorks (where we have no libm.a library), so the pragma +-- Linker_Options ("-lm") is omitted in this version. + +package Ada.Numerics.Aux is + pragma Pure; + + type Double is new Long_Float; + -- Type Double is the type used to call the C routines + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sin"); + pragma Pure_Function (Sin); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cos"); + pragma Pure_Function (Cos); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__x86.adb b/gcc/ada/libgnat/a-numaux__x86.adb new file mode 100644 index 00000000000..303b7293c2c --- /dev/null +++ b/gcc/ada/libgnat/a-numaux__x86.adb @@ -0,0 +1,577 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- B o d y -- +-- (Machine Version for x86) -- +-- -- +-- Copyright (C) 1998-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Machine_Code; use System.Machine_Code; + +package body Ada.Numerics.Aux is + + NL : constant String := ASCII.LF & ASCII.HT; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Is_Nan (X : Double) return Boolean; + -- Return True iff X is a IEEE NaN value + + function Logarithmic_Pow (X, Y : Double) return Double; + -- Implementation of X**Y using Exp and Log functions (binary base) + -- to calculate the exponentiation. This is used by Pow for values + -- for values of Y in the open interval (-0.25, 0.25) + + procedure Reduce (X : in out Double; Q : out Natural); + -- Implement reduction of X by Pi/2. Q is the quadrant of the final + -- result in the range 0..3. The absolute value of X is at most Pi/4. + -- It is needed to avoid a loss of accuracy for sin near Pi and cos + -- near Pi/2 due to the use of an insufficiently precise value of Pi + -- in the range reduction. + + pragma Inline (Is_Nan); + pragma Inline (Reduce); + + -------------------------------- + -- Basic Elementary Functions -- + -------------------------------- + + -- This section implements a few elementary functions that are used to + -- build the more complex ones. This ordering enables better inlining. + + ---------- + -- Atan -- + ---------- + + function Atan (X : Double) return Double is + Result : Double; + + begin + Asm (Template => + "fld1" & NL + & "fpatan", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", X)); + + -- The result value is NaN iff input was invalid + + if not (Result = Result) then + raise Argument_Error; + end if; + + return Result; + end Atan; + + --------- + -- Exp -- + --------- + + function Exp (X : Double) return Double is + Result : Double; + begin + Asm (Template => + "fldl2e " & NL + & "fmulp %%st, %%st(1)" & NL -- X * log2 (E) + & "fld %%st(0) " & NL + & "frndint " & NL -- Integer (X * Log2 (E)) + & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E)) + & "fxch " & NL + & "f2xm1 " & NL -- 2**(...) - 1 + & "fld1 " & NL + & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E))) + & "fscale " & NL -- E ** X + & "fstp %%st(1) ", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", X)); + return Result; + end Exp; + + ------------ + -- Is_Nan -- + ------------ + + function Is_Nan (X : Double) return Boolean is + begin + -- The IEEE NaN values are the only ones that do not equal themselves + + return X /= X; + end Is_Nan; + + --------- + -- Log -- + --------- + + function Log (X : Double) return Double is + Result : Double; + + begin + Asm (Template => + "fldln2 " & NL + & "fxch " & NL + & "fyl2x " & NL, + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", X)); + return Result; + end Log; + + ------------ + -- Reduce -- + ------------ + + procedure Reduce (X : in out Double; Q : out Natural) is + Half_Pi : constant := Pi / 2.0; + Two_Over_Pi : constant := 2.0 / Pi; + + HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); + M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant + P1 : constant Double := Double'Leading_Part (Half_Pi, HM); + P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); + P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); + P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); + P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 + - P4, HM); + P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); + K : Double; + R : Integer; + + begin + -- For X < 2.0**HM, all products below are computed exactly. + -- Due to cancellation effects all subtractions are exact as well. + -- As no double extended floating-point number has more than 75 + -- zeros after the binary point, the result will be the correctly + -- rounded result of X - K * (Pi / 2.0). + + K := X * Two_Over_Pi; + while abs K >= 2.0**HM loop + K := K * M - (K * M - K); + X := + (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; + K := X * Two_Over_Pi; + end loop; + + -- If K is not a number (because X was not finite) raise exception + + if Is_Nan (K) then + raise Constraint_Error; + end if; + + -- Go through an integer temporary so as to use machine instructions + + R := Integer (Double'Rounding (K)); + Q := R mod 4; + K := Double (R); + X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; + end Reduce; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (X : Double) return Double is + Result : Double; + + begin + if X < 0.0 then + raise Argument_Error; + end if; + + Asm (Template => "fsqrt", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", X)); + + return Result; + end Sqrt; + + -------------------------------- + -- Other Elementary Functions -- + -------------------------------- + + -- These are built using the previously implemented basic functions + + ---------- + -- Acos -- + ---------- + + function Acos (X : Double) return Double is + Result : Double; + + begin + Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X))); + + -- The result value is NaN iff input was invalid + + if Is_Nan (Result) then + raise Argument_Error; + end if; + + return Result; + end Acos; + + ---------- + -- Asin -- + ---------- + + function Asin (X : Double) return Double is + Result : Double; + + begin + Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X))); + + -- The result value is NaN iff input was invalid + + if Is_Nan (Result) then + raise Argument_Error; + end if; + + return Result; + end Asin; + + --------- + -- Cos -- + --------- + + function Cos (X : Double) return Double is + Reduced_X : Double := abs X; + Result : Double; + Quadrant : Natural range 0 .. 3; + + begin + if Reduced_X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + Asm (Template => "fcos", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + + when 1 => + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", -Reduced_X)); + + when 2 => + Asm (Template => "fcos ; fchs", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + + when 3 => + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end case; + + else + Asm (Template => "fcos", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end if; + + return Result; + end Cos; + + --------------------- + -- Logarithmic_Pow -- + --------------------- + + function Logarithmic_Pow (X, Y : Double) return Double is + Result : Double; + begin + Asm (Template => "" -- X : Y + & "fyl2x " & NL -- Y * Log2 (X) + & "fld %%st(0) " & NL -- Y * Log2 (X) : Y * Log2 (X) + & "frndint " & NL -- Int (...) : Y * Log2 (X) + & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...) + & "fxch " & NL -- Fract (...) : Int (...) + & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...) + & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...) + & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...) + & "fscale ", -- 2**(Fract (...) + Int (...)) + Outputs => Double'Asm_Output ("=t", Result), + Inputs => + (Double'Asm_Input ("0", X), + Double'Asm_Input ("u", Y))); + return Result; + end Logarithmic_Pow; + + --------- + -- Pow -- + --------- + + function Pow (X, Y : Double) return Double is + type Mantissa_Type is mod 2**Double'Machine_Mantissa; + -- Modular type that can hold all bits of the mantissa of Double + + -- For negative exponents, do divide at the end of the processing + + Negative_Y : constant Boolean := Y < 0.0; + Abs_Y : constant Double := abs Y; + + -- During this function the following invariant is kept: + -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor + + Base : Double := X; + + Exp_High : Double := Double'Floor (Abs_Y); + Exp_Mid : Double; + Exp_Low : Double; + Exp_Int : Mantissa_Type; + + Factor : Double := 1.0; + + begin + -- Select algorithm for calculating Pow (integer cases fall through) + + if Exp_High >= 2.0**Double'Machine_Mantissa then + + -- In case of Y that is IEEE infinity, just raise constraint error + + if Exp_High > Double'Safe_Last then + raise Constraint_Error; + end if; + + -- Large values of Y are even integers and will stay integer + -- after division by two. + + loop + -- Exp_Mid and Exp_Low are zero, so + -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2) + + Exp_High := Exp_High / 2.0; + Base := Base * Base; + exit when Exp_High < 2.0**Double'Machine_Mantissa; + end loop; + + elsif Exp_High /= Abs_Y then + Exp_Low := Abs_Y - Exp_High; + Factor := 1.0; + + if Exp_Low /= 0.0 then + + -- Exp_Low now is in interval (0.0, 1.0) + -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0; + + Exp_Mid := 0.0; + Exp_Low := Exp_Low - Exp_Mid; + + if Exp_Low >= 0.5 then + Factor := Sqrt (X); + Exp_Low := Exp_Low - 0.5; -- exact + + if Exp_Low >= 0.25 then + Factor := Factor * Sqrt (Factor); + Exp_Low := Exp_Low - 0.25; -- exact + end if; + + elsif Exp_Low >= 0.25 then + Factor := Sqrt (Sqrt (X)); + Exp_Low := Exp_Low - 0.25; -- exact + end if; + + -- Exp_Low now is in interval (0.0, 0.25) + + -- This means it is safe to call Logarithmic_Pow + -- for the remaining part. + + Factor := Factor * Logarithmic_Pow (X, Exp_Low); + end if; + + elsif X = 0.0 then + return 0.0; + end if; + + -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa + + Exp_Int := Mantissa_Type (Exp_High); + + -- Standard way for processing integer powers > 0 + + while Exp_Int > 1 loop + if (Exp_Int and 1) = 1 then + + -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0 + + Factor := Factor * Base; + end if; + + -- Exp_Int is even and Exp_Int > 0, so + -- Base**Y = (Base**2)**(Exp_Int / 2) + + Base := Base * Base; + Exp_Int := Exp_Int / 2; + end loop; + + -- Exp_Int = 1 or Exp_Int = 0 + + if Exp_Int = 1 then + Factor := Base * Factor; + end if; + + if Negative_Y then + Factor := 1.0 / Factor; + end if; + + return Factor; + end Pow; + + --------- + -- Sin -- + --------- + + function Sin (X : Double) return Double is + Reduced_X : Double := X; + Result : Double; + Quadrant : Natural range 0 .. 3; + + begin + if abs X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + + when 1 => + Asm (Template => "fcos", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + + when 2 => + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", -Reduced_X)); + + when 3 => + Asm (Template => "fcos ; fchs", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end case; + + else + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end if; + + return Result; + end Sin; + + --------- + -- Tan -- + --------- + + function Tan (X : Double) return Double is + Reduced_X : Double := X; + Result : Double; + Quadrant : Natural range 0 .. 3; + + begin + if abs X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + if Quadrant mod 2 = 0 then + Asm (Template => "fptan" & NL + & "ffree %%st(0)" & NL + & "fincstp", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + else + Asm (Template => "fsincos" & NL + & "fdivp %%st, %%st(1)" & NL + & "fchs", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end if; + + else + Asm (Template => + "fptan " & NL + & "ffree %%st(0) " & NL + & "fincstp ", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end if; + + return Result; + end Tan; + + ---------- + -- Sinh -- + ---------- + + function Sinh (X : Double) return Double is + begin + -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0 + + if abs X < 25.0 then + return (Exp (X) - Exp (-X)) / 2.0; + else + return Exp (X) / 2.0; + end if; + end Sinh; + + ---------- + -- Cosh -- + ---------- + + function Cosh (X : Double) return Double is + begin + -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0 + + if abs X < 22.0 then + return (Exp (X) + Exp (-X)) / 2.0; + else + return Exp (X) / 2.0; + end if; + end Cosh; + + ---------- + -- Tanh -- + ---------- + + function Tanh (X : Double) return Double is + begin + -- Return the Hyperbolic Tangent of x + + -- x -x + -- e - e Sinh (X) + -- Tanh (X) is defined to be ----------- = -------- + -- x -x Cosh (X) + -- e + e + + if abs X > 23.0 then + return Double'Copy_Sign (1.0, X); + end if; + + return 1.0 / (1.0 + Exp (-(2.0 * X))) - 1.0 / (1.0 + Exp (2.0 * X)); + end Tanh; + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux__x86.ads b/gcc/ada/libgnat/a-numaux__x86.ads new file mode 100644 index 00000000000..2002ccdbca2 --- /dev/null +++ b/gcc/ada/libgnat/a-numaux__x86.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (Machine Version for x86) -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for the x86 using the 80-bit x86 long double format with +-- inline asm statements. + +package Ada.Numerics.Aux is + pragma Pure; + + type Double is new Long_Long_Float; + + function Sin (X : Double) return Double; + + function Cos (X : Double) return Double; + + function Tan (X : Double) return Double; + + function Exp (X : Double) return Double; + + function Sqrt (X : Double) return Double; + + function Log (X : Double) return Double; + + function Atan (X : Double) return Double; + + function Acos (X : Double) return Double; + + function Asin (X : Double) return Double; + + function Sinh (X : Double) return Double; + + function Cosh (X : Double) return Double; + + function Tanh (X : Double) return Double; + + function Pow (X, Y : Double) return Double; + +private + pragma Inline (Atan); + pragma Inline (Cos); + pragma Inline (Tan); + pragma Inline (Exp); + pragma Inline (Log); + pragma Inline (Sin); + pragma Inline (Sqrt); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-strunb-shared.adb b/gcc/ada/libgnat/a-strunb-shared.adb deleted file mode 100644 index 4347c065ea7..00000000000 --- a/gcc/ada/libgnat/a-strunb-shared.adb +++ /dev/null @@ -1,2115 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Unbounded is - - use Ada.Strings.Maps; - - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - function Aligned_Max_Length (Max_Length : Natural) return Natural; - -- Returns recommended length of the shared string which is greater or - -- equal to specified length. Calculation take in sense alignment of the - -- allocated memory segments to use memory effectively by Append/Insert/etc - -- operations. - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_String; - Right : Unbounded_String) return Unbounded_String - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := LR.Last + RR.Last; - DR : Shared_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Left string is empty, return Right string - - elsif LR.Last = 0 then - Reference (RR); - DR := RR; - - -- Right string is empty, return Left string - - elsif RR.Last = 0 then - Reference (LR); - DR := LR; - - -- Otherwise, allocate new shared string and fill data - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_String; - Right : String) return Unbounded_String - is - LR : constant Shared_String_Access := Left.Reference; - DL : constant Natural := LR.Last + Right'Length; - DR : Shared_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Right is an empty string, return Left string - - elsif Right'Length = 0 then - Reference (LR); - DR := LR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := Right; - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : String; - Right : Unbounded_String) return Unbounded_String - is - RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := Left'Length + RR.Last; - DR : Shared_String_Access; - - begin - -- Result is an empty string, reuse shared one - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Left is empty string, return Right string - - elsif Left'Length = 0 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Left'Length) := Left; - DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_String; - Right : Character) return Unbounded_String - is - LR : constant Shared_String_Access := Left.Reference; - DL : constant Natural := LR.Last + 1; - DR : Shared_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (DL) := Right; - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Character; - Right : Unbounded_String) return Unbounded_String - is - RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := 1 + RR.Last; - DR : Shared_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1) := Left; - DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Character) return Unbounded_String - is - DR : Shared_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if Left = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Left); - - for J in 1 .. Left loop - DR.Data (J) := Right; - end loop; - - DR.Last := Left; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : String) return Unbounded_String - is - DL : constant Natural := Left * Right'Length; - DR : Shared_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + Right'Length - 1) := Right; - K := K + Right'Length; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_String) return Unbounded_String - is - RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := Left * RR.Last; - DR : Shared_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Coefficient is one, just return string itself - - elsif Left = 1 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); - K := K + RR.Last; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); - end "<"; - - function "<" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) < Right; - end "<"; - - function "<" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left < RR.Data (1 .. RR.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); - end "<="; - - function "<=" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) <= Right; - end "<="; - - function "<=" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left <= RR.Data (1 .. RR.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - - begin - return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); - -- LR = RR means two strings shares shared string, thus they are equal - end "="; - - function "=" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) = Right; - end "="; - - function "=" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left = RR.Data (1 .. RR.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); - end ">"; - - function ">" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) > Right; - end ">"; - - function ">" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left > RR.Data (1 .. RR.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); - end ">="; - - function ">=" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) >= Right; - end ">="; - - function ">=" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left >= RR.Data (1 .. RR.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_String) is - begin - Reference (Object.Reference); - end Adjust; - - ------------------------ - -- Aligned_Max_Length -- - ------------------------ - - function Aligned_Max_Length (Max_Length : Natural) return Natural is - Static_Size : constant Natural := - Empty_Shared_String'Size / Standard'Storage_Unit; - -- Total size of all static components - - begin - return - ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc - - Static_Size; - end Aligned_Max_Length; - - -------------- - -- Allocate -- - -------------- - - function Allocate - (Max_Length : Natural) return not null Shared_String_Access - is - begin - -- Empty string requested, return shared empty string - - if Max_Length = 0 then - Reference (Empty_Shared_String'Access); - return Empty_Shared_String'Access; - - -- Otherwise, allocate requested space (and probably some more room) - - else - return new Shared_String (Aligned_Max_Length (Max_Length)); - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_String; - New_Item : Unbounded_String) - is - SR : constant Shared_String_Access := Source.Reference; - NR : constant Shared_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; - DR : Shared_String_Access; - - begin - -- Source is an empty string, reuse New_Item data - - if SR.Last = 0 then - Reference (NR); - Source.Reference := NR; - Unreference (SR); - - -- New_Item is empty string, nothing to do - - elsif NR.Last = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_String; - New_Item : String) - is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_String_Access; - - begin - -- New_Item is an empty string, nothing to do - - if New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_String; - New_Item : Character) - is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; - DR : Shared_String_Access; - - begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last + 1) then - SR.Data (SR.Last + 1) := New_Item; - SR.Last := SR.Last + 1; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - ------------------- - -- Can_Be_Reused -- - ------------------- - - function Can_Be_Reused - (Item : not null Shared_String_Access; - Length : Natural) return Boolean - is - begin - return - System.Atomic_Counters.Is_One (Item.Counter) - and then Item.Max_Length >= Length - and then Item.Max_Length <= - Aligned_Max_Length (Length + Length / Growth_Factor); - end Can_Be_Reused; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_String; - Set : Maps.Character_Set) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Count (SR.Data (1 .. SR.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_String; - From : Positive; - Through : Natural) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Empty slice is deleted, use the same shared string - - if From > Through then - Reference (SR); - DR := SR; - - -- Index is out of range - - elsif Through > SR.Last then - raise Index_Error; - - -- Compute size of the result - - else - DL := SR.Last - (Through - From + 1); - - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Delete; - - procedure Delete - (Source : in out Unbounded_String; - From : Positive; - Through : Natural) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Nothing changed, return - - if From > Through then - null; - - -- Through is outside of the range - - elsif Through > SR.Last then - raise Index_Error; - - else - DL := SR.Last - (Through - From + 1); - - -- Result is empty, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_String; - Index : Positive) return Character - is - SR : constant Shared_String_Access := Source.Reference; - begin - if Index <= SR.Last then - return SR.Data (Index); - else - raise Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_String) is - SR : constant not null Shared_String_Access := Object.Reference; - begin - if SR /= Null_Unbounded_String.Reference then - - -- The same controlled object can be finalized several times for - -- some reason. As per 7.6.1(24) this should have no ill effect, - -- so we need to add a guard for the case of finalizing the same - -- object twice. - - -- We set the Object to the empty string so there will be no ill - -- effects if a program references an already-finalized object. - - Object.Reference := Null_Unbounded_String.Reference; - Reference (Object.Reference); - Unreference (SR); - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_String_Access := Source.Reference; - begin - Search.Find_Token (SR.Data (From .. SR.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_String_Access := Source.Reference; - begin - Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (String, String_Access); - begin - Deallocate (X); - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Result is empty, reuse shared empty string - - if Count = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Length of the string is the same as requested, reuse source shared - -- string. - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is more than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- contents and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Head; - - procedure Head - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Result is empty, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Result is same as source string, reuse source shared string - - elsif Count = SR.Last then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, Count) then - if Count > SR.Last then - for J in SR.Last + 1 .. Count loop - SR.Data (J) := Pad; - end loop; - end if; - - SR.Last := Count; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is greater than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- existing data and fill remaining positions with Pad characters. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - Source.Reference := DR; - Unreference (SR); - end if; - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Strings.Direction := Strings.Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going); - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : Unbounded_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_String; - From : Positive; - Going : Direction := Forward) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_String) is - begin - Reference (Object.Reference); - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_String; - Before : Positive; - New_Item : String) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_String_Access; - - begin - -- Check index first - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Inserted string is empty, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Insert; - - procedure Insert - (Source : in out Unbounded_String; - Before : Positive; - New_Item : String) - is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Inserted string is empty, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string first - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_String) return Natural is - begin - return Source.Reference.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_String; - Position : Positive; - New_Item : String) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Result is same as source string, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_String; - Position : Positive; - New_Item : String) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Bounds check - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- String unchanged, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Overwrite; - - --------------- - -- Reference -- - --------------- - - procedure Reference (Item : not null Shared_String_Access) is - begin - System.Atomic_Counters.Increment (Item.Counter); - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_String; - Index : Positive; - By : Character) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Bounds check - - if Index <= SR.Last then - - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last) then - SR.Data (Index) := By; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (Index) := By; - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - else - raise Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural; - By : String) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation when removed slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - - -- Otherwise just insert string - - else - return Insert (Source, Low, By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_String; - Low : Positive; - High : Natural; - By : String) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Bounds check - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation only when replaced slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - SR.Data (Low .. Low + By'Length - 1) := By; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - - -- Otherwise just insert item - - else - Insert (Source, Low, By); - end if; - end Replace_Slice; - - -------------------------- - -- Set_Unbounded_String -- - -------------------------- - - procedure Set_Unbounded_String - (Target : out Unbounded_String; - Source : String) - is - TR : constant Shared_String_Access := Target.Reference; - DR : Shared_String_Access; - - begin - -- In case of empty string, reuse empty shared string - - if Source'Length = 0 then - Reference (Empty_Shared_String'Access); - Target.Reference := Empty_Shared_String'Access; - - else - -- Try to reuse existing shared string - - if Can_Be_Reused (TR, Source'Length) then - Reference (TR); - DR := TR; - - -- Otherwise allocate new shared string - - else - DR := Allocate (Source'Length); - Target.Reference := DR; - end if; - - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - Unreference (TR); - end Set_Unbounded_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return String - is - SR : constant Shared_String_Access := Source.Reference; - - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - else - return SR.Data (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- For empty result reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Result is whole source string, reuse source shared string - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Tail; - - procedure Tail - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - procedure Common - (SR : Shared_String_Access; - DR : Shared_String_Access; - Count : Natural); - -- Common code of tail computation. SR/DR can point to the same object - - ------------ - -- Common -- - ------------ - - procedure Common - (SR : Shared_String_Access; - DR : Shared_String_Access; - Count : Natural) is - begin - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end Common; - - begin - -- Result is empty string, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Length of the result is the same as length of the source string, - -- reuse source shared string. - - elsif Count = SR.Last then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, Count) then - Common (SR, SR, Count); - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - Common (SR, DR, Count); - Source.Reference := DR; - Unreference (SR); - end if; - end Tail; - - --------------- - -- To_String -- - --------------- - - function To_String (Source : Unbounded_String) return String is - begin - return Source.Reference.Data (1 .. Source.Reference.Last); - end To_String; - - ------------------------- - -- To_Unbounded_String -- - ------------------------- - - function To_Unbounded_String (Source : String) return Unbounded_String is - DR : Shared_String_Access; - - begin - if Source'Length = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - else - DR := Allocate (Source'Length); - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_String; - - function To_Unbounded_String (Length : Natural) return Unbounded_String is - DR : Shared_String_Access; - - begin - if Length = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - else - DR := Allocate (Length); - DR.Last := Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - end Translate; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - end Translate; - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping_Function) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - - exception - when others => - Unreference (DR); - - raise; - end Translate; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping_Function) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - exception - when others => - if DR /= null then - Unreference (DR); - end if; - - raise; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_String; - Side : Trim_End) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- reuse source shared string. - - if DL = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_String; - Side : Trim_End) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- nothing to do. - - if DL = SR.Last then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - function Trim - (Source : Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DL := High - Low + 1; - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_String; - Target : out Unbounded_String; - Low : Positive; - High : Natural) - is - SR : constant Shared_String_Access := Source.Reference; - TR : constant Shared_String_Access := Target.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_String'Access); - Target.Reference := Empty_Shared_String'Access; - Unreference (TR); - - else - DL := High - Low + 1; - - -- Try to reuse existing shared string - - if Can_Be_Reused (TR, DL) then - TR.Data (1 .. DL) := SR.Data (Low .. High); - TR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Target.Reference := DR; - Unreference (TR); - end if; - end if; - end Unbounded_Slice; - - ----------------- - -- Unreference -- - ----------------- - - procedure Unreference (Item : not null Shared_String_Access) is - - procedure Free is - new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access); - - Aux : Shared_String_Access := Item; - - begin - if System.Atomic_Counters.Decrement (Aux.Counter) then - - -- Reference counter of Empty_Shared_String should never reach - -- zero. We check here in case it wraps around. - - if Aux /= Empty_Shared_String'Access then - Free (Aux); - end if; - end if; - end Unreference; - -end Ada.Strings.Unbounded; diff --git a/gcc/ada/libgnat/a-strunb-shared.ads b/gcc/ada/libgnat/a-strunb-shared.ads deleted file mode 100644 index 3efa51c8a32..00000000000 --- a/gcc/ada/libgnat/a-strunb-shared.ads +++ /dev/null @@ -1,490 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an implementation of Ada.Strings.Unbounded that uses --- reference counts to implement copy on modification (rather than copy on --- assignment). This is significantly more efficient on many targets. - --- This version is supported on: --- - all Alpha platforms --- - all ia64 platforms --- - all PowerPC platforms --- - all SPARC V9 platforms --- - all x86 platforms --- - all x86_64 platforms - - -- This package uses several techniques to increase speed: - - -- - Implicit sharing or copy-on-write. An Unbounded_String contains only - -- the reference to the data which is shared between several instances. - -- The shared data is reallocated only when its value is changed and - -- the object mutation can't be used or it is inefficient to use it. - - -- - Object mutation. Shared data object can be reused without memory - -- reallocation when all of the following requirements are met: - -- - the shared data object is no longer used by anyone else; - -- - the size is sufficient to store the new value; - -- - the gap after reuse is less than a defined threshold. - - -- - Memory preallocation. Most of used memory allocation algorithms - -- align allocated segments on the some boundary, thus some amount of - -- additional memory can be preallocated without any impact. Such - -- preallocated memory can used later by Append/Insert operations - -- without reallocation. - - -- Reference counting uses GCC builtin atomic operations, which allows safe - -- sharing of internal data between Ada tasks. Nevertheless, this does not - -- make objects of Unbounded_String thread-safe: an instance cannot be - -- accessed by several tasks simultaneously. - -with Ada.Strings.Maps; -private with Ada.Finalization; -private with System.Atomic_Counters; - -package Ada.Strings.Unbounded is - pragma Preelaborate; - - type Unbounded_String is private; - pragma Preelaborable_Initialization (Unbounded_String); - - Null_Unbounded_String : constant Unbounded_String; - - function Length (Source : Unbounded_String) return Natural; - - type String_Access is access all String; - - procedure Free (X : in out String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_String - (Source : String) return Unbounded_String; - - function To_Unbounded_String - (Length : Natural) return Unbounded_String; - - function To_String (Source : Unbounded_String) return String; - - procedure Set_Unbounded_String - (Target : out Unbounded_String; - Source : String); - pragma Ada_05 (Set_Unbounded_String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : Unbounded_String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : Character); - - function "&" - (Left : Unbounded_String; - Right : Unbounded_String) return Unbounded_String; - - function "&" - (Left : Unbounded_String; - Right : String) return Unbounded_String; - - function "&" - (Left : String; - Right : Unbounded_String) return Unbounded_String; - - function "&" - (Left : Unbounded_String; - Right : Character) return Unbounded_String; - - function "&" - (Left : Character; - Right : Unbounded_String) return Unbounded_String; - - function Element - (Source : Unbounded_String; - Index : Positive) return Character; - - procedure Replace_Element - (Source : in out Unbounded_String; - Index : Positive; - By : Character); - - function Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return String; - - function Unbounded_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return Unbounded_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_String; - Target : out Unbounded_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "=" - (Left : String; - Right : Unbounded_String) return Boolean; - - function "<" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "<" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "<" - (Left : String; - Right : Unbounded_String) return Boolean; - - function "<=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "<=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "<=" - (Left : String; - Right : Unbounded_String) return Boolean; - - function ">" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function ">" - (Left : Unbounded_String; - Right : String) return Boolean; - - function ">" - (Left : String; - Right : Unbounded_String) return Boolean; - - function ">=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function ">=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function ">=" - (Left : String; - Right : Unbounded_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Count - (Source : Unbounded_String; - Set : Maps.Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping) return Unbounded_String; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping); - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping_Function) return Unbounded_String; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural; - By : String) return Unbounded_String; - - procedure Replace_Slice - (Source : in out Unbounded_String; - Low : Positive; - High : Natural; - By : String); - - function Insert - (Source : Unbounded_String; - Before : Positive; - New_Item : String) return Unbounded_String; - - procedure Insert - (Source : in out Unbounded_String; - Before : Positive; - New_Item : String); - - function Overwrite - (Source : Unbounded_String; - Position : Positive; - New_Item : String) return Unbounded_String; - - procedure Overwrite - (Source : in out Unbounded_String; - Position : Positive; - New_Item : String); - - function Delete - (Source : Unbounded_String; - From : Positive; - Through : Natural) return Unbounded_String; - - procedure Delete - (Source : in out Unbounded_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_String; - Side : Trim_End) return Unbounded_String; - - procedure Trim - (Source : in out Unbounded_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Unbounded_String; - - procedure Trim - (Source : in out Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set); - - function Head - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String; - - procedure Head - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space); - - function Tail - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String; - - procedure Tail - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space); - - function "*" - (Left : Natural; - Right : Character) return Unbounded_String; - - function "*" - (Left : Natural; - Right : String) return Unbounded_String; - - function "*" - (Left : Natural; - Right : Unbounded_String) return Unbounded_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - type Shared_String (Max_Length : Natural) is limited record - Counter : System.Atomic_Counters.Atomic_Counter; - -- Reference counter - - Last : Natural := 0; - Data : String (1 .. Max_Length); - -- Last is the index of last significant element of the Data. All - -- elements with larger indexes are currently insignificant. - end record; - - type Shared_String_Access is access all Shared_String; - - procedure Reference (Item : not null Shared_String_Access); - -- Increment reference counter - - procedure Unreference (Item : not null Shared_String_Access); - -- Decrement reference counter, deallocate Item when counter goes to zero - - function Can_Be_Reused - (Item : not null Shared_String_Access; - Length : Natural) return Boolean; - -- Returns True if Shared_String can be reused. There are two criteria when - -- Shared_String can be reused: its reference counter must be one (thus - -- Shared_String is owned exclusively) and its size is sufficient to - -- store string with specified length effectively. - - function Allocate - (Max_Length : Natural) return not null Shared_String_Access; - -- Allocates new Shared_String with at least specified maximum length. - -- Actual maximum length of the allocated Shared_String can be slightly - -- greater. Returns reference to Empty_Shared_String when requested length - -- is zero. - - Empty_Shared_String : aliased Shared_String (0); - - function To_Unbounded (S : String) return Unbounded_String - renames To_Unbounded_String; - -- This renames are here only to be used in the pragma Stream_Convert - - type Unbounded_String is new AF.Controlled with record - Reference : not null Shared_String_Access := Empty_Shared_String'Access; - end record; - - pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); - -- Provide stream routines without dragging in Ada.Streams - - pragma Finalize_Storage_Only (Unbounded_String); - -- Finalization is required only for freeing storage - - overriding procedure Initialize (Object : in out Unbounded_String); - overriding procedure Adjust (Object : in out Unbounded_String); - overriding procedure Finalize (Object : in out Unbounded_String); - - Null_Unbounded_String : constant Unbounded_String := - (AF.Controlled with - Reference => Empty_Shared_String'Access); - -end Ada.Strings.Unbounded; diff --git a/gcc/ada/libgnat/a-strunb__shared.adb b/gcc/ada/libgnat/a-strunb__shared.adb new file mode 100644 index 00000000000..4347c065ea7 --- /dev/null +++ b/gcc/ada/libgnat/a-strunb__shared.adb @@ -0,0 +1,2115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Unbounded is + + use Ada.Strings.Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of the + -- allocated memory segments to use memory effectively by Append/Insert/etc + -- operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Left string is empty, return Right string + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill data + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Right is an empty string, return Left string + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared one + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Left is empty string, return Right string + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String + is + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if Left = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Coefficient is one, just return string itself + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal + end "="; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + begin + return + ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc + - Static_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate + (Max_Length : Natural) return not null Shared_String_Access + is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_String'Access); + return Empty_Shared_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String) + is + SR : constant Shared_String_Access := Source.Reference; + NR : constant Shared_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : not null Shared_String_Access; + Length : Natural) return Boolean + is + begin + return + System.Atomic_Counters.Is_One (Item.Counter) + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_String; + Index : Positive) return Character + is + SR : constant Shared_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_String) is + SR : constant not null Shared_String_Access := Object.Reference; + begin + if SR /= Null_Unbounded_String.Reference then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + -- We set the Object to the empty string so there will be no ill + -- effects if a program references an already-finalized object. + + Object.Reference := Null_Unbounded_String.Reference; + Reference (Object.Reference); + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_String_Access := Source.Reference; + begin + Search.Find_Token (SR.Data (From .. SR.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_String_Access := Source.Reference; + begin + Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Result is same as source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- existing data and fill remaining positions with Pad characters. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Strings.Direction := Strings.Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Result is same as source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_String_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Index <= SR.Last then + + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + -------------------------- + -- Set_Unbounded_String -- + -------------------------- + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String) + is + TR : constant Shared_String_Access := Target.Reference; + DR : Shared_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_String'Access); + Target.Reference := Empty_Shared_String'Access; + + else + -- Try to reuse existing shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String + is + SR : constant Shared_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Result is whole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + procedure Common + (SR : Shared_String_Access; + DR : Shared_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_String_Access; + DR : Shared_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + --------------- + -- To_String -- + --------------- + + function To_String (Source : Unbounded_String) return String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_String; + + ------------------------- + -- To_Unbounded_String -- + ------------------------- + + function To_Unbounded_String (Source : String) return Unbounded_String is + DR : Shared_String_Access; + + begin + if Source'Length = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + function To_Unbounded_String (Length : Natural) return Unbounded_String is + DR : Shared_String_Access; + + begin + if Length = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_String_Access := Source.Reference; + TR : constant Shared_String_Access := Target.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_String'Access); + Target.Reference := Empty_Shared_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existing shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_String_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access); + + Aux : Shared_String_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + + -- Reference counter of Empty_Shared_String should never reach + -- zero. We check here in case it wraps around. + + if Aux /= Empty_Shared_String'Access then + Free (Aux); + end if; + end if; + end Unreference; + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/libgnat/a-strunb__shared.ads b/gcc/ada/libgnat/a-strunb__shared.ads new file mode 100644 index 00000000000..3efa51c8a32 --- /dev/null +++ b/gcc/ada/libgnat/a-strunb__shared.ads @@ -0,0 +1,490 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an implementation of Ada.Strings.Unbounded that uses +-- reference counts to implement copy on modification (rather than copy on +-- assignment). This is significantly more efficient on many targets. + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86 platforms +-- - all x86_64 platforms + + -- This package uses several techniques to increase speed: + + -- - Implicit sharing or copy-on-write. An Unbounded_String contains only + -- the reference to the data which is shared between several instances. + -- The shared data is reallocated only when its value is changed and + -- the object mutation can't be used or it is inefficient to use it. + + -- - Object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are met: + -- - the shared data object is no longer used by anyone else; + -- - the size is sufficient to store the new value; + -- - the gap after reuse is less than a defined threshold. + + -- - Memory preallocation. Most of used memory allocation algorithms + -- align allocated segments on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be + -- accessed by several tasks simultaneously. + +with Ada.Strings.Maps; +private with Ada.Finalization; +private with System.Atomic_Counters; + +package Ada.Strings.Unbounded is + pragma Preelaborate; + + type Unbounded_String is private; + pragma Preelaborable_Initialization (Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String; + + function Length (Source : Unbounded_String) return Natural; + + type String_Access is access all String; + + procedure Free (X : in out String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_String + (Source : String) return Unbounded_String; + + function To_Unbounded_String + (Length : Natural) return Unbounded_String; + + function To_String (Source : Unbounded_String) return String; + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String); + pragma Ada_05 (Set_Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character); + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String; + + function Element + (Source : Unbounded_String; + Index : Positive) return Character; + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character); + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String; + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping); + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String); + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String); + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String); + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set); + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_String (Max_Length : Natural) is limited record + Counter : System.Atomic_Counters.Atomic_Counter; + -- Reference counter + + Last : Natural := 0; + Data : String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indexes are currently insignificant. + end record; + + type Shared_String_Access is access all Shared_String; + + procedure Reference (Item : not null Shared_String_Access); + -- Increment reference counter + + procedure Unreference (Item : not null Shared_String_Access); + -- Decrement reference counter, deallocate Item when counter goes to zero + + function Can_Be_Reused + (Item : not null Shared_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_String can be reused. There are two criteria when + -- Shared_String can be reused: its reference counter must be one (thus + -- Shared_String is owned exclusively) and its size is sufficient to + -- store string with specified length effectively. + + function Allocate + (Max_Length : Natural) return not null Shared_String_Access; + -- Allocates new Shared_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_String can be slightly + -- greater. Returns reference to Empty_Shared_String when requested length + -- is zero. + + Empty_Shared_String : aliased Shared_String (0); + + function To_Unbounded (S : String) return Unbounded_String + renames To_Unbounded_String; + -- This renames are here only to be used in the pragma Stream_Convert + + type Unbounded_String is new AF.Controlled with record + Reference : not null Shared_String_Access := Empty_Shared_String'Access; + end record; + + pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_String); + overriding procedure Adjust (Object : in out Unbounded_String); + overriding procedure Finalize (Object : in out Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String := + (AF.Controlled with + Reference => Empty_Shared_String'Access); + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/libgnat/a-stunau-shared.adb b/gcc/ada/libgnat/a-stunau-shared.adb deleted file mode 100644 index 583deedeef1..00000000000 --- a/gcc/ada/libgnat/a-stunau-shared.adb +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Unbounded.Aux is - - ---------------- - -- Get_String -- - ---------------- - - procedure Get_String - (U : Unbounded_String; - S : out Big_String_Access; - L : out Natural) - is - X : aliased Big_String; - for X'Address use U.Reference.Data'Address; - begin - S := X'Unchecked_Access; - L := U.Reference.Last; - end Get_String; - - ---------------- - -- Set_String -- - ---------------- - - procedure Set_String (UP : in out Unbounded_String; S : String_Access) is - X : String_Access := S; - - begin - Set_Unbounded_String (UP, S.all); - Free (X); - end Set_String; - -end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-stunau__shared.adb b/gcc/ada/libgnat/a-stunau__shared.adb new file mode 100644 index 00000000000..583deedeef1 --- /dev/null +++ b/gcc/ada/libgnat/a-stunau__shared.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Unbounded.Aux is + + ---------------- + -- Get_String -- + ---------------- + + procedure Get_String + (U : Unbounded_String; + S : out Big_String_Access; + L : out Natural) + is + X : aliased Big_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_String; + + ---------------- + -- Set_String -- + ---------------- + + procedure Set_String (UP : in out Unbounded_String; S : String_Access) is + X : String_Access := S; + + begin + Set_Unbounded_String (UP, S.all); + Free (X); + end Set_String; + +end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-stwiun-shared.adb b/gcc/ada/libgnat/a-stwiun-shared.adb deleted file mode 100644 index 479e66abffe..00000000000 --- a/gcc/ada/libgnat/a-stwiun-shared.adb +++ /dev/null @@ -1,2128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Wide_Unbounded is - - use Ada.Strings.Wide_Maps; - - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - function Aligned_Max_Length (Max_Length : Natural) return Natural; - -- Returns recommended length of the shared string which is greater or - -- equal to specified length. Calculation take in sense alignment of - -- the allocated memory segments to use memory effectively by - -- Append/Insert/etc operations. - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - DL : constant Natural := LR.Last + RR.Last; - DR : Shared_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Left string is empty, return Rigth string - - elsif LR.Last = 0 then - Reference (RR); - DR := RR; - - -- Right string is empty, return Left string - - elsif RR.Last = 0 then - Reference (LR); - DR := LR; - - -- Overwise, allocate new shared string and fill data - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Unbounded_Wide_String - is - LR : constant Shared_Wide_String_Access := Left.Reference; - DL : constant Natural := LR.Last + Right'Length; - DR : Shared_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Right is an empty string, return Left string - - elsif Right'Length = 0 then - Reference (LR); - DR := LR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := Right; - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - RR : constant Shared_Wide_String_Access := Right.Reference; - DL : constant Natural := Left'Length + RR.Last; - DR : Shared_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared one - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Left is empty string, return Right string - - elsif Left'Length = 0 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Left'Length) := Left; - DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_Character) return Unbounded_Wide_String - is - LR : constant Shared_Wide_String_Access := Left.Reference; - DL : constant Natural := LR.Last + 1; - DR : Shared_Wide_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (DL) := Right; - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Wide_Character; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - RR : constant Shared_Wide_String_Access := Right.Reference; - DL : constant Natural := 1 + RR.Last; - DR : Shared_Wide_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1) := Left; - DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Character) return Unbounded_Wide_String - is - DR : Shared_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if Left = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Left); - - for J in 1 .. Left loop - DR.Data (J) := Right; - end loop; - - DR.Last := Left; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Wide_String) return Unbounded_Wide_String - is - DL : constant Natural := Left * Right'Length; - DR : Shared_Wide_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + Right'Length - 1) := Right; - K := K + Right'Length; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - RR : constant Shared_Wide_String_Access := Right.Reference; - DL : constant Natural := Left * RR.Last; - DR : Shared_Wide_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Coefficient is one, just return string itself - - elsif Left = 1 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); - K := K + RR.Last; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); - end "<"; - - function "<" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) < Right; - end "<"; - - function "<" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left < RR.Data (1 .. RR.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); - end "<="; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) <= Right; - end "<="; - - function "<=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left <= RR.Data (1 .. RR.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - - begin - return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); - -- LR = RR means two strings shares shared string, thus they are equal - end "="; - - function "=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) = Right; - end "="; - - function "=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left = RR.Data (1 .. RR.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); - end ">"; - - function ">" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) > Right; - end ">"; - - function ">" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left > RR.Data (1 .. RR.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); - end ">="; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) >= Right; - end ">="; - - function ">=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left >= RR.Data (1 .. RR.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_Wide_String) is - begin - Reference (Object.Reference); - end Adjust; - - ------------------------ - -- Aligned_Max_Length -- - ------------------------ - - function Aligned_Max_Length (Max_Length : Natural) return Natural is - Static_Size : constant Natural := - Empty_Shared_Wide_String'Size / Standard'Storage_Unit; - -- Total size of all static components - - Element_Size : constant Natural := - Wide_Character'Size / Standard'Storage_Unit; - - begin - return - (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) - * Min_Mul_Alloc - Static_Size) / Element_Size; - end Aligned_Max_Length; - - -------------- - -- Allocate -- - -------------- - - function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is - begin - -- Empty string requested, return shared empty string - - if Max_Length = 0 then - Reference (Empty_Shared_Wide_String'Access); - return Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate requested space (and probably some more room) - - else - return new Shared_Wide_String (Aligned_Max_Length (Max_Length)); - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Unbounded_Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - NR : constant Shared_Wide_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; - DR : Shared_Wide_String_Access; - - begin - -- Source is an empty string, reuse New_Item data - - if SR.Last = 0 then - Reference (NR); - Source.Reference := NR; - Unreference (SR); - - -- New_Item is empty string, nothing to do - - elsif NR.Last = 0 then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_String_Access; - - begin - -- New_Item is an empty string, nothing to do - - if New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_Character) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; - DR : Shared_Wide_String_Access; - - begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last + 1) then - SR.Data (SR.Last + 1) := New_Item; - SR.Last := SR.Last + 1; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - ------------------- - -- Can_Be_Reused -- - ------------------- - - function Can_Be_Reused - (Item : Shared_Wide_String_Access; - Length : Natural) return Boolean is - begin - return - System.Atomic_Counters.Is_One (Item.Counter) - and then Item.Max_Length >= Length - and then Item.Max_Length <= - Aligned_Max_Length (Length + Length / Growth_Factor); - end Can_Be_Reused; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Count (SR.Data (1 .. SR.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Empty slice is deleted, use the same shared string - - if From > Through then - Reference (SR); - DR := SR; - - -- Index is out of range - - elsif Through > SR.Last then - raise Index_Error; - - -- Compute size of the result - - else - DL := SR.Last - (Through - From + 1); - - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Delete; - - procedure Delete - (Source : in out Unbounded_Wide_String; - From : Positive; - Through : Natural) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Nothing changed, return - - if From > Through then - null; - - -- Through is outside of the range - - elsif Through > SR.Last then - raise Index_Error; - - else - DL := SR.Last - (Through - From + 1); - - -- Result is empty, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_Wide_String; - Index : Positive) return Wide_Character - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - if Index <= SR.Last then - return SR.Data (Index); - else - raise Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_Wide_String) is - SR : constant Shared_Wide_String_Access := Object.Reference; - - begin - if SR /= null then - - -- The same controlled object can be finalized several times for - -- some reason. As per 7.6.1(24) this should have no ill effect, - -- so we need to add a guard for the case of finalizing the same - -- object twice. - - Object.Reference := null; - Unreference (SR); - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - Wide_Search.Find_Token - (SR.Data (From .. SR.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - Wide_Search.Find_Token - (SR.Data (1 .. SR.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Wide_String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); - begin - Deallocate (X); - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Result is empty, reuse shared empty string - - if Count = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Length of the string is the same as requested, reuse source shared - -- string. - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is more than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- contents and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Head; - - procedure Head - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Result is empty, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Result is same with source string, reuse source shared string - - elsif Count = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, Count) then - if Count > SR.Last then - for J in SR.Last + 1 .. Count loop - SR.Data (J) := Pad; - end loop; - end if; - - SR.Last := Count; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is greater than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- exists data and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - Source.Reference := DR; - Unreference (SR); - end if; - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Strings.Direction := Strings.Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Set, From, Test, Going); - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index_Non_Blank - (SR.Data (1 .. SR.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_Wide_String) is - begin - Reference (Object.Reference); - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_String_Access; - - begin - -- Check index first - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Inserted string is empty, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Insert; - - procedure Insert - (Source : in out Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Inserted string is empty, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existent shared string first - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_Wide_String) return Natural is - begin - return Source.Reference.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Result is same with source string, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Bounds check - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- String unchanged, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Overwrite; - - --------------- - -- Reference -- - --------------- - - procedure Reference (Item : not null Shared_Wide_String_Access) is - begin - System.Atomic_Counters.Increment (Item.Counter); - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_Wide_String; - Index : Positive; - By : Wide_Character) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Bounds check - - if Index <= SR.Last then - - -- Try to reuse existent shared string - - if Can_Be_Reused (SR, SR.Last) then - SR.Data (Index) := By; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (Index) := By; - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - else - raise Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation when removed slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - - -- Otherwise just insert string - - else - return Insert (Source, Low, By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Bounds check - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation only when replaced slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - SR.Data (Low .. Low + By'Length - 1) := By; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - - -- Otherwise just insert item - - else - Insert (Source, Low, By); - end if; - end Replace_Slice; - - ------------------------------- - -- Set_Unbounded_Wide_String -- - ------------------------------- - - procedure Set_Unbounded_Wide_String - (Target : out Unbounded_Wide_String; - Source : Wide_String) - is - TR : constant Shared_Wide_String_Access := Target.Reference; - DR : Shared_Wide_String_Access; - - begin - -- In case of empty string, reuse empty shared string - - if Source'Length = 0 then - Reference (Empty_Shared_Wide_String'Access); - Target.Reference := Empty_Shared_Wide_String'Access; - - else - -- Try to reuse existent shared string - - if Can_Be_Reused (TR, Source'Length) then - Reference (TR); - DR := TR; - - -- Otherwise allocate new shared string - - else - DR := Allocate (Source'Length); - Target.Reference := DR; - end if; - - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - Unreference (TR); - end Set_Unbounded_Wide_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - else - return SR.Data (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- For empty result reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Result is hole source string, reuse source shared string - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Tail; - - procedure Tail - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - procedure Common - (SR : Shared_Wide_String_Access; - DR : Shared_Wide_String_Access; - Count : Natural); - -- Common code of tail computation. SR/DR can point to the same object - - ------------ - -- Common -- - ------------ - - procedure Common - (SR : Shared_Wide_String_Access; - DR : Shared_Wide_String_Access; - Count : Natural) is - begin - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end Common; - - begin - -- Result is empty string, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Length of the result is the same with length of the source string, - -- reuse source shared string. - - elsif Count = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, Count) then - Common (SR, SR, Count); - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - Common (SR, DR, Count); - Source.Reference := DR; - Unreference (SR); - end if; - end Tail; - - -------------------- - -- To_Wide_String -- - -------------------- - - function To_Wide_String - (Source : Unbounded_Wide_String) return Wide_String is - begin - return Source.Reference.Data (1 .. Source.Reference.Last); - end To_Wide_String; - - ------------------------------ - -- To_Unbounded_Wide_String -- - ------------------------------ - - function To_Unbounded_Wide_String - (Source : Wide_String) return Unbounded_Wide_String - is - DR : Shared_Wide_String_Access; - - begin - if Source'Length = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - else - DR := Allocate (Source'Length); - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_Wide_String; - - function To_Unbounded_Wide_String - (Length : Natural) return Unbounded_Wide_String - is - DR : Shared_Wide_String_Access; - - begin - if Length = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - else - DR := Allocate (Length); - DR.Last := Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_Wide_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - end Translate; - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - - exception - when others => - Unreference (DR); - - raise; - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - exception - when others => - if DR /= null then - Unreference (DR); - end if; - - raise; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_Wide_String; - Side : Trim_End) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- reuse source shared string. - - if DL = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Side : Trim_End) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- nothing to do. - - if DL = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - function Trim - (Source : Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DL := High - Low + 1; - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_Wide_String; - Target : out Unbounded_Wide_String; - Low : Positive; - High : Natural) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - TR : constant Shared_Wide_String_Access := Target.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_Wide_String'Access); - Target.Reference := Empty_Shared_Wide_String'Access; - Unreference (TR); - - else - DL := High - Low + 1; - - -- Try to reuse existent shared string - - if Can_Be_Reused (TR, DL) then - TR.Data (1 .. DL) := SR.Data (Low .. High); - TR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Target.Reference := DR; - Unreference (TR); - end if; - end if; - end Unbounded_Slice; - - ----------------- - -- Unreference -- - ----------------- - - procedure Unreference (Item : not null Shared_Wide_String_Access) is - - procedure Free is - new Ada.Unchecked_Deallocation - (Shared_Wide_String, Shared_Wide_String_Access); - - Aux : Shared_Wide_String_Access := Item; - - begin - if System.Atomic_Counters.Decrement (Aux.Counter) then - - -- Reference counter of Empty_Shared_Wide_String must never reach - -- zero. - - pragma Assert (Aux /= Empty_Shared_Wide_String'Access); - - Free (Aux); - end if; - end Unreference; - -end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stwiun-shared.ads b/gcc/ada/libgnat/a-stwiun-shared.ads deleted file mode 100644 index a913df441c3..00000000000 --- a/gcc/ada/libgnat/a-stwiun-shared.ads +++ /dev/null @@ -1,494 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is supported on: --- - all Alpha platforms --- - all ia64 platforms --- - all PowerPC platforms --- - all SPARC V9 platforms --- - all x86 platforms --- - all x86_64 platforms - -with Ada.Strings.Wide_Maps; -private with Ada.Finalization; -private with System.Atomic_Counters; - -package Ada.Strings.Wide_Unbounded is - pragma Preelaborate; - - type Unbounded_Wide_String is private; - pragma Preelaborable_Initialization (Unbounded_Wide_String); - - Null_Unbounded_Wide_String : constant Unbounded_Wide_String; - - function Length (Source : Unbounded_Wide_String) return Natural; - - type Wide_String_Access is access all Wide_String; - - procedure Free (X : in out Wide_String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_Wide_String - (Source : Wide_String) return Unbounded_Wide_String; - - function To_Unbounded_Wide_String - (Length : Natural) return Unbounded_Wide_String; - - function To_Wide_String - (Source : Unbounded_Wide_String) return Wide_String; - - procedure Set_Unbounded_Wide_String - (Target : out Unbounded_Wide_String; - Source : Wide_String); - pragma Ada_05 (Set_Unbounded_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Unbounded_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_Character); - - function "&" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_Character) return Unbounded_Wide_String; - - function "&" - (Left : Wide_Character; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function Element - (Source : Unbounded_Wide_String; - Index : Positive) return Wide_Character; - - procedure Replace_Element - (Source : in out Unbounded_Wide_String; - Index : Positive; - By : Wide_Character); - - function Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Wide_String; - - function Unbounded_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_Wide_String; - Target : out Unbounded_Wide_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "<" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "<=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function ">" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function ">=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Count - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - return Unbounded_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping); - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - return Unbounded_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) return Unbounded_Wide_String; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String); - - function Insert - (Source : Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) return Unbounded_Wide_String; - - procedure Insert - (Source : in out Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String); - - function Overwrite - (Source : Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) return Unbounded_Wide_String; - - procedure Overwrite - (Source : in out Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String); - - function Delete - (Source : Unbounded_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_String; - - procedure Delete - (Source : in out Unbounded_Wide_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_Wide_String; - Side : Trim_End) return Unbounded_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set); - - function Head - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; - - procedure Head - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space); - - function Tail - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; - - procedure Tail - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space); - - function "*" - (Left : Natural; - Right : Wide_Character) return Unbounded_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_String) return Unbounded_Wide_String; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - type Shared_Wide_String (Max_Length : Natural) is limited record - Counter : System.Atomic_Counters.Atomic_Counter; - -- Reference counter - - Last : Natural := 0; - Data : Wide_String (1 .. Max_Length); - -- Last is the index of last significant element of the Data. All - -- elements with larger indexes are just extra room for expansion. - end record; - - type Shared_Wide_String_Access is access all Shared_Wide_String; - - procedure Reference (Item : not null Shared_Wide_String_Access); - -- Increment reference counter. - - procedure Unreference (Item : not null Shared_Wide_String_Access); - -- Decrement reference counter. Deallocate Item when ref counter is zero - - function Can_Be_Reused - (Item : Shared_Wide_String_Access; - Length : Natural) return Boolean; - -- Returns True if Shared_Wide_String can be reused. There are two criteria - -- when Shared_Wide_String can be reused: its reference counter must be one - -- (thus Shared_Wide_String is owned exclusively) and its size is - -- sufficient to store string with specified length effectively. - - function Allocate (Max_Length : Natural) return Shared_Wide_String_Access; - -- Allocates new Shared_Wide_String with at least specified maximum length. - -- Actual maximum length of the allocated Shared_Wide_String can be - -- slightly greater. Returns reference to Empty_Shared_Wide_String when - -- requested length is zero. - - Empty_Shared_Wide_String : aliased Shared_Wide_String (0); - - function To_Unbounded (S : Wide_String) return Unbounded_Wide_String - renames To_Unbounded_Wide_String; - -- This renames are here only to be used in the pragma Stream_Convert - - type Unbounded_Wide_String is new AF.Controlled with record - Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access; - end record; - - -- The Unbounded_Wide_String uses several techniques to increase speed of - -- the application: - - -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains - -- only the reference to the data which is shared between several - -- instances. The shared data is reallocated only when its value is - -- changed and the object mutation can't be used or it is inefficient to - -- use it; - - -- - object mutation. Shared data object can be reused without memory - -- reallocation when all of the following requirements are meat: - -- - shared data object don't used anywhere longer; - -- - its size is sufficient to store new value; - -- - the gap after reuse is less than some threshold. - - -- - memory preallocation. Most of used memory allocation algorithms - -- aligns allocated segment on the some boundary, thus some amount of - -- additional memory can be preallocated without any impact. Such - -- preallocated memory can used later by Append/Insert operations - -- without reallocation. - - -- Reference counting uses GCC builtin atomic operations, which allows safe - -- sharing of internal data between Ada tasks. Nevertheless, this does not - -- make objects of Unbounded_String thread-safe: an instance cannot be - -- accessed by several tasks simultaneously. - - pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String); - -- Provide stream routines without dragging in Ada.Streams - - pragma Finalize_Storage_Only (Unbounded_Wide_String); - -- Finalization is required only for freeing storage - - overriding procedure Initialize (Object : in out Unbounded_Wide_String); - overriding procedure Adjust (Object : in out Unbounded_Wide_String); - overriding procedure Finalize (Object : in out Unbounded_Wide_String); - - Null_Unbounded_Wide_String : constant Unbounded_Wide_String := - (AF.Controlled with - Reference => - Empty_Shared_Wide_String'Access); - -end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stwiun__shared.adb b/gcc/ada/libgnat/a-stwiun__shared.adb new file mode 100644 index 00000000000..479e66abffe --- /dev/null +++ b/gcc/ada/libgnat/a-stwiun__shared.adb @@ -0,0 +1,2128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Unbounded is + + use Ada.Strings.Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left string is empty, return Rigth string + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Right is an empty string, return Left string + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left is empty string, return Right string + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if Left = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Coefficient is one, just return string itself + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal + end "="; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + return Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean is + begin + return + System.Atomic_Counters.Is_One (Item.Counter) + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_String) is + SR : constant Shared_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + Wide_Search.Find_Token + (SR.Data (From .. SR.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + Wide_Search.Find_Token + (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_String_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String) + is + TR : constant Shared_Wide_String_Access := Target.Reference; + DR : Shared_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + -------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_String; + + ------------------------------ + -- To_Unbounded_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + if Source'Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + if Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_String_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_String, Shared_Wide_String_Access); + + Aux : Shared_Wide_String_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + + -- Reference counter of Empty_Shared_Wide_String must never reach + -- zero. + + pragma Assert (Aux /= Empty_Shared_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stwiun__shared.ads b/gcc/ada/libgnat/a-stwiun__shared.ads new file mode 100644 index 00000000000..a913df441c3 --- /dev/null +++ b/gcc/ada/libgnat/a-stwiun__shared.ads @@ -0,0 +1,494 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Maps; +private with Ada.Finalization; +private with System.Atomic_Counters; + +package Ada.Strings.Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String; + + function Length (Source : Unbounded_Wide_String) return Natural; + + type Wide_String_Access is access all Wide_String; + + procedure Free (X : in out Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String; + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String; + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character); + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character); + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String); + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String); + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String); + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_String (Max_Length : Natural) is limited record + Counter : System.Atomic_Counters.Atomic_Counter; + -- Reference counter + + Last : Natural := 0; + Data : Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indexes are just extra room for expansion. + end record; + + type Shared_Wide_String_Access is access all Shared_Wide_String; + + procedure Reference (Item : not null Shared_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when ref counter is zero + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_String can be reused. There are two criteria + -- when Shared_Wide_String can be reused: its reference counter must be one + -- (thus Shared_Wide_String is owned exclusively) and its size is + -- sufficient to store string with specified length effectively. + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access; + -- Allocates new Shared_Wide_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_Wide_String can be + -- slightly greater. Returns reference to Empty_Shared_Wide_String when + -- requested length is zero. + + Empty_Shared_Wide_String : aliased Shared_Wide_String (0); + + function To_Unbounded (S : Wide_String) return Unbounded_Wide_String + renames To_Unbounded_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert + + type Unbounded_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access; + end record; + + -- The Unbounded_Wide_String uses several techniques to increase speed of + -- the application: + + -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains + -- only the reference to the data which is shared between several + -- instances. The shared data is reallocated only when its value is + -- changed and the object mutation can't be used or it is inefficient to + -- use it; + + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less than some threshold. + + -- - memory preallocation. Most of used memory allocation algorithms + -- aligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be + -- accessed by several tasks simultaneously. + + pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_Wide_String); + overriding procedure Adjust (Object : in out Unbounded_Wide_String); + overriding procedure Finalize (Object : in out Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String := + (AF.Controlled with + Reference => + Empty_Shared_Wide_String'Access); + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stzunb-shared.adb b/gcc/ada/libgnat/a-stzunb-shared.adb deleted file mode 100644 index e8b23729868..00000000000 --- a/gcc/ada/libgnat/a-stzunb-shared.adb +++ /dev/null @@ -1,2137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Wide_Wide_Unbounded is - - use Ada.Strings.Wide_Wide_Maps; - - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - function Aligned_Max_Length (Max_Length : Natural) return Natural; - -- Returns recommended length of the shared string which is greater or - -- equal to specified length. Calculation take in sense alignment of - -- the allocated memory segments to use memory effectively by - -- Append/Insert/etc operations. - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - DL : constant Natural := LR.Last + RR.Last; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Left string is empty, return Rigth string - - elsif LR.Last = 0 then - Reference (RR); - DR := RR; - - -- Right string is empty, return Left string - - elsif RR.Last = 0 then - Reference (LR); - DR := LR; - - -- Overwise, allocate new shared string and fill data - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - DL : constant Natural := LR.Last + Right'Length; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Right is an empty string, return Left string - - elsif Right'Length = 0 then - Reference (LR); - DR := LR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := Right; - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - DL : constant Natural := Left'Length + RR.Last; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared one - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Left is empty string, return Right string - - elsif Left'Length = 0 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Left'Length) := Left; - DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - DL : constant Natural := LR.Last + 1; - DR : Shared_Wide_Wide_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (DL) := Right; - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Wide_Wide_Character; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - DL : constant Natural := 1 + RR.Last; - DR : Shared_Wide_Wide_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1) := Left; - DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String - is - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if Left = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Left); - - for J in 1 .. Left loop - DR.Data (J) := Right; - end loop; - - DR.Last := Left; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - DL : constant Natural := Left * Right'Length; - DR : Shared_Wide_Wide_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + Right'Length - 1) := Right; - K := K + Right'Length; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - DL : constant Natural := Left * RR.Last; - DR : Shared_Wide_Wide_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Coefficient is one, just return string itself - - elsif Left = 1 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); - K := K + RR.Last; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); - end "<"; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) < Right; - end "<"; - - function "<" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left < RR.Data (1 .. RR.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); - end "<="; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) <= Right; - end "<="; - - function "<=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left <= RR.Data (1 .. RR.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - - begin - return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); - -- LR = RR means two strings shares shared string, thus they are equal - end "="; - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) = Right; - end "="; - - function "=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left = RR.Data (1 .. RR.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); - end ">"; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) > Right; - end ">"; - - function ">" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left > RR.Data (1 .. RR.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); - end ">="; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) >= Right; - end ">="; - - function ">=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left >= RR.Data (1 .. RR.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is - begin - Reference (Object.Reference); - end Adjust; - - ------------------------ - -- Aligned_Max_Length -- - ------------------------ - - function Aligned_Max_Length (Max_Length : Natural) return Natural is - Static_Size : constant Natural := - Empty_Shared_Wide_Wide_String'Size / Standard'Storage_Unit; - -- Total size of all static components - - Element_Size : constant Natural := - Wide_Wide_Character'Size / Standard'Storage_Unit; - - begin - return - (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) - * Min_Mul_Alloc - Static_Size) / Element_Size; - end Aligned_Max_Length; - - -------------- - -- Allocate -- - -------------- - - function Allocate - (Max_Length : Natural) return Shared_Wide_Wide_String_Access is - begin - -- Empty string requested, return shared empty string - - if Max_Length = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - return Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate requested space (and probably some more room) - - else - return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length)); - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Unbounded_Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Source is an empty string, reuse New_Item data - - if SR.Last = 0 then - Reference (NR); - Source.Reference := NR; - Unreference (SR); - - -- New_Item is empty string, nothing to do - - elsif NR.Last = 0 then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_Wide_String_Access; - - begin - -- New_Item is an empty string, nothing to do - - if New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_Character) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last + 1) then - SR.Data (SR.Last + 1) := New_Item; - SR.Last := SR.Last + 1; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - ------------------- - -- Can_Be_Reused -- - ------------------- - - function Can_Be_Reused - (Item : Shared_Wide_Wide_String_Access; - Length : Natural) return Boolean is - begin - return - System.Atomic_Counters.Is_One (Item.Counter) - and then Item.Max_Length >= Length - and then Item.Max_Length <= - Aligned_Max_Length (Length + Length / Growth_Factor); - end Can_Be_Reused; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Empty slice is deleted, use the same shared string - - if From > Through then - Reference (SR); - DR := SR; - - -- Index is out of range - - elsif Through > SR.Last then - raise Index_Error; - - -- Compute size of the result - - else - DL := SR.Last - (Through - From + 1); - - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Delete; - - procedure Delete - (Source : in out Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing changed, return - - if From > Through then - null; - - -- Through is outside of the range - - elsif Through > SR.Last then - raise Index_Error; - - else - DL := SR.Last - (Through - From + 1); - - -- Result is empty, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - if Index <= SR.Last then - return SR.Data (Index); - else - raise Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is - SR : constant Shared_Wide_Wide_String_Access := Object.Reference; - - begin - if SR /= null then - - -- The same controlled object can be finalized several times for - -- some reason. As per 7.6.1(24) this should have no ill effect, - -- so we need to add a guard for the case of finalizing the same - -- object twice. - - Object.Reference := null; - Unreference (SR); - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - Wide_Wide_Search.Find_Token - (SR.Data (From .. SR.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - Wide_Wide_Search.Find_Token - (SR.Data (1 .. SR.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Wide_Wide_String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation - (Wide_Wide_String, Wide_Wide_String_Access); - begin - Deallocate (X); - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is empty, reuse shared empty string - - if Count = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Length of the string is the same as requested, reuse source shared - -- string. - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is more than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- contents and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Head; - - procedure Head - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is empty, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Result is same with source string, reuse source shared string - - elsif Count = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, Count) then - if Count > SR.Last then - for J in SR.Last + 1 .. Count loop - SR.Data (J) := Pad; - end loop; - end if; - - SR.Last := Count; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is greater than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- exists data and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - Source.Reference := DR; - Unreference (SR); - end if; - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Strings.Direction := Strings.Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Set, From, Test, Going); - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index_Non_Blank - (SR.Data (1 .. SR.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is - begin - Reference (Object.Reference); - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check index first - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Inserted string is empty, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Insert; - - procedure Insert - (Source : in out Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Inserted string is empty, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existent shared string first - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_Wide_Wide_String) return Natural is - begin - return Source.Reference.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Result is same with source string, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Bounds check - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- String unchanged, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Overwrite; - - --------------- - -- Reference -- - --------------- - - procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is - begin - System.Atomic_Counters.Increment (Item.Counter); - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_Wide_Wide_String; - Index : Positive; - By : Wide_Wide_Character) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Bounds check - - if Index <= SR.Last then - - -- Try to reuse existent shared string - - if Can_Be_Reused (SR, SR.Last) then - SR.Data (Index) := By; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (Index) := By; - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - else - raise Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation when removed slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - - -- Otherwise just insert string - - else - return Insert (Source, Low, By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Bounds check - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation only when replaced slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - SR.Data (Low .. Low + By'Length - 1) := By; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - - -- Otherwise just insert item - - else - Insert (Source, Low, By); - end if; - end Replace_Slice; - - ------------------------------- - -- Set_Unbounded_Wide_Wide_String -- - ------------------------------- - - procedure Set_Unbounded_Wide_Wide_String - (Target : out Unbounded_Wide_Wide_String; - Source : Wide_Wide_String) - is - TR : constant Shared_Wide_Wide_String_Access := Target.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- In case of empty string, reuse empty shared string - - if Source'Length = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Target.Reference := Empty_Shared_Wide_Wide_String'Access; - - else - -- Try to reuse existent shared string - - if Can_Be_Reused (TR, Source'Length) then - Reference (TR); - DR := TR; - - -- Otherwise allocate new shared string - - else - DR := Allocate (Source'Length); - Target.Reference := DR; - end if; - - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - Unreference (TR); - end Set_Unbounded_Wide_Wide_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - else - return SR.Data (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- For empty result reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Result is hole source string, reuse source shared string - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Tail; - - procedure Tail - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - procedure Common - (SR : Shared_Wide_Wide_String_Access; - DR : Shared_Wide_Wide_String_Access; - Count : Natural); - -- Common code of tail computation. SR/DR can point to the same object - - ------------ - -- Common -- - ------------ - - procedure Common - (SR : Shared_Wide_Wide_String_Access; - DR : Shared_Wide_Wide_String_Access; - Count : Natural) is - begin - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end Common; - - begin - -- Result is empty string, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Length of the result is the same with length of the source string, - -- reuse source shared string. - - elsif Count = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, Count) then - Common (SR, SR, Count); - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - Common (SR, DR, Count); - Source.Reference := DR; - Unreference (SR); - end if; - end Tail; - - ------------------------- - -- To_Wide_Wide_String -- - ------------------------- - - function To_Wide_Wide_String - (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is - begin - return Source.Reference.Data (1 .. Source.Reference.Last); - end To_Wide_Wide_String; - - ----------------------------------- - -- To_Unbounded_Wide_Wide_String -- - ----------------------------------- - - function To_Unbounded_Wide_Wide_String - (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - DR : Shared_Wide_Wide_String_Access; - - begin - if Source'Length = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - else - DR := Allocate (Source'Length); - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_Wide_Wide_String; - - function To_Unbounded_Wide_Wide_String - (Length : Natural) return Unbounded_Wide_Wide_String - is - DR : Shared_Wide_Wide_String_Access; - - begin - if Length = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - else - DR := Allocate (Length); - DR.Last := Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_Wide_Wide_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - end Translate; - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - - exception - when others => - Unreference (DR); - - raise; - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - exception - when others => - if DR /= null then - Unreference (DR); - end if; - - raise; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_Wide_Wide_String; - Side : Trim_End) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- reuse source shared string. - - if DL = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Side : Trim_End) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- nothing to do. - - if DL = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - function Trim - (Source : Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DL := High - Low + 1; - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Target : out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - TR : constant Shared_Wide_Wide_String_Access := Target.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_Wide_Wide_String'Access); - Target.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (TR); - - else - DL := High - Low + 1; - - -- Try to reuse existent shared string - - if Can_Be_Reused (TR, DL) then - TR.Data (1 .. DL) := SR.Data (Low .. High); - TR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Target.Reference := DR; - Unreference (TR); - end if; - end if; - end Unbounded_Slice; - - ----------------- - -- Unreference -- - ----------------- - - procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is - - procedure Free is - new Ada.Unchecked_Deallocation - (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access); - - Aux : Shared_Wide_Wide_String_Access := Item; - - begin - if System.Atomic_Counters.Decrement (Aux.Counter) then - - -- Reference counter of Empty_Shared_Wide_Wide_String must never - -- reach zero. - - pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access); - - Free (Aux); - end if; - end Unreference; - -end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stzunb-shared.ads b/gcc/ada/libgnat/a-stzunb-shared.ads deleted file mode 100644 index f1ad9231c0b..00000000000 --- a/gcc/ada/libgnat/a-stzunb-shared.ads +++ /dev/null @@ -1,513 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is supported on: --- - all Alpha platforms --- - all ia64 platforms --- - all PowerPC platforms --- - all SPARC V9 platforms --- - all x86 platforms --- - all x86_64 platforms - -with Ada.Strings.Wide_Wide_Maps; -private with Ada.Finalization; -private with System.Atomic_Counters; - -package Ada.Strings.Wide_Wide_Unbounded is - pragma Preelaborate; - - type Unbounded_Wide_Wide_String is private; - pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); - - Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; - - function Length (Source : Unbounded_Wide_Wide_String) return Natural; - - type Wide_Wide_String_Access is access all Wide_Wide_String; - - procedure Free (X : in out Wide_Wide_String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_Wide_Wide_String - (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function To_Unbounded_Wide_Wide_String - (Length : Natural) return Unbounded_Wide_Wide_String; - - function To_Wide_Wide_String - (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; - - procedure Set_Unbounded_Wide_Wide_String - (Target : out Unbounded_Wide_Wide_String; - Source : Wide_Wide_String); - pragma Ada_05 (Set_Unbounded_Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Unbounded_Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_Character); - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Wide_Wide_Character; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function Element - (Source : Unbounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character; - - procedure Replace_Element - (Source : in out Unbounded_Wide_Wide_String; - Index : Positive; - By : Wide_Wide_Character); - - function Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Wide_Wide_String; - - function Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_Wide_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Target : out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "<" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "<=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function ">" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function ">=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Count - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Unbounded_Wide_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Unbounded_Wide_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String); - - function Insert - (Source : Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Insert - (Source : in out Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String); - - function Overwrite - (Source : Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Overwrite - (Source : in out Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String); - - function Delete - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_Wide_String; - - procedure Delete - (Source : in out Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_Wide_Wide_String; - Side : Trim_End) return Unbounded_Wide_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Unbounded_Wide_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set); - - function Head - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String; - - procedure Head - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space); - - function Tail - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String; - - procedure Tail - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space); - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - type Shared_Wide_Wide_String (Max_Length : Natural) is limited record - Counter : System.Atomic_Counters.Atomic_Counter; - -- Reference counter - - Last : Natural := 0; - Data : Wide_Wide_String (1 .. Max_Length); - -- Last is the index of last significant element of the Data. All - -- elements with larger indexes are just extra room for expansion. - end record; - - type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String; - - procedure Reference (Item : not null Shared_Wide_Wide_String_Access); - -- Increment reference counter. - - procedure Unreference (Item : not null Shared_Wide_Wide_String_Access); - -- Decrement reference counter. Deallocate Item when reference counter is - -- zero. - - function Can_Be_Reused - (Item : Shared_Wide_Wide_String_Access; - Length : Natural) return Boolean; - -- Returns True if Shared_Wide_Wide_String can be reused. There are two - -- criteria when Shared_Wide_Wide_String can be reused: its reference - -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively) - -- and its size is sufficient to store string with specified length - -- effectively. - - function Allocate - (Max_Length : Natural) return Shared_Wide_Wide_String_Access; - -- Allocates new Shared_Wide_Wide_String with at least specified maximum - -- length. Actual maximum length of the allocated Shared_Wide_Wide_String - -- can be slightly greater. Returns reference to - -- Empty_Shared_Wide_Wide_String when requested length is zero. - - Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0); - - function To_Unbounded - (S : Wide_Wide_String) return Unbounded_Wide_Wide_String - renames To_Unbounded_Wide_Wide_String; - -- This renames are here only to be used in the pragma Stream_Convert. - - type Unbounded_Wide_Wide_String is new AF.Controlled with record - Reference : Shared_Wide_Wide_String_Access := - Empty_Shared_Wide_Wide_String'Access; - end record; - - -- The Unbounded_Wide_Wide_String uses several techniques to increase speed - -- of the application: - - -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String - -- contains only the reference to the data which is shared between - -- several instances. The shared data is reallocated only when its value - -- is changed and the object mutation can't be used or it is inefficient - -- to use it; - - -- - object mutation. Shared data object can be reused without memory - -- reallocation when all of the following requirements are meat: - -- - shared data object don't used anywhere longer; - -- - its size is sufficient to store new value; - -- - the gap after reuse is less than some threshold. - - -- - memory preallocation. Most of used memory allocation algorithms - -- aligns allocated segment on the some boundary, thus some amount of - -- additional memory can be preallocated without any impact. Such - -- preallocated memory can used later by Append/Insert operations - -- without reallocation. - - -- Reference counting uses GCC builtin atomic operations, which allows safe - -- sharing of internal data between Ada tasks. Nevertheless, this does not - -- make objects of Unbounded_String thread-safe: an instance cannot be - -- accessed by several tasks simultaneously. - - pragma Stream_Convert - (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String); - -- Provide stream routines without dragging in Ada.Streams - - pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); - -- Finalization is required only for freeing storage - - overriding procedure Initialize - (Object : in out Unbounded_Wide_Wide_String); - overriding procedure Adjust - (Object : in out Unbounded_Wide_Wide_String); - overriding procedure Finalize - (Object : in out Unbounded_Wide_Wide_String); - - Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := - (AF.Controlled with - Reference => - Empty_Shared_Wide_Wide_String' - Access); - -end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stzunb__shared.adb b/gcc/ada/libgnat/a-stzunb__shared.adb new file mode 100644 index 00000000000..e8b23729868 --- /dev/null +++ b/gcc/ada/libgnat/a-stzunb__shared.adb @@ -0,0 +1,2137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Unbounded is + + use Ada.Strings.Wide_Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left string is empty, return Rigth string + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Right is an empty string, return Left string + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left is empty string, return Right string + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if Left = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Coefficient is one, just return string itself + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal + end "="; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_Wide_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + return Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean is + begin + return + System.Atomic_Counters.Is_One (Item.Counter) + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is + SR : constant Shared_Wide_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + Wide_Wide_Search.Find_Token + (SR.Data (From .. SR.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + Wide_Wide_Search.Find_Token + (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation + (Wide_Wide_String, Wide_Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String) + is + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + ------------------------- + -- To_Wide_Wide_String -- + ------------------------- + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_Wide_String; + + ----------------------------------- + -- To_Unbounded_Wide_Wide_String -- + ----------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + if Source'Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + if Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access); + + Aux : Shared_Wide_Wide_String_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + + -- Reference counter of Empty_Shared_Wide_Wide_String must never + -- reach zero. + + pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stzunb__shared.ads b/gcc/ada/libgnat/a-stzunb__shared.ads new file mode 100644 index 00000000000..f1ad9231c0b --- /dev/null +++ b/gcc/ada/libgnat/a-stzunb__shared.ads @@ -0,0 +1,513 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Wide_Maps; +private with Ada.Finalization; +private with System.Atomic_Counters; + +package Ada.Strings.Wide_Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; + + function Length (Source : Unbounded_Wide_Wide_String) return Natural; + + type Wide_Wide_String_Access is access all Wide_Wide_String; + + procedure Free (X : in out Wide_Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String; + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character); + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character); + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String); + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String); + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String); + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_Wide_String (Max_Length : Natural) is limited record + Counter : System.Atomic_Counters.Atomic_Counter; + -- Reference counter + + Last : Natural := 0; + Data : Wide_Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indexes are just extra room for expansion. + end record; + + type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String; + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when reference counter is + -- zero. + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_Wide_String can be reused. There are two + -- criteria when Shared_Wide_Wide_String can be reused: its reference + -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively) + -- and its size is sufficient to store string with specified length + -- effectively. + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access; + -- Allocates new Shared_Wide_Wide_String with at least specified maximum + -- length. Actual maximum length of the allocated Shared_Wide_Wide_String + -- can be slightly greater. Returns reference to + -- Empty_Shared_Wide_Wide_String when requested length is zero. + + Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0); + + function To_Unbounded + (S : Wide_Wide_String) return Unbounded_Wide_Wide_String + renames To_Unbounded_Wide_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert. + + type Unbounded_Wide_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_Wide_String_Access := + Empty_Shared_Wide_Wide_String'Access; + end record; + + -- The Unbounded_Wide_Wide_String uses several techniques to increase speed + -- of the application: + + -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String + -- contains only the reference to the data which is shared between + -- several instances. The shared data is reallocated only when its value + -- is changed and the object mutation can't be used or it is inefficient + -- to use it; + + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less than some threshold. + + -- - memory preallocation. Most of used memory allocation algorithms + -- aligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be + -- accessed by several tasks simultaneously. + + pragma Stream_Convert + (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Adjust + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Finalize + (Object : in out Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := + (AF.Controlled with + Reference => + Empty_Shared_Wide_Wide_String' + Access); + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-suteio-shared.adb b/gcc/ada/libgnat/a-suteio-shared.adb deleted file mode 100644 index 13d537d3874..00000000000 --- a/gcc/ada/libgnat/a-suteio-shared.adb +++ /dev/null @@ -1,132 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; use Ada.Text_IO; - -package body Ada.Strings.Unbounded.Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_String is - Buffer : String (1 .. 1000); - Last : Natural; - Result : Unbounded_String; - - begin - Get_Line (Buffer, Last); - Set_Unbounded_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is - Buffer : String (1 .. 1000); - Last : Natural; - Result : Unbounded_String; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Text_IO.File_Type; - Item : out Unbounded_String) - is - Buffer : String (1 .. 1000); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_String (Item, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Item, Buffer (1 .. Last)); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_String) is - UR : constant Shared_String_Access := U.Reference; - - begin - Put (UR.Data (1 .. UR.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_String) is - UR : constant Shared_String_Access := U.Reference; - - begin - Put (File, UR.Data (1 .. UR.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_String) is - UR : constant Shared_String_Access := U.Reference; - - begin - Put_Line (UR.Data (1 .. UR.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_String) is - UR : constant Shared_String_Access := U.Reference; - - begin - Put_Line (File, UR.Data (1 .. UR.Last)); - end Put_Line; - -end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/libgnat/a-suteio__shared.adb b/gcc/ada/libgnat/a-suteio__shared.adb new file mode 100644 index 00000000000..13d537d3874 --- /dev/null +++ b/gcc/ada/libgnat/a-suteio__shared.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; use Ada.Text_IO; + +package body Ada.Strings.Unbounded.Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Result : Unbounded_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Result : Unbounded_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Text_IO.File_Type; + Item : out Unbounded_String) + is + Buffer : String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/libgnat/a-swunau-shared.adb b/gcc/ada/libgnat/a-swunau-shared.adb deleted file mode 100644 index c65f7d01e44..00000000000 --- a/gcc/ada/libgnat/a-swunau-shared.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Wide_Unbounded.Aux is - - --------------------- - -- Get_Wide_String -- - --------------------- - - procedure Get_Wide_String - (U : Unbounded_Wide_String; - S : out Big_Wide_String_Access; - L : out Natural) - is - X : aliased Big_Wide_String; - for X'Address use U.Reference.Data'Address; - begin - S := X'Unchecked_Access; - L := U.Reference.Last; - end Get_Wide_String; - - --------------------- - -- Set_Wide_String -- - --------------------- - - procedure Set_Wide_String - (UP : in out Unbounded_Wide_String; - S : Wide_String_Access) - is - X : Wide_String_Access := S; - - begin - Set_Unbounded_Wide_String (UP, S.all); - Free (X); - end Set_Wide_String; - -end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-swunau__shared.adb b/gcc/ada/libgnat/a-swunau__shared.adb new file mode 100644 index 00000000000..c65f7d01e44 --- /dev/null +++ b/gcc/ada/libgnat/a-swunau__shared.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Unbounded.Aux is + + --------------------- + -- Get_Wide_String -- + --------------------- + + procedure Get_Wide_String + (U : Unbounded_Wide_String; + S : out Big_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_String; + + --------------------- + -- Set_Wide_String -- + --------------------- + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access) + is + X : Wide_String_Access := S; + + begin + Set_Unbounded_Wide_String (UP, S.all); + Free (X); + end Set_Wide_String; + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-swuwti-shared.adb b/gcc/ada/libgnat/a-swuwti-shared.adb deleted file mode 100644 index 1b1c127c67a..00000000000 --- a/gcc/ada/libgnat/a-swuwti-shared.adb +++ /dev/null @@ -1,134 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; - -package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_Wide_String is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - Result : Unbounded_Wide_String; - - begin - Get_Line (Buffer, Last); - Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - function Get_Line - (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String - is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - Result : Unbounded_Wide_String; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_Wide_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Wide_Text_IO.File_Type; - Item : out Unbounded_Wide_String) - is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_Wide_String (Item, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Item, Buffer (1 .. Last)); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_Wide_String) is - UR : constant Shared_Wide_String_Access := U.Reference; - - begin - Put (UR.Data (1 .. UR.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_Wide_String) is - UR : constant Shared_Wide_String_Access := U.Reference; - - begin - Put (File, UR.Data (1 .. UR.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_Wide_String) is - UR : constant Shared_Wide_String_Access := U.Reference; - - begin - Put_Line (UR.Data (1 .. UR.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is - UR : constant Shared_Wide_String_Access := U.Reference; - - begin - Put_Line (File, UR.Data (1 .. UR.Last)); - end Put_Line; - -end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-swuwti__shared.adb b/gcc/ada/libgnat/a-swuwti__shared.adb new file mode 100644 index 00000000000..1b1c127c67a --- /dev/null +++ b/gcc/ada/libgnat/a-swuwti__shared.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; + +package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_String is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-szunau-shared.adb b/gcc/ada/libgnat/a-szunau-shared.adb deleted file mode 100644 index 51737e04f23..00000000000 --- a/gcc/ada/libgnat/a-szunau-shared.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Wide_Wide_Unbounded.Aux is - - -------------------------- - -- Get_Wide_Wide_String -- - -------------------------- - - procedure Get_Wide_Wide_String - (U : Unbounded_Wide_Wide_String; - S : out Big_Wide_Wide_String_Access; - L : out Natural) - is - X : aliased Big_Wide_Wide_String; - for X'Address use U.Reference.Data'Address; - begin - S := X'Unchecked_Access; - L := U.Reference.Last; - end Get_Wide_Wide_String; - - -------------------------- - -- Set_Wide_Wide_String -- - -------------------------- - - procedure Set_Wide_Wide_String - (UP : in out Unbounded_Wide_Wide_String; - S : Wide_Wide_String_Access) - is - X : Wide_Wide_String_Access := S; - - begin - Set_Unbounded_Wide_Wide_String (UP, S.all); - Free (X); - end Set_Wide_Wide_String; - -end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-szunau__shared.adb b/gcc/ada/libgnat/a-szunau__shared.adb new file mode 100644 index 00000000000..51737e04f23 --- /dev/null +++ b/gcc/ada/libgnat/a-szunau__shared.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Wide_Unbounded.Aux is + + -------------------------- + -- Get_Wide_Wide_String -- + -------------------------- + + procedure Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String; + S : out Big_Wide_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_Wide_String; + + -------------------------- + -- Set_Wide_Wide_String -- + -------------------------- + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access) + is + X : Wide_Wide_String_Access := S; + + begin + Set_Unbounded_Wide_Wide_String (UP, S.all); + Free (X); + end Set_Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-szuzti-shared.adb b/gcc/ada/libgnat/a-szuzti-shared.adb deleted file mode 100644 index d8807aff83f..00000000000 --- a/gcc/ada/libgnat/a-szuzti-shared.adb +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; - -package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_Wide_Wide_String is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - Result : Unbounded_Wide_Wide_String; - - begin - Get_Line (Buffer, Last); - Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - function Get_Line - (File : Ada.Wide_Wide_Text_IO.File_Type) - return Unbounded_Wide_Wide_String - is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - Result : Unbounded_Wide_Wide_String; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Wide_Wide_Text_IO.File_Type; - Item : out Unbounded_Wide_Wide_String) - is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Item, Buffer (1 .. Last)); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_Wide_Wide_String) is - UR : constant Shared_Wide_Wide_String_Access := U.Reference; - - begin - Put (UR.Data (1 .. UR.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is - UR : constant Shared_Wide_Wide_String_Access := U.Reference; - - begin - Put (File, UR.Data (1 .. UR.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_Wide_Wide_String) is - UR : constant Shared_Wide_Wide_String_Access := U.Reference; - - begin - Put_Line (UR.Data (1 .. UR.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is - UR : constant Shared_Wide_Wide_String_Access := U.Reference; - - begin - Put_Line (File, UR.Data (1 .. UR.Last)); - end Put_Line; - -end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-szuzti__shared.adb b/gcc/ada/libgnat/a-szuzti__shared.adb new file mode 100644 index 00000000000..d8807aff83f --- /dev/null +++ b/gcc/ada/libgnat/a-szuzti__shared.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; + +package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) + return Unbounded_Wide_Wide_String + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/libgnat/g-alleve-hard.adb b/gcc/ada/libgnat/g-alleve-hard.adb deleted file mode 100644 index 4819211d320..00000000000 --- a/gcc/ada/libgnat/g-alleve-hard.adb +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- --- -- --- B o d y -- --- (Hard Binding Version) -- --- -- --- Copyright (C) 2004-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Altivec.Low_Level_Vectors is - -end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/libgnat/g-alleve-hard.ads b/gcc/ada/libgnat/g-alleve-hard.ads deleted file mode 100644 index 63a0a67be6a..00000000000 --- a/gcc/ada/libgnat/g-alleve-hard.ads +++ /dev/null @@ -1,593 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- --- -- --- S p e c -- --- (Hard Binding Version) -- --- -- --- Copyright (C) 2004-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit exposes the low level vector support for the Hard binding, --- intended for AltiVec capable targets. See Altivec.Design for a description --- of what is expected to be exposed. - -package GNAT.Altivec.Low_Level_Vectors is - pragma Elaborate_Body; - - ---------------------------------------- - -- Low-level Vector Type Declarations -- - ---------------------------------------- - - type LL_VUC is private; - type LL_VSC is private; - type LL_VBC is private; - - type LL_VUS is private; - type LL_VSS is private; - type LL_VBS is private; - - type LL_VUI is private; - type LL_VSI is private; - type LL_VBI is private; - - type LL_VF is private; - type LL_VP is private; - - ------------------------------------ - -- Low-level Functional Interface -- - ------------------------------------ - - function abs_v16qi (A : LL_VSC) return LL_VSC; - function abs_v8hi (A : LL_VSS) return LL_VSS; - function abs_v4si (A : LL_VSI) return LL_VSI; - function abs_v4sf (A : LL_VF) return LL_VF; - - function abss_v16qi (A : LL_VSC) return LL_VSC; - function abss_v8hi (A : LL_VSS) return LL_VSS; - function abss_v4si (A : LL_VSI) return LL_VSI; - - function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vaddfp (A : LL_VF; B : LL_VF) return LL_VF; - - function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vand (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI; - - function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VF; - - function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VF; - - function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VF; - - function vcfux (A : LL_VUI; B : c_int) return LL_VF; - function vcfsx (A : LL_VSI; B : c_int) return LL_VF; - - function vctsxs (A : LL_VF; B : c_int) return LL_VSI; - function vctuxs (A : LL_VF; B : c_int) return LL_VUI; - - procedure dss (A : c_int); - procedure dssall; - - procedure dst (A : c_ptr; B : c_int; C : c_int); - procedure dstst (A : c_ptr; B : c_int; C : c_int); - procedure dststt (A : c_ptr; B : c_int; C : c_int); - procedure dstt (A : c_ptr; B : c_int; C : c_int); - - function vexptefp (A : LL_VF) return LL_VF; - - function vrfim (A : LL_VF) return LL_VF; - - function lvx (A : c_long; B : c_ptr) return LL_VSI; - function lvebx (A : c_long; B : c_ptr) return LL_VSC; - function lvehx (A : c_long; B : c_ptr) return LL_VSS; - function lvewx (A : c_long; B : c_ptr) return LL_VSI; - function lvxl (A : c_long; B : c_ptr) return LL_VSI; - - function vlogefp (A : LL_VF) return LL_VF; - - function lvsl (A : c_long; B : c_ptr) return LL_VSC; - function lvsr (A : c_long; B : c_ptr) return LL_VSC; - - function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; - - function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; - - function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF; - - function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function mfvscr return LL_VSS; - - function vminfp (A : LL_VF; B : LL_VF) return LL_VF; - function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; - - function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; - - function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; - function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; - function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; - function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; - function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; - function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; - - procedure mtvscr (A : LL_VSI); - - function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS; - function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI; - function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS; - function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI; - - function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS; - function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI; - function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS; - function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI; - - function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; - - function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vor (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC; - function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS; - function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS; - function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC; - function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS; - function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC; - function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS; - function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC; - function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS; - - function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI; - - function vrefp (A : LL_VF) return LL_VF; - - function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vrfin (A : LL_VF) return LL_VF; - function vrfip (A : LL_VF) return LL_VF; - function vrfiz (A : LL_VF) return LL_VF; - - function vrsqrtefp (A : LL_VF) return LL_VF; - - function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI; - - function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI; - function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS; - function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC; - function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF; - - function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vspltb (A : LL_VSC; B : c_int) return LL_VSC; - function vsplth (A : LL_VSS; B : c_int) return LL_VSS; - function vspltw (A : LL_VSI; B : c_int) return LL_VSI; - - function vspltisb (A : c_int) return LL_VSC; - function vspltish (A : c_int) return LL_VSS; - function vspltisw (A : c_int) return LL_VSI; - - function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI; - - procedure stvx (A : LL_VSI; B : c_int; C : c_ptr); - procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr); - procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr); - procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr); - procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr); - - function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vsubfp (A : LL_VF; B : LL_VF) return LL_VF; - - function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI; - function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI; - function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI; - - function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vupkhsb (A : LL_VSC) return LL_VSS; - function vupkhsh (A : LL_VSS) return LL_VSI; - function vupkhpx (A : LL_VSS) return LL_VSI; - - function vupklsb (A : LL_VSC) return LL_VSS; - function vupklsh (A : LL_VSS) return LL_VSI; - function vupklpx (A : LL_VSS) return LL_VSI; - - function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; - function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; - function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; - function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; - - function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; - function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; - function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; - function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; - function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; - function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; - function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; - - function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; - function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; - -private - - --------------------------------------- - -- Low-level Vector Type Definitions -- - --------------------------------------- - - -- [PIM-2.3.3 Alignment of aggregate and unions containing vector types]: - - -- "Aggregates (structures and arrays) and unions containing vector - -- types must be aligned on 16-byte boundaries and their internal - -- organization padded, if necessary, so that each internal vector - -- type is aligned on a 16-byte boundary. This is an extension to - -- all ABIs (AIX, Apple, SVR4, and EABI). - - -------------------------- - -- char Core Components -- - -------------------------- - - type LL_VUC is array (1 .. 16) of unsigned_char; - for LL_VUC'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VUC, "vector_type"); - pragma Suppress (All_Checks, LL_VUC); - - type LL_VSC is array (1 .. 16) of signed_char; - for LL_VSC'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VSC, "vector_type"); - pragma Suppress (All_Checks, LL_VSC); - - type LL_VBC is array (1 .. 16) of unsigned_char; - for LL_VBC'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VBC, "vector_type"); - pragma Suppress (All_Checks, LL_VBC); - - --------------------------- - -- short Core Components -- - --------------------------- - - type LL_VUS is array (1 .. 8) of unsigned_short; - for LL_VUS'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VUS, "vector_type"); - pragma Suppress (All_Checks, LL_VUS); - - type LL_VSS is array (1 .. 8) of signed_short; - for LL_VSS'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VSS, "vector_type"); - pragma Suppress (All_Checks, LL_VSS); - - type LL_VBS is array (1 .. 8) of unsigned_short; - for LL_VBS'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VBS, "vector_type"); - pragma Suppress (All_Checks, LL_VBS); - - ------------------------- - -- int Core Components -- - ------------------------- - - type LL_VUI is array (1 .. 4) of unsigned_int; - for LL_VUI'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VUI, "vector_type"); - pragma Suppress (All_Checks, LL_VUI); - - type LL_VSI is array (1 .. 4) of signed_int; - for LL_VSI'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VSI, "vector_type"); - pragma Suppress (All_Checks, LL_VSI); - - type LL_VBI is array (1 .. 4) of unsigned_int; - for LL_VBI'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VBI, "vector_type"); - pragma Suppress (All_Checks, LL_VBI); - - --------------------------- - -- Float Core Components -- - --------------------------- - - type LL_VF is array (1 .. 4) of Float; - for LL_VF'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VF, "vector_type"); - pragma Suppress (All_Checks, LL_VF); - - --------------------------- - -- pixel Core Components -- - --------------------------- - - type LL_VP is array (1 .. 8) of pixel; - for LL_VP'Alignment use VECTOR_ALIGNMENT; - pragma Machine_Attribute (LL_VP, "vector_type"); - pragma Suppress (All_Checks, LL_VP); - - ------------------------------------ - -- Low-level Functional Interface -- - ------------------------------------ - - -- The functions we have to expose here are exactly those for which - -- GCC builtins are available. Calls to these functions will be turned - -- into real AltiVec instructions by the GCC back-end. - - pragma Convention_Identifier (LL_Altivec, Intrinsic); - - pragma Import (LL_Altivec, dss, "__builtin_altivec_dss"); - pragma Import (LL_Altivec, dssall, "__builtin_altivec_dssall"); - pragma Import (LL_Altivec, dst, "__builtin_altivec_dst"); - pragma Import (LL_Altivec, dstst, "__builtin_altivec_dstst"); - pragma Import (LL_Altivec, dststt, "__builtin_altivec_dststt"); - pragma Import (LL_Altivec, dstt, "__builtin_altivec_dstt"); - pragma Import (LL_Altivec, mtvscr, "__builtin_altivec_mtvscr"); - pragma Import (LL_Altivec, mfvscr, "__builtin_altivec_mfvscr"); - pragma Import (LL_Altivec, stvebx, "__builtin_altivec_stvebx"); - pragma Import (LL_Altivec, stvehx, "__builtin_altivec_stvehx"); - pragma Import (LL_Altivec, stvewx, "__builtin_altivec_stvewx"); - pragma Import (LL_Altivec, stvx, "__builtin_altivec_stvx"); - pragma Import (LL_Altivec, stvxl, "__builtin_altivec_stvxl"); - pragma Import (LL_Altivec, lvebx, "__builtin_altivec_lvebx"); - pragma Import (LL_Altivec, lvehx, "__builtin_altivec_lvehx"); - pragma Import (LL_Altivec, lvewx, "__builtin_altivec_lvewx"); - pragma Import (LL_Altivec, lvx, "__builtin_altivec_lvx"); - pragma Import (LL_Altivec, lvxl, "__builtin_altivec_lvxl"); - pragma Import (LL_Altivec, lvsl, "__builtin_altivec_lvsl"); - pragma Import (LL_Altivec, lvsr, "__builtin_altivec_lvsr"); - pragma Import (LL_Altivec, abs_v16qi, "__builtin_altivec_abs_v16qi"); - pragma Import (LL_Altivec, abs_v8hi, "__builtin_altivec_abs_v8hi"); - pragma Import (LL_Altivec, abs_v4si, "__builtin_altivec_abs_v4si"); - pragma Import (LL_Altivec, abs_v4sf, "__builtin_altivec_abs_v4sf"); - pragma Import (LL_Altivec, abss_v16qi, "__builtin_altivec_abss_v16qi"); - pragma Import (LL_Altivec, abss_v8hi, "__builtin_altivec_abss_v8hi"); - pragma Import (LL_Altivec, abss_v4si, "__builtin_altivec_abss_v4si"); - pragma Import (LL_Altivec, vaddcuw, "__builtin_altivec_vaddcuw"); - pragma Import (LL_Altivec, vaddfp, "__builtin_altivec_vaddfp"); - pragma Import (LL_Altivec, vaddsbs, "__builtin_altivec_vaddsbs"); - pragma Import (LL_Altivec, vaddshs, "__builtin_altivec_vaddshs"); - pragma Import (LL_Altivec, vaddsws, "__builtin_altivec_vaddsws"); - pragma Import (LL_Altivec, vaddubm, "__builtin_altivec_vaddubm"); - pragma Import (LL_Altivec, vaddubs, "__builtin_altivec_vaddubs"); - pragma Import (LL_Altivec, vadduhm, "__builtin_altivec_vadduhm"); - pragma Import (LL_Altivec, vadduhs, "__builtin_altivec_vadduhs"); - pragma Import (LL_Altivec, vadduwm, "__builtin_altivec_vadduwm"); - pragma Import (LL_Altivec, vadduws, "__builtin_altivec_vadduws"); - pragma Import (LL_Altivec, vand, "__builtin_altivec_vand"); - pragma Import (LL_Altivec, vandc, "__builtin_altivec_vandc"); - pragma Import (LL_Altivec, vavgsb, "__builtin_altivec_vavgsb"); - pragma Import (LL_Altivec, vavgsh, "__builtin_altivec_vavgsh"); - pragma Import (LL_Altivec, vavgsw, "__builtin_altivec_vavgsw"); - pragma Import (LL_Altivec, vavgub, "__builtin_altivec_vavgub"); - pragma Import (LL_Altivec, vavguh, "__builtin_altivec_vavguh"); - pragma Import (LL_Altivec, vavguw, "__builtin_altivec_vavguw"); - pragma Import (LL_Altivec, vcfsx, "__builtin_altivec_vcfsx"); - pragma Import (LL_Altivec, vcfux, "__builtin_altivec_vcfux"); - pragma Import (LL_Altivec, vcmpbfp, "__builtin_altivec_vcmpbfp"); - pragma Import (LL_Altivec, vcmpeqfp, "__builtin_altivec_vcmpeqfp"); - pragma Import (LL_Altivec, vcmpequb, "__builtin_altivec_vcmpequb"); - pragma Import (LL_Altivec, vcmpequh, "__builtin_altivec_vcmpequh"); - pragma Import (LL_Altivec, vcmpequw, "__builtin_altivec_vcmpequw"); - pragma Import (LL_Altivec, vcmpgefp, "__builtin_altivec_vcmpgefp"); - pragma Import (LL_Altivec, vcmpgtfp, "__builtin_altivec_vcmpgtfp"); - pragma Import (LL_Altivec, vcmpgtsb, "__builtin_altivec_vcmpgtsb"); - pragma Import (LL_Altivec, vcmpgtsh, "__builtin_altivec_vcmpgtsh"); - pragma Import (LL_Altivec, vcmpgtsw, "__builtin_altivec_vcmpgtsw"); - pragma Import (LL_Altivec, vcmpgtub, "__builtin_altivec_vcmpgtub"); - pragma Import (LL_Altivec, vcmpgtuh, "__builtin_altivec_vcmpgtuh"); - pragma Import (LL_Altivec, vcmpgtuw, "__builtin_altivec_vcmpgtuw"); - pragma Import (LL_Altivec, vctsxs, "__builtin_altivec_vctsxs"); - pragma Import (LL_Altivec, vctuxs, "__builtin_altivec_vctuxs"); - pragma Import (LL_Altivec, vexptefp, "__builtin_altivec_vexptefp"); - pragma Import (LL_Altivec, vlogefp, "__builtin_altivec_vlogefp"); - pragma Import (LL_Altivec, vmaddfp, "__builtin_altivec_vmaddfp"); - pragma Import (LL_Altivec, vmaxfp, "__builtin_altivec_vmaxfp"); - pragma Import (LL_Altivec, vmaxsb, "__builtin_altivec_vmaxsb"); - pragma Import (LL_Altivec, vmaxsh, "__builtin_altivec_vmaxsh"); - pragma Import (LL_Altivec, vmaxsw, "__builtin_altivec_vmaxsw"); - pragma Import (LL_Altivec, vmaxub, "__builtin_altivec_vmaxub"); - pragma Import (LL_Altivec, vmaxuh, "__builtin_altivec_vmaxuh"); - pragma Import (LL_Altivec, vmaxuw, "__builtin_altivec_vmaxuw"); - pragma Import (LL_Altivec, vmhaddshs, "__builtin_altivec_vmhaddshs"); - pragma Import (LL_Altivec, vmhraddshs, "__builtin_altivec_vmhraddshs"); - pragma Import (LL_Altivec, vminfp, "__builtin_altivec_vminfp"); - pragma Import (LL_Altivec, vminsb, "__builtin_altivec_vminsb"); - pragma Import (LL_Altivec, vminsh, "__builtin_altivec_vminsh"); - pragma Import (LL_Altivec, vminsw, "__builtin_altivec_vminsw"); - pragma Import (LL_Altivec, vminub, "__builtin_altivec_vminub"); - pragma Import (LL_Altivec, vminuh, "__builtin_altivec_vminuh"); - pragma Import (LL_Altivec, vminuw, "__builtin_altivec_vminuw"); - pragma Import (LL_Altivec, vmladduhm, "__builtin_altivec_vmladduhm"); - pragma Import (LL_Altivec, vmrghb, "__builtin_altivec_vmrghb"); - pragma Import (LL_Altivec, vmrghh, "__builtin_altivec_vmrghh"); - pragma Import (LL_Altivec, vmrghw, "__builtin_altivec_vmrghw"); - pragma Import (LL_Altivec, vmrglb, "__builtin_altivec_vmrglb"); - pragma Import (LL_Altivec, vmrglh, "__builtin_altivec_vmrglh"); - pragma Import (LL_Altivec, vmrglw, "__builtin_altivec_vmrglw"); - pragma Import (LL_Altivec, vmsummbm, "__builtin_altivec_vmsummbm"); - pragma Import (LL_Altivec, vmsumshm, "__builtin_altivec_vmsumshm"); - pragma Import (LL_Altivec, vmsumshs, "__builtin_altivec_vmsumshs"); - pragma Import (LL_Altivec, vmsumubm, "__builtin_altivec_vmsumubm"); - pragma Import (LL_Altivec, vmsumuhm, "__builtin_altivec_vmsumuhm"); - pragma Import (LL_Altivec, vmsumuhs, "__builtin_altivec_vmsumuhs"); - pragma Import (LL_Altivec, vmulesb, "__builtin_altivec_vmulesb"); - pragma Import (LL_Altivec, vmulesh, "__builtin_altivec_vmulesh"); - pragma Import (LL_Altivec, vmuleub, "__builtin_altivec_vmuleub"); - pragma Import (LL_Altivec, vmuleuh, "__builtin_altivec_vmuleuh"); - pragma Import (LL_Altivec, vmulosb, "__builtin_altivec_vmulosb"); - pragma Import (LL_Altivec, vmulosh, "__builtin_altivec_vmulosh"); - pragma Import (LL_Altivec, vmuloub, "__builtin_altivec_vmuloub"); - pragma Import (LL_Altivec, vmulouh, "__builtin_altivec_vmulouh"); - pragma Import (LL_Altivec, vnmsubfp, "__builtin_altivec_vnmsubfp"); - pragma Import (LL_Altivec, vnor, "__builtin_altivec_vnor"); - pragma Import (LL_Altivec, vxor, "__builtin_altivec_vxor"); - pragma Import (LL_Altivec, vor, "__builtin_altivec_vor"); - pragma Import (LL_Altivec, vperm_4si, "__builtin_altivec_vperm_4si"); - pragma Import (LL_Altivec, vpkpx, "__builtin_altivec_vpkpx"); - pragma Import (LL_Altivec, vpkshss, "__builtin_altivec_vpkshss"); - pragma Import (LL_Altivec, vpkshus, "__builtin_altivec_vpkshus"); - pragma Import (LL_Altivec, vpkswss, "__builtin_altivec_vpkswss"); - pragma Import (LL_Altivec, vpkswus, "__builtin_altivec_vpkswus"); - pragma Import (LL_Altivec, vpkuhum, "__builtin_altivec_vpkuhum"); - pragma Import (LL_Altivec, vpkuhus, "__builtin_altivec_vpkuhus"); - pragma Import (LL_Altivec, vpkuwum, "__builtin_altivec_vpkuwum"); - pragma Import (LL_Altivec, vpkuwus, "__builtin_altivec_vpkuwus"); - pragma Import (LL_Altivec, vrefp, "__builtin_altivec_vrefp"); - pragma Import (LL_Altivec, vrfim, "__builtin_altivec_vrfim"); - pragma Import (LL_Altivec, vrfin, "__builtin_altivec_vrfin"); - pragma Import (LL_Altivec, vrfip, "__builtin_altivec_vrfip"); - pragma Import (LL_Altivec, vrfiz, "__builtin_altivec_vrfiz"); - pragma Import (LL_Altivec, vrlb, "__builtin_altivec_vrlb"); - pragma Import (LL_Altivec, vrlh, "__builtin_altivec_vrlh"); - pragma Import (LL_Altivec, vrlw, "__builtin_altivec_vrlw"); - pragma Import (LL_Altivec, vrsqrtefp, "__builtin_altivec_vrsqrtefp"); - pragma Import (LL_Altivec, vsel_4si, "__builtin_altivec_vsel_4si"); - pragma Import (LL_Altivec, vsldoi_4si, "__builtin_altivec_vsldoi_4si"); - pragma Import (LL_Altivec, vsldoi_8hi, "__builtin_altivec_vsldoi_8hi"); - pragma Import (LL_Altivec, vsldoi_16qi, "__builtin_altivec_vsldoi_16qi"); - pragma Import (LL_Altivec, vsldoi_4sf, "__builtin_altivec_vsldoi_4sf"); - pragma Import (LL_Altivec, vsl, "__builtin_altivec_vsl"); - pragma Import (LL_Altivec, vslb, "__builtin_altivec_vslb"); - pragma Import (LL_Altivec, vslh, "__builtin_altivec_vslh"); - pragma Import (LL_Altivec, vslo, "__builtin_altivec_vslo"); - pragma Import (LL_Altivec, vslw, "__builtin_altivec_vslw"); - pragma Import (LL_Altivec, vspltb, "__builtin_altivec_vspltb"); - pragma Import (LL_Altivec, vsplth, "__builtin_altivec_vsplth"); - pragma Import (LL_Altivec, vspltisb, "__builtin_altivec_vspltisb"); - pragma Import (LL_Altivec, vspltish, "__builtin_altivec_vspltish"); - pragma Import (LL_Altivec, vspltisw, "__builtin_altivec_vspltisw"); - pragma Import (LL_Altivec, vspltw, "__builtin_altivec_vspltw"); - pragma Import (LL_Altivec, vsr, "__builtin_altivec_vsr"); - pragma Import (LL_Altivec, vsrab, "__builtin_altivec_vsrab"); - pragma Import (LL_Altivec, vsrah, "__builtin_altivec_vsrah"); - pragma Import (LL_Altivec, vsraw, "__builtin_altivec_vsraw"); - pragma Import (LL_Altivec, vsrb, "__builtin_altivec_vsrb"); - pragma Import (LL_Altivec, vsrh, "__builtin_altivec_vsrh"); - pragma Import (LL_Altivec, vsro, "__builtin_altivec_vsro"); - pragma Import (LL_Altivec, vsrw, "__builtin_altivec_vsrw"); - pragma Import (LL_Altivec, vsubcuw, "__builtin_altivec_vsubcuw"); - pragma Import (LL_Altivec, vsubfp, "__builtin_altivec_vsubfp"); - pragma Import (LL_Altivec, vsubsbs, "__builtin_altivec_vsubsbs"); - pragma Import (LL_Altivec, vsubshs, "__builtin_altivec_vsubshs"); - pragma Import (LL_Altivec, vsubsws, "__builtin_altivec_vsubsws"); - pragma Import (LL_Altivec, vsububm, "__builtin_altivec_vsububm"); - pragma Import (LL_Altivec, vsububs, "__builtin_altivec_vsububs"); - pragma Import (LL_Altivec, vsubuhm, "__builtin_altivec_vsubuhm"); - pragma Import (LL_Altivec, vsubuhs, "__builtin_altivec_vsubuhs"); - pragma Import (LL_Altivec, vsubuwm, "__builtin_altivec_vsubuwm"); - pragma Import (LL_Altivec, vsubuws, "__builtin_altivec_vsubuws"); - pragma Import (LL_Altivec, vsum2sws, "__builtin_altivec_vsum2sws"); - pragma Import (LL_Altivec, vsum4sbs, "__builtin_altivec_vsum4sbs"); - pragma Import (LL_Altivec, vsum4shs, "__builtin_altivec_vsum4shs"); - pragma Import (LL_Altivec, vsum4ubs, "__builtin_altivec_vsum4ubs"); - pragma Import (LL_Altivec, vsumsws, "__builtin_altivec_vsumsws"); - pragma Import (LL_Altivec, vupkhpx, "__builtin_altivec_vupkhpx"); - pragma Import (LL_Altivec, vupkhsb, "__builtin_altivec_vupkhsb"); - pragma Import (LL_Altivec, vupkhsh, "__builtin_altivec_vupkhsh"); - pragma Import (LL_Altivec, vupklpx, "__builtin_altivec_vupklpx"); - pragma Import (LL_Altivec, vupklsb, "__builtin_altivec_vupklsb"); - pragma Import (LL_Altivec, vupklsh, "__builtin_altivec_vupklsh"); - pragma Import (LL_Altivec, vcmpbfp_p, "__builtin_altivec_vcmpbfp_p"); - pragma Import (LL_Altivec, vcmpeqfp_p, "__builtin_altivec_vcmpeqfp_p"); - pragma Import (LL_Altivec, vcmpgefp_p, "__builtin_altivec_vcmpgefp_p"); - pragma Import (LL_Altivec, vcmpgtfp_p, "__builtin_altivec_vcmpgtfp_p"); - pragma Import (LL_Altivec, vcmpequw_p, "__builtin_altivec_vcmpequw_p"); - pragma Import (LL_Altivec, vcmpgtsw_p, "__builtin_altivec_vcmpgtsw_p"); - pragma Import (LL_Altivec, vcmpgtuw_p, "__builtin_altivec_vcmpgtuw_p"); - pragma Import (LL_Altivec, vcmpgtuh_p, "__builtin_altivec_vcmpgtuh_p"); - pragma Import (LL_Altivec, vcmpgtsh_p, "__builtin_altivec_vcmpgtsh_p"); - pragma Import (LL_Altivec, vcmpequh_p, "__builtin_altivec_vcmpequh_p"); - pragma Import (LL_Altivec, vcmpequb_p, "__builtin_altivec_vcmpequb_p"); - pragma Import (LL_Altivec, vcmpgtsb_p, "__builtin_altivec_vcmpgtsb_p"); - pragma Import (LL_Altivec, vcmpgtub_p, "__builtin_altivec_vcmpgtub_p"); - -end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/libgnat/g-alleve__hard.adb b/gcc/ada/libgnat/g-alleve__hard.adb new file mode 100644 index 00000000000..4819211d320 --- /dev/null +++ b/gcc/ada/libgnat/g-alleve__hard.adb @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- +-- -- +-- B o d y -- +-- (Hard Binding Version) -- +-- -- +-- Copyright (C) 2004-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Altivec.Low_Level_Vectors is + +end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/libgnat/g-alleve__hard.ads b/gcc/ada/libgnat/g-alleve__hard.ads new file mode 100644 index 00000000000..63a0a67be6a --- /dev/null +++ b/gcc/ada/libgnat/g-alleve__hard.ads @@ -0,0 +1,593 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- +-- -- +-- S p e c -- +-- (Hard Binding Version) -- +-- -- +-- Copyright (C) 2004-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit exposes the low level vector support for the Hard binding, +-- intended for AltiVec capable targets. See Altivec.Design for a description +-- of what is expected to be exposed. + +package GNAT.Altivec.Low_Level_Vectors is + pragma Elaborate_Body; + + ---------------------------------------- + -- Low-level Vector Type Declarations -- + ---------------------------------------- + + type LL_VUC is private; + type LL_VSC is private; + type LL_VBC is private; + + type LL_VUS is private; + type LL_VSS is private; + type LL_VBS is private; + + type LL_VUI is private; + type LL_VSI is private; + type LL_VBI is private; + + type LL_VF is private; + type LL_VP is private; + + ------------------------------------ + -- Low-level Functional Interface -- + ------------------------------------ + + function abs_v16qi (A : LL_VSC) return LL_VSC; + function abs_v8hi (A : LL_VSS) return LL_VSS; + function abs_v4si (A : LL_VSI) return LL_VSI; + function abs_v4sf (A : LL_VF) return LL_VF; + + function abss_v16qi (A : LL_VSC) return LL_VSC; + function abss_v8hi (A : LL_VSS) return LL_VSS; + function abss_v4si (A : LL_VSI) return LL_VSI; + + function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vaddfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vand (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI; + + function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VF; + + function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vcfux (A : LL_VUI; B : c_int) return LL_VF; + function vcfsx (A : LL_VSI; B : c_int) return LL_VF; + + function vctsxs (A : LL_VF; B : c_int) return LL_VSI; + function vctuxs (A : LL_VF; B : c_int) return LL_VUI; + + procedure dss (A : c_int); + procedure dssall; + + procedure dst (A : c_ptr; B : c_int; C : c_int); + procedure dstst (A : c_ptr; B : c_int; C : c_int); + procedure dststt (A : c_ptr; B : c_int; C : c_int); + procedure dstt (A : c_ptr; B : c_int; C : c_int); + + function vexptefp (A : LL_VF) return LL_VF; + + function vrfim (A : LL_VF) return LL_VF; + + function lvx (A : c_long; B : c_ptr) return LL_VSI; + function lvebx (A : c_long; B : c_ptr) return LL_VSC; + function lvehx (A : c_long; B : c_ptr) return LL_VSS; + function lvewx (A : c_long; B : c_ptr) return LL_VSI; + function lvxl (A : c_long; B : c_ptr) return LL_VSI; + + function vlogefp (A : LL_VF) return LL_VF; + + function lvsl (A : c_long; B : c_ptr) return LL_VSC; + function lvsr (A : c_long; B : c_ptr) return LL_VSC; + + function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; + + function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function mfvscr return LL_VSS; + + function vminfp (A : LL_VF; B : LL_VF) return LL_VF; + function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; + function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; + function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + + procedure mtvscr (A : LL_VSI); + + function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI; + function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI; + + function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI; + function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI; + + function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; + + function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vor (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS; + + function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI; + + function vrefp (A : LL_VF) return LL_VF; + + function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vrfin (A : LL_VF) return LL_VF; + function vrfip (A : LL_VF) return LL_VF; + function vrfiz (A : LL_VF) return LL_VF; + + function vrsqrtefp (A : LL_VF) return LL_VF; + + function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI; + + function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI; + function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS; + function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC; + function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF; + + function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vspltb (A : LL_VSC; B : c_int) return LL_VSC; + function vsplth (A : LL_VSS; B : c_int) return LL_VSS; + function vspltw (A : LL_VSI; B : c_int) return LL_VSI; + + function vspltisb (A : c_int) return LL_VSC; + function vspltish (A : c_int) return LL_VSS; + function vspltisw (A : c_int) return LL_VSI; + + function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI; + + procedure stvx (A : LL_VSI; B : c_int; C : c_ptr); + procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr); + procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr); + procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr); + procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr); + + function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsubfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI; + function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI; + function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI; + + function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vupkhsb (A : LL_VSC) return LL_VSS; + function vupkhsh (A : LL_VSS) return LL_VSI; + function vupkhpx (A : LL_VSS) return LL_VSI; + + function vupklsb (A : LL_VSC) return LL_VSS; + function vupklsh (A : LL_VSS) return LL_VSI; + function vupklpx (A : LL_VSS) return LL_VSI; + + function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + + function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + + function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + +private + + --------------------------------------- + -- Low-level Vector Type Definitions -- + --------------------------------------- + + -- [PIM-2.3.3 Alignment of aggregate and unions containing vector types]: + + -- "Aggregates (structures and arrays) and unions containing vector + -- types must be aligned on 16-byte boundaries and their internal + -- organization padded, if necessary, so that each internal vector + -- type is aligned on a 16-byte boundary. This is an extension to + -- all ABIs (AIX, Apple, SVR4, and EABI). + + -------------------------- + -- char Core Components -- + -------------------------- + + type LL_VUC is array (1 .. 16) of unsigned_char; + for LL_VUC'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VUC, "vector_type"); + pragma Suppress (All_Checks, LL_VUC); + + type LL_VSC is array (1 .. 16) of signed_char; + for LL_VSC'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VSC, "vector_type"); + pragma Suppress (All_Checks, LL_VSC); + + type LL_VBC is array (1 .. 16) of unsigned_char; + for LL_VBC'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VBC, "vector_type"); + pragma Suppress (All_Checks, LL_VBC); + + --------------------------- + -- short Core Components -- + --------------------------- + + type LL_VUS is array (1 .. 8) of unsigned_short; + for LL_VUS'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VUS, "vector_type"); + pragma Suppress (All_Checks, LL_VUS); + + type LL_VSS is array (1 .. 8) of signed_short; + for LL_VSS'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VSS, "vector_type"); + pragma Suppress (All_Checks, LL_VSS); + + type LL_VBS is array (1 .. 8) of unsigned_short; + for LL_VBS'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VBS, "vector_type"); + pragma Suppress (All_Checks, LL_VBS); + + ------------------------- + -- int Core Components -- + ------------------------- + + type LL_VUI is array (1 .. 4) of unsigned_int; + for LL_VUI'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VUI, "vector_type"); + pragma Suppress (All_Checks, LL_VUI); + + type LL_VSI is array (1 .. 4) of signed_int; + for LL_VSI'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VSI, "vector_type"); + pragma Suppress (All_Checks, LL_VSI); + + type LL_VBI is array (1 .. 4) of unsigned_int; + for LL_VBI'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VBI, "vector_type"); + pragma Suppress (All_Checks, LL_VBI); + + --------------------------- + -- Float Core Components -- + --------------------------- + + type LL_VF is array (1 .. 4) of Float; + for LL_VF'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VF, "vector_type"); + pragma Suppress (All_Checks, LL_VF); + + --------------------------- + -- pixel Core Components -- + --------------------------- + + type LL_VP is array (1 .. 8) of pixel; + for LL_VP'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VP, "vector_type"); + pragma Suppress (All_Checks, LL_VP); + + ------------------------------------ + -- Low-level Functional Interface -- + ------------------------------------ + + -- The functions we have to expose here are exactly those for which + -- GCC builtins are available. Calls to these functions will be turned + -- into real AltiVec instructions by the GCC back-end. + + pragma Convention_Identifier (LL_Altivec, Intrinsic); + + pragma Import (LL_Altivec, dss, "__builtin_altivec_dss"); + pragma Import (LL_Altivec, dssall, "__builtin_altivec_dssall"); + pragma Import (LL_Altivec, dst, "__builtin_altivec_dst"); + pragma Import (LL_Altivec, dstst, "__builtin_altivec_dstst"); + pragma Import (LL_Altivec, dststt, "__builtin_altivec_dststt"); + pragma Import (LL_Altivec, dstt, "__builtin_altivec_dstt"); + pragma Import (LL_Altivec, mtvscr, "__builtin_altivec_mtvscr"); + pragma Import (LL_Altivec, mfvscr, "__builtin_altivec_mfvscr"); + pragma Import (LL_Altivec, stvebx, "__builtin_altivec_stvebx"); + pragma Import (LL_Altivec, stvehx, "__builtin_altivec_stvehx"); + pragma Import (LL_Altivec, stvewx, "__builtin_altivec_stvewx"); + pragma Import (LL_Altivec, stvx, "__builtin_altivec_stvx"); + pragma Import (LL_Altivec, stvxl, "__builtin_altivec_stvxl"); + pragma Import (LL_Altivec, lvebx, "__builtin_altivec_lvebx"); + pragma Import (LL_Altivec, lvehx, "__builtin_altivec_lvehx"); + pragma Import (LL_Altivec, lvewx, "__builtin_altivec_lvewx"); + pragma Import (LL_Altivec, lvx, "__builtin_altivec_lvx"); + pragma Import (LL_Altivec, lvxl, "__builtin_altivec_lvxl"); + pragma Import (LL_Altivec, lvsl, "__builtin_altivec_lvsl"); + pragma Import (LL_Altivec, lvsr, "__builtin_altivec_lvsr"); + pragma Import (LL_Altivec, abs_v16qi, "__builtin_altivec_abs_v16qi"); + pragma Import (LL_Altivec, abs_v8hi, "__builtin_altivec_abs_v8hi"); + pragma Import (LL_Altivec, abs_v4si, "__builtin_altivec_abs_v4si"); + pragma Import (LL_Altivec, abs_v4sf, "__builtin_altivec_abs_v4sf"); + pragma Import (LL_Altivec, abss_v16qi, "__builtin_altivec_abss_v16qi"); + pragma Import (LL_Altivec, abss_v8hi, "__builtin_altivec_abss_v8hi"); + pragma Import (LL_Altivec, abss_v4si, "__builtin_altivec_abss_v4si"); + pragma Import (LL_Altivec, vaddcuw, "__builtin_altivec_vaddcuw"); + pragma Import (LL_Altivec, vaddfp, "__builtin_altivec_vaddfp"); + pragma Import (LL_Altivec, vaddsbs, "__builtin_altivec_vaddsbs"); + pragma Import (LL_Altivec, vaddshs, "__builtin_altivec_vaddshs"); + pragma Import (LL_Altivec, vaddsws, "__builtin_altivec_vaddsws"); + pragma Import (LL_Altivec, vaddubm, "__builtin_altivec_vaddubm"); + pragma Import (LL_Altivec, vaddubs, "__builtin_altivec_vaddubs"); + pragma Import (LL_Altivec, vadduhm, "__builtin_altivec_vadduhm"); + pragma Import (LL_Altivec, vadduhs, "__builtin_altivec_vadduhs"); + pragma Import (LL_Altivec, vadduwm, "__builtin_altivec_vadduwm"); + pragma Import (LL_Altivec, vadduws, "__builtin_altivec_vadduws"); + pragma Import (LL_Altivec, vand, "__builtin_altivec_vand"); + pragma Import (LL_Altivec, vandc, "__builtin_altivec_vandc"); + pragma Import (LL_Altivec, vavgsb, "__builtin_altivec_vavgsb"); + pragma Import (LL_Altivec, vavgsh, "__builtin_altivec_vavgsh"); + pragma Import (LL_Altivec, vavgsw, "__builtin_altivec_vavgsw"); + pragma Import (LL_Altivec, vavgub, "__builtin_altivec_vavgub"); + pragma Import (LL_Altivec, vavguh, "__builtin_altivec_vavguh"); + pragma Import (LL_Altivec, vavguw, "__builtin_altivec_vavguw"); + pragma Import (LL_Altivec, vcfsx, "__builtin_altivec_vcfsx"); + pragma Import (LL_Altivec, vcfux, "__builtin_altivec_vcfux"); + pragma Import (LL_Altivec, vcmpbfp, "__builtin_altivec_vcmpbfp"); + pragma Import (LL_Altivec, vcmpeqfp, "__builtin_altivec_vcmpeqfp"); + pragma Import (LL_Altivec, vcmpequb, "__builtin_altivec_vcmpequb"); + pragma Import (LL_Altivec, vcmpequh, "__builtin_altivec_vcmpequh"); + pragma Import (LL_Altivec, vcmpequw, "__builtin_altivec_vcmpequw"); + pragma Import (LL_Altivec, vcmpgefp, "__builtin_altivec_vcmpgefp"); + pragma Import (LL_Altivec, vcmpgtfp, "__builtin_altivec_vcmpgtfp"); + pragma Import (LL_Altivec, vcmpgtsb, "__builtin_altivec_vcmpgtsb"); + pragma Import (LL_Altivec, vcmpgtsh, "__builtin_altivec_vcmpgtsh"); + pragma Import (LL_Altivec, vcmpgtsw, "__builtin_altivec_vcmpgtsw"); + pragma Import (LL_Altivec, vcmpgtub, "__builtin_altivec_vcmpgtub"); + pragma Import (LL_Altivec, vcmpgtuh, "__builtin_altivec_vcmpgtuh"); + pragma Import (LL_Altivec, vcmpgtuw, "__builtin_altivec_vcmpgtuw"); + pragma Import (LL_Altivec, vctsxs, "__builtin_altivec_vctsxs"); + pragma Import (LL_Altivec, vctuxs, "__builtin_altivec_vctuxs"); + pragma Import (LL_Altivec, vexptefp, "__builtin_altivec_vexptefp"); + pragma Import (LL_Altivec, vlogefp, "__builtin_altivec_vlogefp"); + pragma Import (LL_Altivec, vmaddfp, "__builtin_altivec_vmaddfp"); + pragma Import (LL_Altivec, vmaxfp, "__builtin_altivec_vmaxfp"); + pragma Import (LL_Altivec, vmaxsb, "__builtin_altivec_vmaxsb"); + pragma Import (LL_Altivec, vmaxsh, "__builtin_altivec_vmaxsh"); + pragma Import (LL_Altivec, vmaxsw, "__builtin_altivec_vmaxsw"); + pragma Import (LL_Altivec, vmaxub, "__builtin_altivec_vmaxub"); + pragma Import (LL_Altivec, vmaxuh, "__builtin_altivec_vmaxuh"); + pragma Import (LL_Altivec, vmaxuw, "__builtin_altivec_vmaxuw"); + pragma Import (LL_Altivec, vmhaddshs, "__builtin_altivec_vmhaddshs"); + pragma Import (LL_Altivec, vmhraddshs, "__builtin_altivec_vmhraddshs"); + pragma Import (LL_Altivec, vminfp, "__builtin_altivec_vminfp"); + pragma Import (LL_Altivec, vminsb, "__builtin_altivec_vminsb"); + pragma Import (LL_Altivec, vminsh, "__builtin_altivec_vminsh"); + pragma Import (LL_Altivec, vminsw, "__builtin_altivec_vminsw"); + pragma Import (LL_Altivec, vminub, "__builtin_altivec_vminub"); + pragma Import (LL_Altivec, vminuh, "__builtin_altivec_vminuh"); + pragma Import (LL_Altivec, vminuw, "__builtin_altivec_vminuw"); + pragma Import (LL_Altivec, vmladduhm, "__builtin_altivec_vmladduhm"); + pragma Import (LL_Altivec, vmrghb, "__builtin_altivec_vmrghb"); + pragma Import (LL_Altivec, vmrghh, "__builtin_altivec_vmrghh"); + pragma Import (LL_Altivec, vmrghw, "__builtin_altivec_vmrghw"); + pragma Import (LL_Altivec, vmrglb, "__builtin_altivec_vmrglb"); + pragma Import (LL_Altivec, vmrglh, "__builtin_altivec_vmrglh"); + pragma Import (LL_Altivec, vmrglw, "__builtin_altivec_vmrglw"); + pragma Import (LL_Altivec, vmsummbm, "__builtin_altivec_vmsummbm"); + pragma Import (LL_Altivec, vmsumshm, "__builtin_altivec_vmsumshm"); + pragma Import (LL_Altivec, vmsumshs, "__builtin_altivec_vmsumshs"); + pragma Import (LL_Altivec, vmsumubm, "__builtin_altivec_vmsumubm"); + pragma Import (LL_Altivec, vmsumuhm, "__builtin_altivec_vmsumuhm"); + pragma Import (LL_Altivec, vmsumuhs, "__builtin_altivec_vmsumuhs"); + pragma Import (LL_Altivec, vmulesb, "__builtin_altivec_vmulesb"); + pragma Import (LL_Altivec, vmulesh, "__builtin_altivec_vmulesh"); + pragma Import (LL_Altivec, vmuleub, "__builtin_altivec_vmuleub"); + pragma Import (LL_Altivec, vmuleuh, "__builtin_altivec_vmuleuh"); + pragma Import (LL_Altivec, vmulosb, "__builtin_altivec_vmulosb"); + pragma Import (LL_Altivec, vmulosh, "__builtin_altivec_vmulosh"); + pragma Import (LL_Altivec, vmuloub, "__builtin_altivec_vmuloub"); + pragma Import (LL_Altivec, vmulouh, "__builtin_altivec_vmulouh"); + pragma Import (LL_Altivec, vnmsubfp, "__builtin_altivec_vnmsubfp"); + pragma Import (LL_Altivec, vnor, "__builtin_altivec_vnor"); + pragma Import (LL_Altivec, vxor, "__builtin_altivec_vxor"); + pragma Import (LL_Altivec, vor, "__builtin_altivec_vor"); + pragma Import (LL_Altivec, vperm_4si, "__builtin_altivec_vperm_4si"); + pragma Import (LL_Altivec, vpkpx, "__builtin_altivec_vpkpx"); + pragma Import (LL_Altivec, vpkshss, "__builtin_altivec_vpkshss"); + pragma Import (LL_Altivec, vpkshus, "__builtin_altivec_vpkshus"); + pragma Import (LL_Altivec, vpkswss, "__builtin_altivec_vpkswss"); + pragma Import (LL_Altivec, vpkswus, "__builtin_altivec_vpkswus"); + pragma Import (LL_Altivec, vpkuhum, "__builtin_altivec_vpkuhum"); + pragma Import (LL_Altivec, vpkuhus, "__builtin_altivec_vpkuhus"); + pragma Import (LL_Altivec, vpkuwum, "__builtin_altivec_vpkuwum"); + pragma Import (LL_Altivec, vpkuwus, "__builtin_altivec_vpkuwus"); + pragma Import (LL_Altivec, vrefp, "__builtin_altivec_vrefp"); + pragma Import (LL_Altivec, vrfim, "__builtin_altivec_vrfim"); + pragma Import (LL_Altivec, vrfin, "__builtin_altivec_vrfin"); + pragma Import (LL_Altivec, vrfip, "__builtin_altivec_vrfip"); + pragma Import (LL_Altivec, vrfiz, "__builtin_altivec_vrfiz"); + pragma Import (LL_Altivec, vrlb, "__builtin_altivec_vrlb"); + pragma Import (LL_Altivec, vrlh, "__builtin_altivec_vrlh"); + pragma Import (LL_Altivec, vrlw, "__builtin_altivec_vrlw"); + pragma Import (LL_Altivec, vrsqrtefp, "__builtin_altivec_vrsqrtefp"); + pragma Import (LL_Altivec, vsel_4si, "__builtin_altivec_vsel_4si"); + pragma Import (LL_Altivec, vsldoi_4si, "__builtin_altivec_vsldoi_4si"); + pragma Import (LL_Altivec, vsldoi_8hi, "__builtin_altivec_vsldoi_8hi"); + pragma Import (LL_Altivec, vsldoi_16qi, "__builtin_altivec_vsldoi_16qi"); + pragma Import (LL_Altivec, vsldoi_4sf, "__builtin_altivec_vsldoi_4sf"); + pragma Import (LL_Altivec, vsl, "__builtin_altivec_vsl"); + pragma Import (LL_Altivec, vslb, "__builtin_altivec_vslb"); + pragma Import (LL_Altivec, vslh, "__builtin_altivec_vslh"); + pragma Import (LL_Altivec, vslo, "__builtin_altivec_vslo"); + pragma Import (LL_Altivec, vslw, "__builtin_altivec_vslw"); + pragma Import (LL_Altivec, vspltb, "__builtin_altivec_vspltb"); + pragma Import (LL_Altivec, vsplth, "__builtin_altivec_vsplth"); + pragma Import (LL_Altivec, vspltisb, "__builtin_altivec_vspltisb"); + pragma Import (LL_Altivec, vspltish, "__builtin_altivec_vspltish"); + pragma Import (LL_Altivec, vspltisw, "__builtin_altivec_vspltisw"); + pragma Import (LL_Altivec, vspltw, "__builtin_altivec_vspltw"); + pragma Import (LL_Altivec, vsr, "__builtin_altivec_vsr"); + pragma Import (LL_Altivec, vsrab, "__builtin_altivec_vsrab"); + pragma Import (LL_Altivec, vsrah, "__builtin_altivec_vsrah"); + pragma Import (LL_Altivec, vsraw, "__builtin_altivec_vsraw"); + pragma Import (LL_Altivec, vsrb, "__builtin_altivec_vsrb"); + pragma Import (LL_Altivec, vsrh, "__builtin_altivec_vsrh"); + pragma Import (LL_Altivec, vsro, "__builtin_altivec_vsro"); + pragma Import (LL_Altivec, vsrw, "__builtin_altivec_vsrw"); + pragma Import (LL_Altivec, vsubcuw, "__builtin_altivec_vsubcuw"); + pragma Import (LL_Altivec, vsubfp, "__builtin_altivec_vsubfp"); + pragma Import (LL_Altivec, vsubsbs, "__builtin_altivec_vsubsbs"); + pragma Import (LL_Altivec, vsubshs, "__builtin_altivec_vsubshs"); + pragma Import (LL_Altivec, vsubsws, "__builtin_altivec_vsubsws"); + pragma Import (LL_Altivec, vsububm, "__builtin_altivec_vsububm"); + pragma Import (LL_Altivec, vsububs, "__builtin_altivec_vsububs"); + pragma Import (LL_Altivec, vsubuhm, "__builtin_altivec_vsubuhm"); + pragma Import (LL_Altivec, vsubuhs, "__builtin_altivec_vsubuhs"); + pragma Import (LL_Altivec, vsubuwm, "__builtin_altivec_vsubuwm"); + pragma Import (LL_Altivec, vsubuws, "__builtin_altivec_vsubuws"); + pragma Import (LL_Altivec, vsum2sws, "__builtin_altivec_vsum2sws"); + pragma Import (LL_Altivec, vsum4sbs, "__builtin_altivec_vsum4sbs"); + pragma Import (LL_Altivec, vsum4shs, "__builtin_altivec_vsum4shs"); + pragma Import (LL_Altivec, vsum4ubs, "__builtin_altivec_vsum4ubs"); + pragma Import (LL_Altivec, vsumsws, "__builtin_altivec_vsumsws"); + pragma Import (LL_Altivec, vupkhpx, "__builtin_altivec_vupkhpx"); + pragma Import (LL_Altivec, vupkhsb, "__builtin_altivec_vupkhsb"); + pragma Import (LL_Altivec, vupkhsh, "__builtin_altivec_vupkhsh"); + pragma Import (LL_Altivec, vupklpx, "__builtin_altivec_vupklpx"); + pragma Import (LL_Altivec, vupklsb, "__builtin_altivec_vupklsb"); + pragma Import (LL_Altivec, vupklsh, "__builtin_altivec_vupklsh"); + pragma Import (LL_Altivec, vcmpbfp_p, "__builtin_altivec_vcmpbfp_p"); + pragma Import (LL_Altivec, vcmpeqfp_p, "__builtin_altivec_vcmpeqfp_p"); + pragma Import (LL_Altivec, vcmpgefp_p, "__builtin_altivec_vcmpgefp_p"); + pragma Import (LL_Altivec, vcmpgtfp_p, "__builtin_altivec_vcmpgtfp_p"); + pragma Import (LL_Altivec, vcmpequw_p, "__builtin_altivec_vcmpequw_p"); + pragma Import (LL_Altivec, vcmpgtsw_p, "__builtin_altivec_vcmpgtsw_p"); + pragma Import (LL_Altivec, vcmpgtuw_p, "__builtin_altivec_vcmpgtuw_p"); + pragma Import (LL_Altivec, vcmpgtuh_p, "__builtin_altivec_vcmpgtuh_p"); + pragma Import (LL_Altivec, vcmpgtsh_p, "__builtin_altivec_vcmpgtsh_p"); + pragma Import (LL_Altivec, vcmpequh_p, "__builtin_altivec_vcmpequh_p"); + pragma Import (LL_Altivec, vcmpequb_p, "__builtin_altivec_vcmpequb_p"); + pragma Import (LL_Altivec, vcmpgtsb_p, "__builtin_altivec_vcmpgtsb_p"); + pragma Import (LL_Altivec, vcmpgtub_p, "__builtin_altivec_vcmpgtub_p"); + +end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/libgnat/g-io-put-vxworks.adb b/gcc/ada/libgnat/g-io-put-vxworks.adb deleted file mode 100644 index 65ee8db51bb..00000000000 --- a/gcc/ada/libgnat/g-io-put-vxworks.adb +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- vxworks zfp version of Put (C : Character) - -with Interfaces.C; use Interfaces.C; - -separate (GNAT.IO) -procedure Put (C : Character) is - - function ioGlobalStdGet - (File : int) return int; - pragma Import (C, ioGlobalStdGet, "ioGlobalStdGet"); - - procedure fdprintf - (File : int; - Format : String; - Value : Character); - pragma Import (C, fdprintf, "fdprintf"); - - Stdout_ID : constant int := 1; - -begin - fdprintf (ioGlobalStdGet (Stdout_ID), "%c" & ASCII.NUL, C); -end Put; diff --git a/gcc/ada/libgnat/g-io__put-vxworks.adb b/gcc/ada/libgnat/g-io__put-vxworks.adb new file mode 100644 index 00000000000..65ee8db51bb --- /dev/null +++ b/gcc/ada/libgnat/g-io__put-vxworks.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- vxworks zfp version of Put (C : Character) + +with Interfaces.C; use Interfaces.C; + +separate (GNAT.IO) +procedure Put (C : Character) is + + function ioGlobalStdGet + (File : int) return int; + pragma Import (C, ioGlobalStdGet, "ioGlobalStdGet"); + + procedure fdprintf + (File : int; + Format : String; + Value : Character); + pragma Import (C, fdprintf, "fdprintf"); + + Stdout_ID : constant int := 1; + +begin + fdprintf (ioGlobalStdGet (Stdout_ID), "%c" & ASCII.NUL, C); +end Put; diff --git a/gcc/ada/libgnat/g-sercom-linux.adb b/gcc/ada/libgnat/g-sercom-linux.adb deleted file mode 100644 index 78e629fc4f0..00000000000 --- a/gcc/ada/libgnat/g-sercom-linux.adb +++ /dev/null @@ -1,314 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the GNU/Linux implementation of this package - -with Ada.Streams; use Ada.Streams; -with Ada; use Ada; -with Ada.Unchecked_Deallocation; - -with System; use System; -with System.Communication; use System.Communication; -with System.CRTL; use System.CRTL; -with System.OS_Constants; - -with GNAT.OS_Lib; use GNAT.OS_Lib; - -package body GNAT.Serial_Communications is - - package OSC renames System.OS_Constants; - - use type Interfaces.C.unsigned; - - type Port_Data is new int; - - subtype unsigned is Interfaces.C.unsigned; - subtype char is Interfaces.C.char; - subtype unsigned_char is Interfaces.C.unsigned_char; - - function fcntl (fd : int; cmd : int; value : int) return int; - pragma Import (C, fcntl, "fcntl"); - - C_Data_Rate : constant array (Data_Rate) of unsigned := - (B75 => OSC.B75, - B110 => OSC.B110, - B150 => OSC.B150, - B300 => OSC.B300, - B600 => OSC.B600, - B1200 => OSC.B1200, - B2400 => OSC.B2400, - B4800 => OSC.B4800, - B9600 => OSC.B9600, - B19200 => OSC.B19200, - B38400 => OSC.B38400, - B57600 => OSC.B57600, - B115200 => OSC.B115200); - - C_Bits : constant array (Data_Bits) of unsigned := - (CS7 => OSC.CS7, CS8 => OSC.CS8); - - C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := - (One => 0, Two => OSC.CSTOPB); - - C_Parity : constant array (Parity_Check) of unsigned := - (None => 0, - Odd => OSC.PARENB or OSC.PARODD, - Even => OSC.PARENB); - - procedure Raise_Error (Message : String; Error : Integer := Errno); - pragma No_Return (Raise_Error); - - ---------- - -- Name -- - ---------- - - function Name (Number : Positive) return Port_Name is - N : constant Natural := Number - 1; - N_Img : constant String := Natural'Image (N); - begin - return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last)); - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (Port : out Serial_Port; - Name : Port_Name) - is - use OSC; - - C_Name : constant String := String (Name) & ASCII.NUL; - Res : int; - - begin - if Port.H = null then - Port.H := new Port_Data; - end if; - - Port.H.all := Port_Data (open - (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); - - if Port.H.all = -1 then - Raise_Error ("open: open failed"); - end if; - - -- By default we are in blocking mode - - Res := fcntl (int (Port.H.all), F_SETFL, 0); - - if Res = -1 then - Raise_Error ("open: fcntl failed"); - end if; - end Open; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error (Message : String; Error : Integer := Errno) is - begin - raise Serial_Error with Message - & (if Error /= 0 - then " (" & Errno_Message (Err => Error) & ')' - else ""); - end Raise_Error; - - ---------- - -- Read -- - ---------- - - overriding procedure Read - (Port : in out Serial_Port; - Buffer : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - Len : constant size_t := Buffer'Length; - Res : ssize_t; - - begin - if Port.H = null then - Raise_Error ("read: port not opened", 0); - end if; - - Res := read (Integer (Port.H.all), Buffer'Address, Len); - - if Res = -1 then - Raise_Error ("read failed"); - end if; - - Last := Last_Index (Buffer'First, size_t (Res)); - end Read; - - --------- - -- Set -- - --------- - - procedure Set - (Port : Serial_Port; - Rate : Data_Rate := B9600; - Bits : Data_Bits := CS8; - Stop_Bits : Stop_Bits_Number := One; - Parity : Parity_Check := None; - Block : Boolean := True; - Local : Boolean := True; - Flow : Flow_Control := None; - Timeout : Duration := 10.0) - is - use OSC; - - type termios is record - c_iflag : unsigned; - c_oflag : unsigned; - c_cflag : unsigned; - c_lflag : unsigned; - c_line : unsigned_char; - c_cc : Interfaces.C.char_array (0 .. 31); - c_ispeed : unsigned; - c_ospeed : unsigned; - end record; - pragma Convention (C, termios); - - function tcgetattr (fd : int; termios_p : Address) return int; - pragma Import (C, tcgetattr, "tcgetattr"); - - function tcsetattr - (fd : int; action : int; termios_p : Address) return int; - pragma Import (C, tcsetattr, "tcsetattr"); - - function tcflush (fd : int; queue_selector : int) return int; - pragma Import (C, tcflush, "tcflush"); - - Current : termios; - - Res : int; - pragma Warnings (Off, Res); - -- Warnings off, since we don't always test the result - - begin - if Port.H = null then - Raise_Error ("set: port not opened", 0); - end if; - - -- Get current port settings - - Res := tcgetattr (int (Port.H.all), Current'Address); - - -- Change settings now - - Current.c_cflag := C_Data_Rate (Rate) - or C_Bits (Bits) - or C_Stop_Bits (Stop_Bits) - or C_Parity (Parity) - or CREAD; - Current.c_iflag := 0; - Current.c_lflag := 0; - Current.c_oflag := 0; - - if Local then - Current.c_cflag := Current.c_cflag or CLOCAL; - end if; - - case Flow is - when None => - null; - - when RTS_CTS => - Current.c_cflag := Current.c_cflag or CRTSCTS; - - when Xon_Xoff => - Current.c_iflag := Current.c_iflag or IXON; - end case; - - Current.c_ispeed := Data_Rate_Value (Rate); - Current.c_ospeed := Data_Rate_Value (Rate); - Current.c_cc (VMIN) := char'Val (0); - Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10)); - - -- Set port settings - - Res := tcflush (int (Port.H.all), TCIFLUSH); - Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); - - -- Block - - Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY)); - - if Res = -1 then - Raise_Error ("set: fcntl failed"); - end if; - end Set; - - ----------- - -- Write -- - ----------- - - overriding procedure Write - (Port : in out Serial_Port; - Buffer : Stream_Element_Array) - is - Len : constant size_t := Buffer'Length; - Res : ssize_t; - - begin - if Port.H = null then - Raise_Error ("write: port not opened", 0); - end if; - - Res := write (int (Port.H.all), Buffer'Address, Len); - - if Res = -1 then - Raise_Error ("write failed"); - end if; - - pragma Assert (size_t (Res) = Len); - end Write; - - ----------- - -- Close -- - ----------- - - procedure Close (Port : in out Serial_Port) is - procedure Unchecked_Free is - new Unchecked_Deallocation (Port_Data, Port_Data_Access); - - Res : int; - pragma Unreferenced (Res); - - begin - if Port.H /= null then - Res := close (int (Port.H.all)); - Unchecked_Free (Port.H); - end if; - end Close; - -end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-sercom-mingw.adb b/gcc/ada/libgnat/g-sercom-mingw.adb deleted file mode 100644 index ed78a523393..00000000000 --- a/gcc/ada/libgnat/g-sercom-mingw.adb +++ /dev/null @@ -1,316 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Windows implementation of this package - -with Ada.Streams; use Ada.Streams; -with Ada.Unchecked_Deallocation; use Ada; - -with System; use System; -with System.Communication; use System.Communication; -with System.CRTL; use System.CRTL; -with System.OS_Constants; -with System.Win32; use System.Win32; -with System.Win32.Ext; use System.Win32.Ext; - -with GNAT.OS_Lib; - -package body GNAT.Serial_Communications is - - package OSC renames System.OS_Constants; - - -- Common types - - type Port_Data is new HANDLE; - - C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7); - C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned := - (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY); - C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned := - (One => ONESTOPBIT, Two => TWOSTOPBITS); - - ----------- - -- Files -- - ----------- - - procedure Raise_Error (Message : String; Error : DWORD := GetLastError); - pragma No_Return (Raise_Error); - - ----------- - -- Close -- - ----------- - - procedure Close (Port : in out Serial_Port) is - procedure Unchecked_Free is - new Unchecked_Deallocation (Port_Data, Port_Data_Access); - - Success : BOOL; - - begin - if Port.H /= null then - Success := CloseHandle (HANDLE (Port.H.all)); - Unchecked_Free (Port.H); - - if Success = Win32.FALSE then - Raise_Error ("error closing the port"); - end if; - end if; - end Close; - - ---------- - -- Name -- - ---------- - - function Name (Number : Positive) return Port_Name is - N_Img : constant String := Positive'Image (Number); - begin - if Number > 9 then - return - Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last)); - else - return - Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':'); - end if; - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (Port : out Serial_Port; - Name : Port_Name) - is - C_Name : constant String := String (Name) & ASCII.NUL; - Success : BOOL; - pragma Unreferenced (Success); - - begin - if Port.H = null then - Port.H := new Port_Data; - else - Success := CloseHandle (HANDLE (Port.H.all)); - end if; - - Port.H.all := CreateFileA - (lpFileName => C_Name (C_Name'First)'Address, - dwDesiredAccess => GENERIC_READ or GENERIC_WRITE, - dwShareMode => 0, - lpSecurityAttributes => null, - dwCreationDisposition => OPEN_EXISTING, - dwFlagsAndAttributes => 0, - hTemplateFile => 0); - - if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then - Raise_Error ("cannot open com port"); - end if; - end Open; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is - begin - raise Serial_Error with Message - & (if Error /= 0 - then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')' - else ""); - end Raise_Error; - - ---------- - -- Read -- - ---------- - - overriding procedure Read - (Port : in out Serial_Port; - Buffer : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - Success : BOOL; - Read_Last : aliased DWORD; - - begin - if Port.H = null then - Raise_Error ("read: port not opened", 0); - end if; - - Success := - ReadFile - (hFile => HANDLE (Port.H.all), - lpBuffer => Buffer (Buffer'First)'Address, - nNumberOfBytesToRead => DWORD (Buffer'Length), - lpNumberOfBytesRead => Read_Last'Access, - lpOverlapped => null); - - if Success = Win32.FALSE then - Raise_Error ("read error"); - end if; - - Last := Last_Index (Buffer'First, size_t (Read_Last)); - end Read; - - --------- - -- Set -- - --------- - - procedure Set - (Port : Serial_Port; - Rate : Data_Rate := B9600; - Bits : Data_Bits := CS8; - Stop_Bits : Stop_Bits_Number := One; - Parity : Parity_Check := None; - Block : Boolean := True; - Local : Boolean := True; - Flow : Flow_Control := None; - Timeout : Duration := 10.0) - is - pragma Unreferenced (Local); - - Success : BOOL; - Com_Time_Out : aliased COMMTIMEOUTS; - Com_Settings : aliased DCB; - - begin - if Port.H = null then - Raise_Error ("set: port not opened", 0); - end if; - - Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access); - - if Success = Win32.FALSE then - Success := CloseHandle (HANDLE (Port.H.all)); - Port.H.all := 0; - Raise_Error ("set: cannot get comm state"); - end if; - - Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate)); - Com_Settings.fParity := 1; - Com_Settings.fBinary := Bits1 (System.Win32.TRUE); - Com_Settings.fOutxDsrFlow := 0; - Com_Settings.fDsrSensitivity := 0; - Com_Settings.fDtrControl := OSC.DTR_CONTROL_ENABLE; - Com_Settings.fInX := 0; - Com_Settings.fRtsControl := OSC.RTS_CONTROL_ENABLE; - - case Flow is - when None => - Com_Settings.fOutX := 0; - Com_Settings.fOutxCtsFlow := 0; - - when RTS_CTS => - Com_Settings.fOutX := 0; - Com_Settings.fOutxCtsFlow := 1; - - when Xon_Xoff => - Com_Settings.fOutX := 1; - Com_Settings.fOutxCtsFlow := 0; - end case; - - Com_Settings.fAbortOnError := 0; - Com_Settings.ByteSize := BYTE (C_Bits (Bits)); - Com_Settings.Parity := BYTE (C_Parity (Parity)); - Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits)); - - Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access); - - if Success = Win32.FALSE then - Success := CloseHandle (HANDLE (Port.H.all)); - Port.H.all := 0; - Raise_Error ("cannot set comm state"); - end if; - - -- Set the timeout status, to honor our spec with respect to read - -- timeouts. Always disconnect write timeouts. - - -- Blocking reads - no timeout at all - - if Block then - Com_Time_Out := (others => 0); - - -- Non-blocking reads and null timeout - immediate return with what we - -- have - set ReadIntervalTimeout to MAXDWORD. - - elsif Timeout = 0.0 then - Com_Time_Out := - (ReadIntervalTimeout => DWORD'Last, - others => 0); - - -- Non-blocking reads with timeout - set total read timeout accordingly - - else - Com_Time_Out := - (ReadTotalTimeoutConstant => DWORD (1000 * Timeout), - others => 0); - end if; - - Success := - SetCommTimeouts - (hFile => HANDLE (Port.H.all), - lpCommTimeouts => Com_Time_Out'Access); - - if Success = Win32.FALSE then - Raise_Error ("cannot set the timeout"); - end if; - end Set; - - ----------- - -- Write -- - ----------- - - overriding procedure Write - (Port : in out Serial_Port; - Buffer : Stream_Element_Array) - is - Success : BOOL; - Temp_Last : aliased DWORD; - - begin - if Port.H = null then - Raise_Error ("write: port not opened", 0); - end if; - - Success := - WriteFile - (hFile => HANDLE (Port.H.all), - lpBuffer => Buffer'Address, - nNumberOfBytesToWrite => DWORD (Buffer'Length), - lpNumberOfBytesWritten => Temp_Last'Access, - lpOverlapped => null); - - if Success = Win32.FALSE - or else Stream_Element_Offset (Temp_Last) /= Buffer'Length - then - Raise_Error ("failed to write data"); - end if; - end Write; - -end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-sercom__linux.adb b/gcc/ada/libgnat/g-sercom__linux.adb new file mode 100644 index 00000000000..78e629fc4f0 --- /dev/null +++ b/gcc/ada/libgnat/g-sercom__linux.adb @@ -0,0 +1,314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the GNU/Linux implementation of this package + +with Ada.Streams; use Ada.Streams; +with Ada; use Ada; +with Ada.Unchecked_Deallocation; + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.OS_Constants; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body GNAT.Serial_Communications is + + package OSC renames System.OS_Constants; + + use type Interfaces.C.unsigned; + + type Port_Data is new int; + + subtype unsigned is Interfaces.C.unsigned; + subtype char is Interfaces.C.char; + subtype unsigned_char is Interfaces.C.unsigned_char; + + function fcntl (fd : int; cmd : int; value : int) return int; + pragma Import (C, fcntl, "fcntl"); + + C_Data_Rate : constant array (Data_Rate) of unsigned := + (B75 => OSC.B75, + B110 => OSC.B110, + B150 => OSC.B150, + B300 => OSC.B300, + B600 => OSC.B600, + B1200 => OSC.B1200, + B2400 => OSC.B2400, + B4800 => OSC.B4800, + B9600 => OSC.B9600, + B19200 => OSC.B19200, + B38400 => OSC.B38400, + B57600 => OSC.B57600, + B115200 => OSC.B115200); + + C_Bits : constant array (Data_Bits) of unsigned := + (CS7 => OSC.CS7, CS8 => OSC.CS8); + + C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := + (One => 0, Two => OSC.CSTOPB); + + C_Parity : constant array (Parity_Check) of unsigned := + (None => 0, + Odd => OSC.PARENB or OSC.PARODD, + Even => OSC.PARENB); + + procedure Raise_Error (Message : String; Error : Integer := Errno); + pragma No_Return (Raise_Error); + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + N : constant Natural := Number - 1; + N_Img : constant String := Natural'Image (N); + begin + return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + use OSC; + + C_Name : constant String := String (Name) & ASCII.NUL; + Res : int; + + begin + if Port.H = null then + Port.H := new Port_Data; + end if; + + Port.H.all := Port_Data (open + (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); + + if Port.H.all = -1 then + Raise_Error ("open: open failed"); + end if; + + -- By default we are in blocking mode + + Res := fcntl (int (Port.H.all), F_SETFL, 0); + + if Res = -1 then + Raise_Error ("open: fcntl failed"); + end if; + end Open; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error (Message : String; Error : Integer := Errno) is + begin + raise Serial_Error with Message + & (if Error /= 0 + then " (" & Errno_Message (Err => Error) & ')' + else ""); + end Raise_Error; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Len : constant size_t := Buffer'Length; + Res : ssize_t; + + begin + if Port.H = null then + Raise_Error ("read: port not opened", 0); + end if; + + Res := read (Integer (Port.H.all), Buffer'Address, Len); + + if Res = -1 then + Raise_Error ("read failed"); + end if; + + Last := Last_Index (Buffer'First, size_t (Res)); + end Read; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; + Timeout : Duration := 10.0) + is + use OSC; + + type termios is record + c_iflag : unsigned; + c_oflag : unsigned; + c_cflag : unsigned; + c_lflag : unsigned; + c_line : unsigned_char; + c_cc : Interfaces.C.char_array (0 .. 31); + c_ispeed : unsigned; + c_ospeed : unsigned; + end record; + pragma Convention (C, termios); + + function tcgetattr (fd : int; termios_p : Address) return int; + pragma Import (C, tcgetattr, "tcgetattr"); + + function tcsetattr + (fd : int; action : int; termios_p : Address) return int; + pragma Import (C, tcsetattr, "tcsetattr"); + + function tcflush (fd : int; queue_selector : int) return int; + pragma Import (C, tcflush, "tcflush"); + + Current : termios; + + Res : int; + pragma Warnings (Off, Res); + -- Warnings off, since we don't always test the result + + begin + if Port.H = null then + Raise_Error ("set: port not opened", 0); + end if; + + -- Get current port settings + + Res := tcgetattr (int (Port.H.all), Current'Address); + + -- Change settings now + + Current.c_cflag := C_Data_Rate (Rate) + or C_Bits (Bits) + or C_Stop_Bits (Stop_Bits) + or C_Parity (Parity) + or CREAD; + Current.c_iflag := 0; + Current.c_lflag := 0; + Current.c_oflag := 0; + + if Local then + Current.c_cflag := Current.c_cflag or CLOCAL; + end if; + + case Flow is + when None => + null; + + when RTS_CTS => + Current.c_cflag := Current.c_cflag or CRTSCTS; + + when Xon_Xoff => + Current.c_iflag := Current.c_iflag or IXON; + end case; + + Current.c_ispeed := Data_Rate_Value (Rate); + Current.c_ospeed := Data_Rate_Value (Rate); + Current.c_cc (VMIN) := char'Val (0); + Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10)); + + -- Set port settings + + Res := tcflush (int (Port.H.all), TCIFLUSH); + Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); + + -- Block + + Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY)); + + if Res = -1 then + Raise_Error ("set: fcntl failed"); + end if; + end Set; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + Len : constant size_t := Buffer'Length; + Res : ssize_t; + + begin + if Port.H = null then + Raise_Error ("write: port not opened", 0); + end if; + + Res := write (int (Port.H.all), Buffer'Address, Len); + + if Res = -1 then + Raise_Error ("write failed"); + end if; + + pragma Assert (size_t (Res) = Len); + end Write; + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Port_Data, Port_Data_Access); + + Res : int; + pragma Unreferenced (Res); + + begin + if Port.H /= null then + Res := close (int (Port.H.all)); + Unchecked_Free (Port.H); + end if; + end Close; + +end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-sercom__mingw.adb b/gcc/ada/libgnat/g-sercom__mingw.adb new file mode 100644 index 00000000000..ed78a523393 --- /dev/null +++ b/gcc/ada/libgnat/g-sercom__mingw.adb @@ -0,0 +1,316 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows implementation of this package + +with Ada.Streams; use Ada.Streams; +with Ada.Unchecked_Deallocation; use Ada; + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.OS_Constants; +with System.Win32; use System.Win32; +with System.Win32.Ext; use System.Win32.Ext; + +with GNAT.OS_Lib; + +package body GNAT.Serial_Communications is + + package OSC renames System.OS_Constants; + + -- Common types + + type Port_Data is new HANDLE; + + C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7); + C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned := + (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY); + C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned := + (One => ONESTOPBIT, Two => TWOSTOPBITS); + + ----------- + -- Files -- + ----------- + + procedure Raise_Error (Message : String; Error : DWORD := GetLastError); + pragma No_Return (Raise_Error); + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Port_Data, Port_Data_Access); + + Success : BOOL; + + begin + if Port.H /= null then + Success := CloseHandle (HANDLE (Port.H.all)); + Unchecked_Free (Port.H); + + if Success = Win32.FALSE then + Raise_Error ("error closing the port"); + end if; + end if; + end Close; + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + N_Img : constant String := Positive'Image (Number); + begin + if Number > 9 then + return + Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last)); + else + return + Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':'); + end if; + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + C_Name : constant String := String (Name) & ASCII.NUL; + Success : BOOL; + pragma Unreferenced (Success); + + begin + if Port.H = null then + Port.H := new Port_Data; + else + Success := CloseHandle (HANDLE (Port.H.all)); + end if; + + Port.H.all := CreateFileA + (lpFileName => C_Name (C_Name'First)'Address, + dwDesiredAccess => GENERIC_READ or GENERIC_WRITE, + dwShareMode => 0, + lpSecurityAttributes => null, + dwCreationDisposition => OPEN_EXISTING, + dwFlagsAndAttributes => 0, + hTemplateFile => 0); + + if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then + Raise_Error ("cannot open com port"); + end if; + end Open; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is + begin + raise Serial_Error with Message + & (if Error /= 0 + then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')' + else ""); + end Raise_Error; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Success : BOOL; + Read_Last : aliased DWORD; + + begin + if Port.H = null then + Raise_Error ("read: port not opened", 0); + end if; + + Success := + ReadFile + (hFile => HANDLE (Port.H.all), + lpBuffer => Buffer (Buffer'First)'Address, + nNumberOfBytesToRead => DWORD (Buffer'Length), + lpNumberOfBytesRead => Read_Last'Access, + lpOverlapped => null); + + if Success = Win32.FALSE then + Raise_Error ("read error"); + end if; + + Last := Last_Index (Buffer'First, size_t (Read_Last)); + end Read; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; + Timeout : Duration := 10.0) + is + pragma Unreferenced (Local); + + Success : BOOL; + Com_Time_Out : aliased COMMTIMEOUTS; + Com_Settings : aliased DCB; + + begin + if Port.H = null then + Raise_Error ("set: port not opened", 0); + end if; + + Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access); + + if Success = Win32.FALSE then + Success := CloseHandle (HANDLE (Port.H.all)); + Port.H.all := 0; + Raise_Error ("set: cannot get comm state"); + end if; + + Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate)); + Com_Settings.fParity := 1; + Com_Settings.fBinary := Bits1 (System.Win32.TRUE); + Com_Settings.fOutxDsrFlow := 0; + Com_Settings.fDsrSensitivity := 0; + Com_Settings.fDtrControl := OSC.DTR_CONTROL_ENABLE; + Com_Settings.fInX := 0; + Com_Settings.fRtsControl := OSC.RTS_CONTROL_ENABLE; + + case Flow is + when None => + Com_Settings.fOutX := 0; + Com_Settings.fOutxCtsFlow := 0; + + when RTS_CTS => + Com_Settings.fOutX := 0; + Com_Settings.fOutxCtsFlow := 1; + + when Xon_Xoff => + Com_Settings.fOutX := 1; + Com_Settings.fOutxCtsFlow := 0; + end case; + + Com_Settings.fAbortOnError := 0; + Com_Settings.ByteSize := BYTE (C_Bits (Bits)); + Com_Settings.Parity := BYTE (C_Parity (Parity)); + Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits)); + + Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access); + + if Success = Win32.FALSE then + Success := CloseHandle (HANDLE (Port.H.all)); + Port.H.all := 0; + Raise_Error ("cannot set comm state"); + end if; + + -- Set the timeout status, to honor our spec with respect to read + -- timeouts. Always disconnect write timeouts. + + -- Blocking reads - no timeout at all + + if Block then + Com_Time_Out := (others => 0); + + -- Non-blocking reads and null timeout - immediate return with what we + -- have - set ReadIntervalTimeout to MAXDWORD. + + elsif Timeout = 0.0 then + Com_Time_Out := + (ReadIntervalTimeout => DWORD'Last, + others => 0); + + -- Non-blocking reads with timeout - set total read timeout accordingly + + else + Com_Time_Out := + (ReadTotalTimeoutConstant => DWORD (1000 * Timeout), + others => 0); + end if; + + Success := + SetCommTimeouts + (hFile => HANDLE (Port.H.all), + lpCommTimeouts => Com_Time_Out'Access); + + if Success = Win32.FALSE then + Raise_Error ("cannot set the timeout"); + end if; + end Set; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + Success : BOOL; + Temp_Last : aliased DWORD; + + begin + if Port.H = null then + Raise_Error ("write: port not opened", 0); + end if; + + Success := + WriteFile + (hFile => HANDLE (Port.H.all), + lpBuffer => Buffer'Address, + nNumberOfBytesToWrite => DWORD (Buffer'Length), + lpNumberOfBytesWritten => Temp_Last'Access, + lpOverlapped => null); + + if Success = Win32.FALSE + or else Stream_Element_Offset (Temp_Last) /= Buffer'Length + then + Raise_Error ("failed to write data"); + end if; + end Write; + +end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-socket-dummy.adb b/gcc/ada/libgnat/g-socket-dummy.adb deleted file mode 100644 index 6cf2eab0ccb..00000000000 --- a/gcc/ada/libgnat/g-socket-dummy.adb +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma No_Body; diff --git a/gcc/ada/libgnat/g-socket-dummy.ads b/gcc/ada/libgnat/g-socket-dummy.ads deleted file mode 100644 index 18caed94d0f..00000000000 --- a/gcc/ada/libgnat/g-socket-dummy.ads +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is a placeholder for the sockets binding for platforms where --- it is not implemented. - -package GNAT.Sockets is - pragma Unimplemented_Unit; -end GNAT.Sockets; diff --git a/gcc/ada/libgnat/g-socket__dummy.adb b/gcc/ada/libgnat/g-socket__dummy.adb new file mode 100644 index 00000000000..6cf2eab0ccb --- /dev/null +++ b/gcc/ada/libgnat/g-socket__dummy.adb @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-socket__dummy.ads b/gcc/ada/libgnat/g-socket__dummy.ads new file mode 100644 index 00000000000..18caed94d0f --- /dev/null +++ b/gcc/ada/libgnat/g-socket__dummy.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a placeholder for the sockets binding for platforms where +-- it is not implemented. + +package GNAT.Sockets is + pragma Unimplemented_Unit; +end GNAT.Sockets; diff --git a/gcc/ada/libgnat/g-socthi-dummy.adb b/gcc/ada/libgnat/g-socthi-dummy.adb deleted file mode 100644 index 4ee3dfdaf3f..00000000000 --- a/gcc/ada/libgnat/g-socthi-dummy.adb +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma No_Body; diff --git a/gcc/ada/libgnat/g-socthi-dummy.ads b/gcc/ada/libgnat/g-socthi-dummy.ads deleted file mode 100644 index 53c49f4012b..00000000000 --- a/gcc/ada/libgnat/g-socthi-dummy.ads +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is a placeholder for the sockets binding for platforms where --- it is not implemented. - -package GNAT.Sockets.Thin is - pragma Unimplemented_Unit; -end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi-mingw.adb b/gcc/ada/libgnat/g-socthi-mingw.adb deleted file mode 100644 index e0cde85d66a..00000000000 --- a/gcc/ada/libgnat/g-socthi-mingw.adb +++ /dev/null @@ -1,631 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This version is for NT - -with Ada.Unchecked_Conversion; -with Interfaces.C.Strings; use Interfaces.C.Strings; -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; - -package body GNAT.Sockets.Thin is - - use type C.unsigned; - - WSAData_Dummy : array (1 .. 512) of C.int; - - WS_Version : constant := 16#0202#; - -- Winsock 2.2 - - Initialized : Boolean := False; - - function Standard_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - pragma Import (Stdcall, Standard_Connect, "connect"); - - function Standard_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - pragma Import (Stdcall, Standard_Select, "select"); - - type Error_Type is - (N_EINTR, - N_EBADF, - N_EACCES, - N_EFAULT, - N_EINVAL, - N_EMFILE, - N_EWOULDBLOCK, - N_EINPROGRESS, - N_EALREADY, - N_ENOTSOCK, - N_EDESTADDRREQ, - N_EMSGSIZE, - N_EPROTOTYPE, - N_ENOPROTOOPT, - N_EPROTONOSUPPORT, - N_ESOCKTNOSUPPORT, - N_EOPNOTSUPP, - N_EPFNOSUPPORT, - N_EAFNOSUPPORT, - N_EADDRINUSE, - N_EADDRNOTAVAIL, - N_ENETDOWN, - N_ENETUNREACH, - N_ENETRESET, - N_ECONNABORTED, - N_ECONNRESET, - N_ENOBUFS, - N_EISCONN, - N_ENOTCONN, - N_ESHUTDOWN, - N_ETOOMANYREFS, - N_ETIMEDOUT, - N_ECONNREFUSED, - N_ELOOP, - N_ENAMETOOLONG, - N_EHOSTDOWN, - N_EHOSTUNREACH, - N_WSASYSNOTREADY, - N_WSAVERNOTSUPPORTED, - N_WSANOTINITIALISED, - N_WSAEDISCON, - N_HOST_NOT_FOUND, - N_TRY_AGAIN, - N_NO_RECOVERY, - N_NO_DATA, - N_OTHERS); - - Error_Messages : constant array (Error_Type) of chars_ptr := - (N_EINTR => - New_String ("Interrupted system call"), - N_EBADF => - New_String ("Bad file number"), - N_EACCES => - New_String ("Permission denied"), - N_EFAULT => - New_String ("Bad address"), - N_EINVAL => - New_String ("Invalid argument"), - N_EMFILE => - New_String ("Too many open files"), - N_EWOULDBLOCK => - New_String ("Operation would block"), - N_EINPROGRESS => - New_String ("Operation now in progress. This error is " - & "returned if any Windows Sockets API " - & "function is called while a blocking " - & "function is in progress"), - N_EALREADY => - New_String ("Operation already in progress"), - N_ENOTSOCK => - New_String ("Socket operation on nonsocket"), - N_EDESTADDRREQ => - New_String ("Destination address required"), - N_EMSGSIZE => - New_String ("Message too long"), - N_EPROTOTYPE => - New_String ("Protocol wrong type for socket"), - N_ENOPROTOOPT => - New_String ("Protocol not available"), - N_EPROTONOSUPPORT => - New_String ("Protocol not supported"), - N_ESOCKTNOSUPPORT => - New_String ("Socket type not supported"), - N_EOPNOTSUPP => - New_String ("Operation not supported on socket"), - N_EPFNOSUPPORT => - New_String ("Protocol family not supported"), - N_EAFNOSUPPORT => - New_String ("Address family not supported by protocol family"), - N_EADDRINUSE => - New_String ("Address already in use"), - N_EADDRNOTAVAIL => - New_String ("Cannot assign requested address"), - N_ENETDOWN => - New_String ("Network is down. This error may be " - & "reported at any time if the Windows " - & "Sockets implementation detects an " - & "underlying failure"), - N_ENETUNREACH => - New_String ("Network is unreachable"), - N_ENETRESET => - New_String ("Network dropped connection on reset"), - N_ECONNABORTED => - New_String ("Software caused connection abort"), - N_ECONNRESET => - New_String ("Connection reset by peer"), - N_ENOBUFS => - New_String ("No buffer space available"), - N_EISCONN => - New_String ("Socket is already connected"), - N_ENOTCONN => - New_String ("Socket is not connected"), - N_ESHUTDOWN => - New_String ("Cannot send after socket shutdown"), - N_ETOOMANYREFS => - New_String ("Too many references: cannot splice"), - N_ETIMEDOUT => - New_String ("Connection timed out"), - N_ECONNREFUSED => - New_String ("Connection refused"), - N_ELOOP => - New_String ("Too many levels of symbolic links"), - N_ENAMETOOLONG => - New_String ("File name too long"), - N_EHOSTDOWN => - New_String ("Host is down"), - N_EHOSTUNREACH => - New_String ("No route to host"), - N_WSASYSNOTREADY => - New_String ("Returned by WSAStartup(), indicating that " - & "the network subsystem is unusable"), - N_WSAVERNOTSUPPORTED => - New_String ("Returned by WSAStartup(), indicating that " - & "the Windows Sockets DLL cannot support " - & "this application"), - N_WSANOTINITIALISED => - New_String ("Winsock not initialized. This message is " - & "returned by any function except WSAStartup(), " - & "indicating that a successful WSAStartup() has " - & "not yet been performed"), - N_WSAEDISCON => - New_String ("Disconnected"), - N_HOST_NOT_FOUND => - New_String ("Host not found. This message indicates " - & "that the key (name, address, and so on) was not found"), - N_TRY_AGAIN => - New_String ("Nonauthoritative host not found. This error may " - & "suggest that the name service itself is not " - & "functioning"), - N_NO_RECOVERY => - New_String ("Nonrecoverable error. This error may suggest that the " - & "name service itself is not functioning"), - N_NO_DATA => - New_String ("Valid name, no data record of requested type. " - & "This error indicates that the key (name, address, " - & "and so on) was not found."), - N_OTHERS => - New_String ("Unknown system error")); - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int - is - Res : C.int; - - begin - Res := Standard_Connect (S, Name, Namelen); - - if Res = -1 then - if Socket_Errno = SOSC.EWOULDBLOCK then - Set_Socket_Errno (SOSC.EINPROGRESS); - end if; - end if; - - return Res; - end C_Connect; - - ------------------ - -- Socket_Ioctl -- - ------------------ - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int - is - begin - return C_Ioctl (S, Req, Arg); - end Socket_Ioctl; - - --------------- - -- C_Recvmsg -- - --------------- - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - use type C.size_t; - - Fill : constant Boolean := - SOSC.MSG_WAITALL /= -1 - and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; - -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors - - Res : C.int; - Count : C.int := 0; - - MH : Msghdr; - for MH'Address use Msg; - - Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; - for Iovec'Address use MH.Msg_Iov; - pragma Import (Ada, Iovec); - - Iov_Index : Integer; - Current_Iovec : Vector_Element; - - function To_Access is new Ada.Unchecked_Conversion - (System.Address, Stream_Element_Reference); - pragma Warnings (Off, Stream_Element_Reference); - - Req : Request_Type (Name => N_Bytes_To_Read); - - begin - -- Windows does not provide an implementation of recvmsg(). The spec for - -- WSARecvMsg() is incompatible with the data types we define, and is - -- available starting with Windows Vista and Server 2008 only. So, - -- we use C_Recv instead. - - -- Check how much data are available - - Control_Socket (Socket_Type (S), Req); - - -- Fill the vectors - - Iov_Index := -1; - Current_Iovec := (Base => null, Length => 0); - - loop - if Current_Iovec.Length = 0 then - Iov_Index := Iov_Index + 1; - exit when Iov_Index > Integer (Iovec'Last); - Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index)); - end if; - - Res := - C_Recv - (S, - Current_Iovec.Base.all'Address, - C.int (Current_Iovec.Length), - Flags); - - if Res < 0 then - return System.CRTL.ssize_t (Res); - - elsif Res = 0 and then not Fill then - exit; - - else - pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length); - - Count := Count + Res; - Current_Iovec.Length := - Current_Iovec.Length - Interfaces.C.size_t (Res); - Current_Iovec.Base := - To_Access (Current_Iovec.Base.all'Address - + Storage_Offset (Res)); - - -- If all the data that was initially available read, do not - -- attempt to receive more, since this might block, or merge data - -- from successive datagrams for a datagram-oriented socket. We - -- still try to receive more if we need to fill all vectors - -- (MSG_WAITALL flag is set). - - exit when Natural (Count) >= Req.Size - and then - - -- Either we are not in fill mode - - (not Fill - - -- Or else last vector filled - - or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last - and then Current_Iovec.Length = 0)); - end if; - end loop; - - return System.CRTL.ssize_t (Count); - end C_Recvmsg; - - -------------- - -- C_Select -- - -------------- - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int - is - pragma Warnings (Off, Exceptfds); - - Original_WFS : aliased constant Fd_Set := Writefds.all; - - Res : C.int; - S : aliased C.int; - Last : aliased C.int; - - begin - -- Asynchronous connection failures are notified in the exception fd - -- set instead of the write fd set. To ensure POSIX compatibility, copy - -- write fd set into exception fd set. Once select() returns, check any - -- socket present in the exception fd set and peek at incoming - -- out-of-band data. If the test is not successful, and the socket is - -- present in the initial write fd set, then move the socket from the - -- exception fd set to the write fd set. - - if Writefds /= No_Fd_Set_Access then - - -- Add any socket present in write fd set into exception fd set - - declare - WFS : aliased Fd_Set := Writefds.all; - begin - Last := Nfds - 1; - loop - Get_Socket_From_Set - (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access); - exit when S = -1; - Insert_Socket_In_Set (Exceptfds, S); - end loop; - end; - end if; - - Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout); - - if Exceptfds /= No_Fd_Set_Access then - declare - EFSC : aliased Fd_Set := Exceptfds.all; - Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB; - Buffer : Character; - Length : C.int; - Fromlen : aliased C.int; - - begin - Last := Nfds - 1; - loop - Get_Socket_From_Set - (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access); - - -- No more sockets in EFSC - - exit when S = -1; - - -- Check out-of-band data - - Length := - C_Recvfrom - (S, Buffer'Address, 1, Flag, - From => System.Null_Address, - Fromlen => Fromlen'Unchecked_Access); - -- Is Fromlen necessary if From is Null_Address??? - - -- If the signal is not an out-of-band data, then it - -- is a connection failure notification. - - if Length = -1 then - Remove_Socket_From_Set (Exceptfds, S); - - -- If S is present in the initial write fd set, move it from - -- exception fd set back to write fd set. Otherwise, ignore - -- this event since the user is not watching for it. - - if Writefds /= No_Fd_Set_Access - and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0) - then - Insert_Socket_In_Set (Writefds, S); - end if; - end if; - end loop; - end; - end if; - return Res; - end C_Select; - - --------------- - -- C_Sendmsg -- - --------------- - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - use type C.size_t; - - Res : C.int; - Count : C.int := 0; - - MH : Msghdr; - for MH'Address use Msg; - - Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; - for Iovec'Address use MH.Msg_Iov; - pragma Import (Ada, Iovec); - - begin - -- Windows does not provide an implementation of sendmsg(). The spec for - -- WSASendMsg() is incompatible with the data types we define, and is - -- available starting with Windows Vista and Server 2008 only. So - -- use C_Sendto instead. - - for J in Iovec'Range loop - Res := - C_Sendto - (S, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - Flags => Flags, - To => MH.Msg_Name, - Tolen => C.int (MH.Msg_Namelen)); - - if Res < 0 then - return System.CRTL.ssize_t (Res); - else - Count := Count + Res; - end if; - - -- Exit now if the buffer is not fully transmitted - - exit when Interfaces.C.size_t (Res) < Iovec (J).Length; - end loop; - - return System.CRTL.ssize_t (Count); - end C_Sendmsg; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - if Initialized then - WSACleanup; - Initialized := False; - end if; - end Finalize; - - ------------------------- - -- Host_Error_Messages -- - ------------------------- - - package body Host_Error_Messages is - - -- On Windows, socket and host errors share the same code space, and - -- error messages are provided by Socket_Error_Message, so the default - -- separate body for Host_Error_Messages is not used in this case. - - function Host_Error_Message (H_Errno : Integer) return String - renames Socket_Error_Message; - - end Host_Error_Messages; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - Return_Value : Interfaces.C.int; - begin - if not Initialized then - Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); - pragma Assert (Return_Value = 0); - Initialized := True; - end if; - end Initialize; - - -------------------- - -- Signalling_Fds -- - -------------------- - - package body Signalling_Fds is separate; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message (Errno : Integer) return String is - use GNAT.Sockets.SOSC; - - Errm : C.Strings.chars_ptr; - - begin - case Errno is - when EINTR => Errm := Error_Messages (N_EINTR); - when EBADF => Errm := Error_Messages (N_EBADF); - when EACCES => Errm := Error_Messages (N_EACCES); - when EFAULT => Errm := Error_Messages (N_EFAULT); - when EINVAL => Errm := Error_Messages (N_EINVAL); - when EMFILE => Errm := Error_Messages (N_EMFILE); - when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK); - when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS); - when EALREADY => Errm := Error_Messages (N_EALREADY); - when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK); - when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ); - when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE); - when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE); - when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT); - when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT); - when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT); - when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP); - when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT); - when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT); - when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE); - when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL); - when ENETDOWN => Errm := Error_Messages (N_ENETDOWN); - when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH); - when ENETRESET => Errm := Error_Messages (N_ENETRESET); - when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED); - when ECONNRESET => Errm := Error_Messages (N_ECONNRESET); - when ENOBUFS => Errm := Error_Messages (N_ENOBUFS); - when EISCONN => Errm := Error_Messages (N_EISCONN); - when ENOTCONN => Errm := Error_Messages (N_ENOTCONN); - when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN); - when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS); - when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT); - when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED); - when ELOOP => Errm := Error_Messages (N_ELOOP); - when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG); - when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN); - when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH); - - -- Windows-specific error codes - - when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY); - when WSAVERNOTSUPPORTED => - Errm := Error_Messages (N_WSAVERNOTSUPPORTED); - when WSANOTINITIALISED => - Errm := Error_Messages (N_WSANOTINITIALISED); - when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON); - - -- h_errno values - - when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND); - when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN); - when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY); - when NO_DATA => Errm := Error_Messages (N_NO_DATA); - when others => Errm := Error_Messages (N_OTHERS); - end case; - - return Value (Errm); - end Socket_Error_Message; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi-mingw.ads b/gcc/ada/libgnat/g-socthi-mingw.ads deleted file mode 100644 index 48f5aeb9bef..00000000000 --- a/gcc/ada/libgnat/g-socthi-mingw.ads +++ /dev/null @@ -1,242 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This version is for NT - -with Interfaces.C; - -with GNAT.Sockets.Thin_Common; - -with System; -with System.CRTL; - -package GNAT.Sockets.Thin is - - use Thin_Common; - - package C renames Interfaces.C; - - use type System.CRTL.ssize_t; - - function Socket_Errno return Integer; - -- Returns last socket error number - - procedure Set_Socket_Errno (Errno : Integer); - -- Set last socket error number - - function Socket_Error_Message (Errno : Integer) return String; - -- Returns the error message string for the error number Errno. If Errno is - -- not known, returns "Unknown system error". - - function Host_Errno return Integer; - pragma Import (C, Host_Errno, "__gnat_get_h_errno"); - -- Returns last host error number - - package Host_Error_Messages is - - function Host_Error_Message (H_Errno : Integer) return String; - -- Returns the error message string for the host error number H_Errno. - -- If H_Errno is not known, returns "Unknown system error". - - end Host_Error_Messages; - - -------------------------------- - -- Standard library functions -- - -------------------------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int; - - function C_Bind - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Close - (Fd : C.int) return C.int; - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Gethostname - (Name : System.Address; - Namelen : C.int) return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : not null access C.int) return C.int; - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int; - - function C_Listen - (S : C.int; - Backlog : C.int) return C.int; - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int; - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int; - - function C_Setsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : C.int) return C.int; - - function C_Shutdown - (S : C.int; - How : C.int) return C.int; - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int; - - function C_System - (Command : System.Address) return C.int; - - function WSAStartup - (WS_Version : Interfaces.C.unsigned_short; - WSADataAddress : System.Address) return Interfaces.C.int; - - ------------------------------------------------------- - -- Signalling file descriptors for selector abortion -- - ------------------------------------------------------- - - package Signalling_Fds is - - function Create (Fds : not null access Fd_Pair) return C.int; - pragma Convention (C, Create); - -- Create a pair of connected descriptors suitable for use with C_Select - -- (used for signalling in Selector objects). - - function Read (Rsig : C.int) return C.int; - pragma Convention (C, Read); - -- Read one byte of data from rsig, the read end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - function Write (Wsig : C.int) return C.int; - pragma Convention (C, Write); - -- Write one byte of data to wsig, the write end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - procedure Close (Sig : C.int); - pragma Convention (C, Close); - -- Close one end of a pair of signalling fds (ignoring any error) - - end Signalling_Fds; - - procedure WSACleanup; - - procedure Initialize; - procedure Finalize; - -private - pragma Import (Stdcall, C_Accept, "accept"); - pragma Import (Stdcall, C_Bind, "bind"); - pragma Import (Stdcall, C_Close, "closesocket"); - pragma Import (Stdcall, C_Gethostname, "gethostname"); - pragma Import (Stdcall, C_Getpeername, "getpeername"); - pragma Import (Stdcall, C_Getsockname, "getsockname"); - pragma Import (Stdcall, C_Getsockopt, "getsockopt"); - pragma Import (Stdcall, C_Listen, "listen"); - pragma Import (Stdcall, C_Recv, "recv"); - pragma Import (Stdcall, C_Recvfrom, "recvfrom"); - pragma Import (Stdcall, C_Sendto, "sendto"); - pragma Import (Stdcall, C_Setsockopt, "setsockopt"); - pragma Import (Stdcall, C_Shutdown, "shutdown"); - pragma Import (Stdcall, C_Socket, "socket"); - pragma Import (C, C_System, "_system"); - pragma Import (Stdcall, Socket_Errno, "WSAGetLastError"); - pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError"); - pragma Import (Stdcall, WSAStartup, "WSAStartup"); - pragma Import (Stdcall, WSACleanup, "WSACleanup"); - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi-vxworks.adb b/gcc/ada/libgnat/g-socthi-vxworks.adb deleted file mode 100644 index 05bedc2a1f9..00000000000 --- a/gcc/ada/libgnat/g-socthi-vxworks.adb +++ /dev/null @@ -1,487 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This version is for VxWorks - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Task_Lock; - -with Interfaces.C; use Interfaces.C; - -package body GNAT.Sockets.Thin is - - Non_Blocking_Sockets : aliased Fd_Set; - -- When this package is initialized with Process_Blocking_IO set - -- to True, sockets are set in non-blocking mode to avoid blocking - -- the whole process when a thread wants to perform a blocking IO - -- operation. But the user can also set a socket in non-blocking - -- mode by purpose. In order to make a difference between these - -- two situations, we track the origin of non-blocking mode in - -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has - -- been set in non-blocking mode by the user. - - Quantum : constant Duration := 0.2; - -- When SOSC.Thread_Blocking_IO is False, we set sockets in - -- non-blocking mode and we spend a period of time Quantum between - -- two attempts on a blocking operation. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All these require comments ??? - - function Syscall_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int; - pragma Import (C, Syscall_Accept, "accept"); - - function Syscall_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - pragma Import (C, Syscall_Connect, "connect"); - - function Syscall_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recv, "recv"); - - function Syscall_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int; - pragma Import (C, Syscall_Recvfrom, "recvfrom"); - - function Syscall_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recvmsg, "recvmsg"); - - function Syscall_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Sendmsg, "sendmsg"); - - function Syscall_Send - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Send, "send"); - - function Syscall_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int; - pragma Import (C, Syscall_Sendto, "sendto"); - - function Syscall_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int; - pragma Import (C, Syscall_Socket, "socket"); - - function Non_Blocking_Socket (S : C.int) return Boolean; - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); - - -------------- - -- C_Accept -- - -------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Res : C.int; - pragma Unreferenced (Res); - - begin - loop - R := Syscall_Accept (S, Addr, Addrlen); - exit when SOSC.Thread_Blocking_IO - or else R /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- A socket inherits the properties of its server especially - -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram - -- tracks sockets set in non-blocking mode by user. - - Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); - Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - -- Is it OK to ignore result ??? - end if; - - return R; - end C_Accept; - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int - is - Res : C.int; - - begin - Res := Syscall_Connect (S, Name, Namelen); - - if SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EINPROGRESS - then - return Res; - end if; - - declare - WSet : aliased Fd_Set; - Now : aliased Timeval; - begin - Reset_Socket_Set (WSet'Access); - loop - Insert_Socket_In_Set (WSet'Access, S); - Now := Immediat; - Res := C_Select - (S + 1, - No_Fd_Set_Access, - WSet'Access, - No_Fd_Set_Access, - Now'Unchecked_Access); - - exit when Res > 0; - - if Res = Failure then - return Res; - end if; - - delay Quantum; - end loop; - end; - - Res := Syscall_Connect (S, Name, Namelen); - - if Res = Failure - and then Errno = SOSC.EISCONN - then - return Thin_Common.Success; - else - return Res; - end if; - end C_Connect; - - ------------------ - -- Socket_Ioctl -- - ------------------ - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int - is - begin - if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then - if Arg.all /= 0 then - Set_Non_Blocking_Socket (S, True); - end if; - end if; - - return C_Ioctl (S, Req, Arg); - end Socket_Ioctl; - - ------------ - -- C_Recv -- - ------------ - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recv (S, Msg, Len, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recv; - - ---------------- - -- C_Recvfrom -- - ---------------- - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recvfrom; - - --------------- - -- C_Recvmsg -- - --------------- - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : C.int; - - begin - loop - Res := Syscall_Recvmsg (S, Msg, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return System.CRTL.ssize_t (Res); - end C_Recvmsg; - - --------------- - -- C_Sendmsg -- - --------------- - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : C.int; - - begin - loop - Res := Syscall_Sendmsg (S, Msg, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return System.CRTL.ssize_t (Res); - end C_Sendmsg; - - -------------- - -- C_Sendto -- - -------------- - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int - is - use System; - - Res : C.int; - - begin - loop - if To = Null_Address then - - -- In violation of the standard sockets API, VxWorks does not - -- support sendto(2) calls on connected sockets with a null - -- destination address, so use send(2) instead in that case. - - Res := Syscall_Send (S, Msg, Len, Flags); - - -- Normal case where destination address is non-null - - else - Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - end if; - - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Sendto; - - -------------- - -- C_Socket -- - -------------- - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Res : C.int; - pragma Unreferenced (Res); - - begin - R := Syscall_Socket (Domain, Typ, Protocol); - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- Do not use Socket_Ioctl as this subprogram tracks sockets set - -- in non-blocking mode by user. - - Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - -- Is it OK to ignore result ??? - Set_Non_Blocking_Socket (R, False); - end if; - - return R; - end C_Socket; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - null; - end Finalize; - - ------------------------- - -- Host_Error_Messages -- - ------------------------- - - package body Host_Error_Messages is separate; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Reset_Socket_Set (Non_Blocking_Sockets'Access); - end Initialize; - - ------------------------- - -- Non_Blocking_Socket -- - ------------------------- - - function Non_Blocking_Socket (S : C.int) return Boolean is - R : Boolean; - begin - Task_Lock.Lock; - R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); - Task_Lock.Unlock; - return R; - end Non_Blocking_Socket; - - ----------------------------- - -- Set_Non_Blocking_Socket -- - ----------------------------- - - procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is - begin - Task_Lock.Lock; - if V then - Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); - else - Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); - end if; - - Task_Lock.Unlock; - end Set_Non_Blocking_Socket; - - -------------------- - -- Signalling_Fds -- - -------------------- - - package body Signalling_Fds is separate; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message (Errno : Integer) return String is separate; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi-vxworks.ads b/gcc/ada/libgnat/g-socthi-vxworks.ads deleted file mode 100644 index 9cb4018afcb..00000000000 --- a/gcc/ada/libgnat/g-socthi-vxworks.ads +++ /dev/null @@ -1,228 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This is the version for VxWorks - -with Interfaces.C; - -with GNAT.OS_Lib; -with GNAT.Sockets.Thin_Common; - -with System; -with System.CRTL; - -package GNAT.Sockets.Thin is - - use Thin_Common; - - package C renames Interfaces.C; - - use type System.CRTL.ssize_t; - - function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; - -- Returns last socket error number - - procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno; - -- Set last socket error number - - function Socket_Error_Message (Errno : Integer) return String; - -- Returns the error message string for the error number Errno. If Errno is - -- not known, returns "Unknown system error". - - function Host_Errno return Integer; - pragma Import (C, Host_Errno, "__gnat_get_h_errno"); - -- Returns last host error number - - package Host_Error_Messages is - - function Host_Error_Message (H_Errno : Integer) return String; - -- Returns the error message string for the host error number H_Errno. - -- If H_Errno is not known, returns "Unknown system error". - - end Host_Error_Messages; - - -------------------------------- - -- Standard library functions -- - -------------------------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null access C.int) return C.int; - - function C_Bind - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Close - (Fd : C.int) return C.int; - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int; - - function C_Gethostname - (Name : System.Address; - Namelen : C.int) return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : not null access C.int) return C.int; - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int; - - function C_Listen - (S : C.int; - Backlog : C.int) return C.int; - - function C_Recv - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int) return C.int; - - function C_Recvfrom - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - From : System.Address; - Fromlen : not null access C.int) return C.int; - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int; - - function C_Setsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : C.int) return C.int; - - function C_Shutdown - (S : C.int; - How : C.int) return C.int; - - function C_Socket - (Domain : C.int; - Typ : C.int; - Protocol : C.int) return C.int; - - function C_System - (Command : System.Address) return C.int; - - ------------------------------------------------------- - -- Signalling file descriptors for selector abortion -- - ------------------------------------------------------- - - package Signalling_Fds is - - function Create (Fds : not null access Fd_Pair) return C.int; - pragma Convention (C, Create); - -- Create a pair of connected descriptors suitable for use with C_Select - -- (used for signalling in Selector objects). - - function Read (Rsig : C.int) return C.int; - pragma Convention (C, Read); - -- Read one byte of data from rsig, the read end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - function Write (Wsig : C.int) return C.int; - pragma Convention (C, Write); - -- Write one byte of data to wsig, the write end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - procedure Close (Sig : C.int); - pragma Convention (C, Close); - -- Close one end of a pair of signalling fds (ignoring any error) - - end Signalling_Fds; - - procedure Initialize; - procedure Finalize; - -private - pragma Import (C, C_Bind, "bind"); - pragma Import (C, C_Close, "close"); - pragma Import (C, C_Gethostname, "gethostname"); - pragma Import (C, C_Getpeername, "getpeername"); - pragma Import (C, C_Getsockname, "getsockname"); - pragma Import (C, C_Getsockopt, "getsockopt"); - pragma Import (C, C_Listen, "listen"); - pragma Import (C, C_Select, "select"); - pragma Import (C, C_Setsockopt, "setsockopt"); - pragma Import (C, C_Shutdown, "shutdown"); - pragma Import (C, C_System, "system"); -end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi__dummy.adb b/gcc/ada/libgnat/g-socthi__dummy.adb new file mode 100644 index 00000000000..4ee3dfdaf3f --- /dev/null +++ b/gcc/ada/libgnat/g-socthi__dummy.adb @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-socthi__dummy.ads b/gcc/ada/libgnat/g-socthi__dummy.ads new file mode 100644 index 00000000000..53c49f4012b --- /dev/null +++ b/gcc/ada/libgnat/g-socthi__dummy.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a placeholder for the sockets binding for platforms where +-- it is not implemented. + +package GNAT.Sockets.Thin is + pragma Unimplemented_Unit; +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi__mingw.adb b/gcc/ada/libgnat/g-socthi__mingw.adb new file mode 100644 index 00000000000..e0cde85d66a --- /dev/null +++ b/gcc/ada/libgnat/g-socthi__mingw.adb @@ -0,0 +1,631 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for NT + +with Ada.Unchecked_Conversion; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +package body GNAT.Sockets.Thin is + + use type C.unsigned; + + WSAData_Dummy : array (1 .. 512) of C.int; + + WS_Version : constant := 16#0202#; + -- Winsock 2.2 + + Initialized : Boolean := False; + + function Standard_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + pragma Import (Stdcall, Standard_Connect, "connect"); + + function Standard_Select + (Nfds : C.int; + Readfds : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int; + pragma Import (Stdcall, Standard_Select, "select"); + + type Error_Type is + (N_EINTR, + N_EBADF, + N_EACCES, + N_EFAULT, + N_EINVAL, + N_EMFILE, + N_EWOULDBLOCK, + N_EINPROGRESS, + N_EALREADY, + N_ENOTSOCK, + N_EDESTADDRREQ, + N_EMSGSIZE, + N_EPROTOTYPE, + N_ENOPROTOOPT, + N_EPROTONOSUPPORT, + N_ESOCKTNOSUPPORT, + N_EOPNOTSUPP, + N_EPFNOSUPPORT, + N_EAFNOSUPPORT, + N_EADDRINUSE, + N_EADDRNOTAVAIL, + N_ENETDOWN, + N_ENETUNREACH, + N_ENETRESET, + N_ECONNABORTED, + N_ECONNRESET, + N_ENOBUFS, + N_EISCONN, + N_ENOTCONN, + N_ESHUTDOWN, + N_ETOOMANYREFS, + N_ETIMEDOUT, + N_ECONNREFUSED, + N_ELOOP, + N_ENAMETOOLONG, + N_EHOSTDOWN, + N_EHOSTUNREACH, + N_WSASYSNOTREADY, + N_WSAVERNOTSUPPORTED, + N_WSANOTINITIALISED, + N_WSAEDISCON, + N_HOST_NOT_FOUND, + N_TRY_AGAIN, + N_NO_RECOVERY, + N_NO_DATA, + N_OTHERS); + + Error_Messages : constant array (Error_Type) of chars_ptr := + (N_EINTR => + New_String ("Interrupted system call"), + N_EBADF => + New_String ("Bad file number"), + N_EACCES => + New_String ("Permission denied"), + N_EFAULT => + New_String ("Bad address"), + N_EINVAL => + New_String ("Invalid argument"), + N_EMFILE => + New_String ("Too many open files"), + N_EWOULDBLOCK => + New_String ("Operation would block"), + N_EINPROGRESS => + New_String ("Operation now in progress. This error is " + & "returned if any Windows Sockets API " + & "function is called while a blocking " + & "function is in progress"), + N_EALREADY => + New_String ("Operation already in progress"), + N_ENOTSOCK => + New_String ("Socket operation on nonsocket"), + N_EDESTADDRREQ => + New_String ("Destination address required"), + N_EMSGSIZE => + New_String ("Message too long"), + N_EPROTOTYPE => + New_String ("Protocol wrong type for socket"), + N_ENOPROTOOPT => + New_String ("Protocol not available"), + N_EPROTONOSUPPORT => + New_String ("Protocol not supported"), + N_ESOCKTNOSUPPORT => + New_String ("Socket type not supported"), + N_EOPNOTSUPP => + New_String ("Operation not supported on socket"), + N_EPFNOSUPPORT => + New_String ("Protocol family not supported"), + N_EAFNOSUPPORT => + New_String ("Address family not supported by protocol family"), + N_EADDRINUSE => + New_String ("Address already in use"), + N_EADDRNOTAVAIL => + New_String ("Cannot assign requested address"), + N_ENETDOWN => + New_String ("Network is down. This error may be " + & "reported at any time if the Windows " + & "Sockets implementation detects an " + & "underlying failure"), + N_ENETUNREACH => + New_String ("Network is unreachable"), + N_ENETRESET => + New_String ("Network dropped connection on reset"), + N_ECONNABORTED => + New_String ("Software caused connection abort"), + N_ECONNRESET => + New_String ("Connection reset by peer"), + N_ENOBUFS => + New_String ("No buffer space available"), + N_EISCONN => + New_String ("Socket is already connected"), + N_ENOTCONN => + New_String ("Socket is not connected"), + N_ESHUTDOWN => + New_String ("Cannot send after socket shutdown"), + N_ETOOMANYREFS => + New_String ("Too many references: cannot splice"), + N_ETIMEDOUT => + New_String ("Connection timed out"), + N_ECONNREFUSED => + New_String ("Connection refused"), + N_ELOOP => + New_String ("Too many levels of symbolic links"), + N_ENAMETOOLONG => + New_String ("File name too long"), + N_EHOSTDOWN => + New_String ("Host is down"), + N_EHOSTUNREACH => + New_String ("No route to host"), + N_WSASYSNOTREADY => + New_String ("Returned by WSAStartup(), indicating that " + & "the network subsystem is unusable"), + N_WSAVERNOTSUPPORTED => + New_String ("Returned by WSAStartup(), indicating that " + & "the Windows Sockets DLL cannot support " + & "this application"), + N_WSANOTINITIALISED => + New_String ("Winsock not initialized. This message is " + & "returned by any function except WSAStartup(), " + & "indicating that a successful WSAStartup() has " + & "not yet been performed"), + N_WSAEDISCON => + New_String ("Disconnected"), + N_HOST_NOT_FOUND => + New_String ("Host not found. This message indicates " + & "that the key (name, address, and so on) was not found"), + N_TRY_AGAIN => + New_String ("Nonauthoritative host not found. This error may " + & "suggest that the name service itself is not " + & "functioning"), + N_NO_RECOVERY => + New_String ("Nonrecoverable error. This error may suggest that the " + & "name service itself is not functioning"), + N_NO_DATA => + New_String ("Valid name, no data record of requested type. " + & "This error indicates that the key (name, address, " + & "and so on) was not found."), + N_OTHERS => + New_String ("Unknown system error")); + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int + is + Res : C.int; + + begin + Res := Standard_Connect (S, Name, Namelen); + + if Res = -1 then + if Socket_Errno = SOSC.EWOULDBLOCK then + Set_Socket_Errno (SOSC.EINPROGRESS); + end if; + end if; + + return Res; + end C_Connect; + + ------------------ + -- Socket_Ioctl -- + ------------------ + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int + is + begin + return C_Ioctl (S, Req, Arg); + end Socket_Ioctl; + + --------------- + -- C_Recvmsg -- + --------------- + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + use type C.size_t; + + Fill : constant Boolean := + SOSC.MSG_WAITALL /= -1 + and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; + -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors + + Res : C.int; + Count : C.int := 0; + + MH : Msghdr; + for MH'Address use Msg; + + Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; + for Iovec'Address use MH.Msg_Iov; + pragma Import (Ada, Iovec); + + Iov_Index : Integer; + Current_Iovec : Vector_Element; + + function To_Access is new Ada.Unchecked_Conversion + (System.Address, Stream_Element_Reference); + pragma Warnings (Off, Stream_Element_Reference); + + Req : Request_Type (Name => N_Bytes_To_Read); + + begin + -- Windows does not provide an implementation of recvmsg(). The spec for + -- WSARecvMsg() is incompatible with the data types we define, and is + -- available starting with Windows Vista and Server 2008 only. So, + -- we use C_Recv instead. + + -- Check how much data are available + + Control_Socket (Socket_Type (S), Req); + + -- Fill the vectors + + Iov_Index := -1; + Current_Iovec := (Base => null, Length => 0); + + loop + if Current_Iovec.Length = 0 then + Iov_Index := Iov_Index + 1; + exit when Iov_Index > Integer (Iovec'Last); + Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index)); + end if; + + Res := + C_Recv + (S, + Current_Iovec.Base.all'Address, + C.int (Current_Iovec.Length), + Flags); + + if Res < 0 then + return System.CRTL.ssize_t (Res); + + elsif Res = 0 and then not Fill then + exit; + + else + pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length); + + Count := Count + Res; + Current_Iovec.Length := + Current_Iovec.Length - Interfaces.C.size_t (Res); + Current_Iovec.Base := + To_Access (Current_Iovec.Base.all'Address + + Storage_Offset (Res)); + + -- If all the data that was initially available read, do not + -- attempt to receive more, since this might block, or merge data + -- from successive datagrams for a datagram-oriented socket. We + -- still try to receive more if we need to fill all vectors + -- (MSG_WAITALL flag is set). + + exit when Natural (Count) >= Req.Size + and then + + -- Either we are not in fill mode + + (not Fill + + -- Or else last vector filled + + or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last + and then Current_Iovec.Length = 0)); + end if; + end loop; + + return System.CRTL.ssize_t (Count); + end C_Recvmsg; + + -------------- + -- C_Select -- + -------------- + + function C_Select + (Nfds : C.int; + Readfds : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int + is + pragma Warnings (Off, Exceptfds); + + Original_WFS : aliased constant Fd_Set := Writefds.all; + + Res : C.int; + S : aliased C.int; + Last : aliased C.int; + + begin + -- Asynchronous connection failures are notified in the exception fd + -- set instead of the write fd set. To ensure POSIX compatibility, copy + -- write fd set into exception fd set. Once select() returns, check any + -- socket present in the exception fd set and peek at incoming + -- out-of-band data. If the test is not successful, and the socket is + -- present in the initial write fd set, then move the socket from the + -- exception fd set to the write fd set. + + if Writefds /= No_Fd_Set_Access then + + -- Add any socket present in write fd set into exception fd set + + declare + WFS : aliased Fd_Set := Writefds.all; + begin + Last := Nfds - 1; + loop + Get_Socket_From_Set + (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access); + exit when S = -1; + Insert_Socket_In_Set (Exceptfds, S); + end loop; + end; + end if; + + Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout); + + if Exceptfds /= No_Fd_Set_Access then + declare + EFSC : aliased Fd_Set := Exceptfds.all; + Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB; + Buffer : Character; + Length : C.int; + Fromlen : aliased C.int; + + begin + Last := Nfds - 1; + loop + Get_Socket_From_Set + (EFSC'Access, S'Unchecked_Access, Last'Unchecked_Access); + + -- No more sockets in EFSC + + exit when S = -1; + + -- Check out-of-band data + + Length := + C_Recvfrom + (S, Buffer'Address, 1, Flag, + From => System.Null_Address, + Fromlen => Fromlen'Unchecked_Access); + -- Is Fromlen necessary if From is Null_Address??? + + -- If the signal is not an out-of-band data, then it + -- is a connection failure notification. + + if Length = -1 then + Remove_Socket_From_Set (Exceptfds, S); + + -- If S is present in the initial write fd set, move it from + -- exception fd set back to write fd set. Otherwise, ignore + -- this event since the user is not watching for it. + + if Writefds /= No_Fd_Set_Access + and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0) + then + Insert_Socket_In_Set (Writefds, S); + end if; + end if; + end loop; + end; + end if; + return Res; + end C_Select; + + --------------- + -- C_Sendmsg -- + --------------- + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + use type C.size_t; + + Res : C.int; + Count : C.int := 0; + + MH : Msghdr; + for MH'Address use Msg; + + Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; + for Iovec'Address use MH.Msg_Iov; + pragma Import (Ada, Iovec); + + begin + -- Windows does not provide an implementation of sendmsg(). The spec for + -- WSASendMsg() is incompatible with the data types we define, and is + -- available starting with Windows Vista and Server 2008 only. So + -- use C_Sendto instead. + + for J in Iovec'Range loop + Res := + C_Sendto + (S, + Iovec (J).Base.all'Address, + C.int (Iovec (J).Length), + Flags => Flags, + To => MH.Msg_Name, + Tolen => C.int (MH.Msg_Namelen)); + + if Res < 0 then + return System.CRTL.ssize_t (Res); + else + Count := Count + Res; + end if; + + -- Exit now if the buffer is not fully transmitted + + exit when Interfaces.C.size_t (Res) < Iovec (J).Length; + end loop; + + return System.CRTL.ssize_t (Count); + end C_Sendmsg; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + if Initialized then + WSACleanup; + Initialized := False; + end if; + end Finalize; + + ------------------------- + -- Host_Error_Messages -- + ------------------------- + + package body Host_Error_Messages is + + -- On Windows, socket and host errors share the same code space, and + -- error messages are provided by Socket_Error_Message, so the default + -- separate body for Host_Error_Messages is not used in this case. + + function Host_Error_Message (H_Errno : Integer) return String + renames Socket_Error_Message; + + end Host_Error_Messages; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Return_Value : Interfaces.C.int; + begin + if not Initialized then + Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); + pragma Assert (Return_Value = 0); + Initialized := True; + end if; + end Initialize; + + -------------------- + -- Signalling_Fds -- + -------------------- + + package body Signalling_Fds is separate; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message (Errno : Integer) return String is + use GNAT.Sockets.SOSC; + + Errm : C.Strings.chars_ptr; + + begin + case Errno is + when EINTR => Errm := Error_Messages (N_EINTR); + when EBADF => Errm := Error_Messages (N_EBADF); + when EACCES => Errm := Error_Messages (N_EACCES); + when EFAULT => Errm := Error_Messages (N_EFAULT); + when EINVAL => Errm := Error_Messages (N_EINVAL); + when EMFILE => Errm := Error_Messages (N_EMFILE); + when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK); + when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS); + when EALREADY => Errm := Error_Messages (N_EALREADY); + when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK); + when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ); + when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE); + when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE); + when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT); + when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT); + when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT); + when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP); + when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT); + when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT); + when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE); + when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL); + when ENETDOWN => Errm := Error_Messages (N_ENETDOWN); + when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH); + when ENETRESET => Errm := Error_Messages (N_ENETRESET); + when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED); + when ECONNRESET => Errm := Error_Messages (N_ECONNRESET); + when ENOBUFS => Errm := Error_Messages (N_ENOBUFS); + when EISCONN => Errm := Error_Messages (N_EISCONN); + when ENOTCONN => Errm := Error_Messages (N_ENOTCONN); + when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN); + when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS); + when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT); + when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED); + when ELOOP => Errm := Error_Messages (N_ELOOP); + when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG); + when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN); + when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH); + + -- Windows-specific error codes + + when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY); + when WSAVERNOTSUPPORTED => + Errm := Error_Messages (N_WSAVERNOTSUPPORTED); + when WSANOTINITIALISED => + Errm := Error_Messages (N_WSANOTINITIALISED); + when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON); + + -- h_errno values + + when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND); + when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN); + when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY); + when NO_DATA => Errm := Error_Messages (N_NO_DATA); + when others => Errm := Error_Messages (N_OTHERS); + end case; + + return Value (Errm); + end Socket_Error_Message; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi__mingw.ads b/gcc/ada/libgnat/g-socthi__mingw.ads new file mode 100644 index 00000000000..48f5aeb9bef --- /dev/null +++ b/gcc/ada/libgnat/g-socthi__mingw.ads @@ -0,0 +1,242 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for NT + +with Interfaces.C; + +with GNAT.Sockets.Thin_Common; + +with System; +with System.CRTL; + +package GNAT.Sockets.Thin is + + use Thin_Common; + + package C renames Interfaces.C; + + use type System.CRTL.ssize_t; + + function Socket_Errno return Integer; + -- Returns last socket error number + + procedure Set_Socket_Errno (Errno : Integer); + -- Set last socket error number + + function Socket_Error_Message (Errno : Integer) return String; + -- Returns the error message string for the error number Errno. If Errno is + -- not known, returns "Unknown system error". + + function Host_Errno return Integer; + pragma Import (C, Host_Errno, "__gnat_get_h_errno"); + -- Returns last host error number + + package Host_Error_Messages is + + function Host_Error_Message (H_Errno : Integer) return String; + -- Returns the error message string for the host error number H_Errno. + -- If H_Errno is not known, returns "Unknown system error". + + end Host_Error_Messages; + + -------------------------------- + -- Standard library functions -- + -------------------------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null access C.int) return C.int; + + function C_Bind + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + + function C_Close + (Fd : C.int) return C.int; + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + + function C_Gethostname + (Name : System.Address; + Namelen : C.int) return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : not null access C.int) return C.int; + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int; + + function C_Listen + (S : C.int; + Backlog : C.int) return C.int; + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : System.Address; + Fromlen : not null access C.int) return C.int; + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Select + (Nfds : C.int; + Readfds : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int; + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + Tolen : C.int) return C.int; + + function C_Setsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : C.int) return C.int; + + function C_Shutdown + (S : C.int; + How : C.int) return C.int; + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int; + + function C_System + (Command : System.Address) return C.int; + + function WSAStartup + (WS_Version : Interfaces.C.unsigned_short; + WSADataAddress : System.Address) return Interfaces.C.int; + + ------------------------------------------------------- + -- Signalling file descriptors for selector abortion -- + ------------------------------------------------------- + + package Signalling_Fds is + + function Create (Fds : not null access Fd_Pair) return C.int; + pragma Convention (C, Create); + -- Create a pair of connected descriptors suitable for use with C_Select + -- (used for signalling in Selector objects). + + function Read (Rsig : C.int) return C.int; + pragma Convention (C, Read); + -- Read one byte of data from rsig, the read end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + function Write (Wsig : C.int) return C.int; + pragma Convention (C, Write); + -- Write one byte of data to wsig, the write end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + procedure Close (Sig : C.int); + pragma Convention (C, Close); + -- Close one end of a pair of signalling fds (ignoring any error) + + end Signalling_Fds; + + procedure WSACleanup; + + procedure Initialize; + procedure Finalize; + +private + pragma Import (Stdcall, C_Accept, "accept"); + pragma Import (Stdcall, C_Bind, "bind"); + pragma Import (Stdcall, C_Close, "closesocket"); + pragma Import (Stdcall, C_Gethostname, "gethostname"); + pragma Import (Stdcall, C_Getpeername, "getpeername"); + pragma Import (Stdcall, C_Getsockname, "getsockname"); + pragma Import (Stdcall, C_Getsockopt, "getsockopt"); + pragma Import (Stdcall, C_Listen, "listen"); + pragma Import (Stdcall, C_Recv, "recv"); + pragma Import (Stdcall, C_Recvfrom, "recvfrom"); + pragma Import (Stdcall, C_Sendto, "sendto"); + pragma Import (Stdcall, C_Setsockopt, "setsockopt"); + pragma Import (Stdcall, C_Shutdown, "shutdown"); + pragma Import (Stdcall, C_Socket, "socket"); + pragma Import (C, C_System, "_system"); + pragma Import (Stdcall, Socket_Errno, "WSAGetLastError"); + pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError"); + pragma Import (Stdcall, WSAStartup, "WSAStartup"); + pragma Import (Stdcall, WSACleanup, "WSACleanup"); + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi__vxworks.adb b/gcc/ada/libgnat/g-socthi__vxworks.adb new file mode 100644 index 00000000000..05bedc2a1f9 --- /dev/null +++ b/gcc/ada/libgnat/g-socthi__vxworks.adb @@ -0,0 +1,487 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This version is for VxWorks + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Task_Lock; + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Sockets.Thin is + + Non_Blocking_Sockets : aliased Fd_Set; + -- When this package is initialized with Process_Blocking_IO set + -- to True, sockets are set in non-blocking mode to avoid blocking + -- the whole process when a thread wants to perform a blocking IO + -- operation. But the user can also set a socket in non-blocking + -- mode by purpose. In order to make a difference between these + -- two situations, we track the origin of non-blocking mode in + -- Non_Blocking_Sockets. If S is in Non_Blocking_Sockets, it has + -- been set in non-blocking mode by the user. + + Quantum : constant Duration := 0.2; + -- When SOSC.Thread_Blocking_IO is False, we set sockets in + -- non-blocking mode and we spend a period of time Quantum between + -- two attempts on a blocking operation. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- All these require comments ??? + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null access C.int) return C.int; + pragma Import (C, Syscall_Accept, "accept"); + + function Syscall_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + pragma Import (C, Syscall_Connect, "connect"); + + function Syscall_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Recv, "recv"); + + function Syscall_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : System.Address; + Fromlen : not null access C.int) return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Recvmsg, "recvmsg"); + + function Syscall_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Sendmsg, "sendmsg"); + + function Syscall_Send + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Send, "send"); + + function Syscall_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + Tolen : C.int) return C.int; + pragma Import (C, Syscall_Sendto, "sendto"); + + function Syscall_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int; + pragma Import (C, Syscall_Socket, "socket"); + + function Non_Blocking_Socket (S : C.int) return Boolean; + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); + + -------------- + -- C_Accept -- + -------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null access C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Res : C.int; + pragma Unreferenced (Res); + + begin + loop + R := Syscall_Accept (S, Addr, Addrlen); + exit when SOSC.Thread_Blocking_IO + or else R /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + if not SOSC.Thread_Blocking_IO + and then R /= Failure + then + -- A socket inherits the properties of its server especially + -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram + -- tracks sockets set in non-blocking mode by user. + + Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); + Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); + -- Is it OK to ignore result ??? + end if; + + return R; + end C_Accept; + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int + is + Res : C.int; + + begin + Res := Syscall_Connect (S, Name, Namelen); + + if SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EINPROGRESS + then + return Res; + end if; + + declare + WSet : aliased Fd_Set; + Now : aliased Timeval; + begin + Reset_Socket_Set (WSet'Access); + loop + Insert_Socket_In_Set (WSet'Access, S); + Now := Immediat; + Res := C_Select + (S + 1, + No_Fd_Set_Access, + WSet'Access, + No_Fd_Set_Access, + Now'Unchecked_Access); + + exit when Res > 0; + + if Res = Failure then + return Res; + end if; + + delay Quantum; + end loop; + end; + + Res := Syscall_Connect (S, Name, Namelen); + + if Res = Failure + and then Errno = SOSC.EISCONN + then + return Thin_Common.Success; + else + return Res; + end if; + end C_Connect; + + ------------------ + -- Socket_Ioctl -- + ------------------ + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int + is + begin + if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then + if Arg.all /= 0 then + Set_Non_Blocking_Socket (S, True); + end if; + end if; + + return C_Ioctl (S, Req, Arg); + end Socket_Ioctl; + + ------------ + -- C_Recv -- + ------------ + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recv (S, Msg, Len, Flags); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recv; + + ---------------- + -- C_Recvfrom -- + ---------------- + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : System.Address; + Fromlen : not null access C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + --------------- + -- C_Recvmsg -- + --------------- + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + Res : C.int; + + begin + loop + Res := Syscall_Recvmsg (S, Msg, Flags); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return System.CRTL.ssize_t (Res); + end C_Recvmsg; + + --------------- + -- C_Sendmsg -- + --------------- + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + Res : C.int; + + begin + loop + Res := Syscall_Sendmsg (S, Msg, Flags); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return System.CRTL.ssize_t (Res); + end C_Sendmsg; + + -------------- + -- C_Sendto -- + -------------- + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + Tolen : C.int) return C.int + is + use System; + + Res : C.int; + + begin + loop + if To = Null_Address then + + -- In violation of the standard sockets API, VxWorks does not + -- support sendto(2) calls on connected sockets with a null + -- destination address, so use send(2) instead in that case. + + Res := Syscall_Send (S, Msg, Len, Flags); + + -- Normal case where destination address is non-null + + else + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + end if; + + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Sendto; + + -------------- + -- C_Socket -- + -------------- + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Res : C.int; + pragma Unreferenced (Res); + + begin + R := Syscall_Socket (Domain, Typ, Protocol); + + if not SOSC.Thread_Blocking_IO + and then R /= Failure + then + -- Do not use Socket_Ioctl as this subprogram tracks sockets set + -- in non-blocking mode by user. + + Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); + -- Is it OK to ignore result ??? + Set_Non_Blocking_Socket (R, False); + end if; + + return R; + end C_Socket; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ------------------------- + -- Host_Error_Messages -- + ------------------------- + + package body Host_Error_Messages is separate; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Reset_Socket_Set (Non_Blocking_Sockets'Access); + end Initialize; + + ------------------------- + -- Non_Blocking_Socket -- + ------------------------- + + function Non_Blocking_Socket (S : C.int) return Boolean is + R : Boolean; + begin + Task_Lock.Lock; + R := (Is_Socket_In_Set (Non_Blocking_Sockets'Access, S) /= 0); + Task_Lock.Unlock; + return R; + end Non_Blocking_Socket; + + ----------------------------- + -- Set_Non_Blocking_Socket -- + ----------------------------- + + procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean) is + begin + Task_Lock.Lock; + if V then + Insert_Socket_In_Set (Non_Blocking_Sockets'Access, S); + else + Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); + end if; + + Task_Lock.Unlock; + end Set_Non_Blocking_Socket; + + -------------------- + -- Signalling_Fds -- + -------------------- + + package body Signalling_Fds is separate; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message (Errno : Integer) return String is separate; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi__vxworks.ads b/gcc/ada/libgnat/g-socthi__vxworks.ads new file mode 100644 index 00000000000..9cb4018afcb --- /dev/null +++ b/gcc/ada/libgnat/g-socthi__vxworks.ads @@ -0,0 +1,228 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the version for VxWorks + +with Interfaces.C; + +with GNAT.OS_Lib; +with GNAT.Sockets.Thin_Common; + +with System; +with System.CRTL; + +package GNAT.Sockets.Thin is + + use Thin_Common; + + package C renames Interfaces.C; + + use type System.CRTL.ssize_t; + + function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; + -- Returns last socket error number + + procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno; + -- Set last socket error number + + function Socket_Error_Message (Errno : Integer) return String; + -- Returns the error message string for the error number Errno. If Errno is + -- not known, returns "Unknown system error". + + function Host_Errno return Integer; + pragma Import (C, Host_Errno, "__gnat_get_h_errno"); + -- Returns last host error number + + package Host_Error_Messages is + + function Host_Error_Message (H_Errno : Integer) return String; + -- Returns the error message string for the host error number H_Errno. + -- If H_Errno is not known, returns "Unknown system error". + + end Host_Error_Messages; + + -------------------------------- + -- Standard library functions -- + -------------------------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null access C.int) return C.int; + + function C_Bind + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + + function C_Close + (Fd : C.int) return C.int; + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int; + + function C_Gethostname + (Name : System.Address; + Namelen : C.int) return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : not null access C.int) return C.int; + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int; + + function C_Listen + (S : C.int; + Backlog : C.int) return C.int; + + function C_Recv + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int) return C.int; + + function C_Recvfrom + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + From : System.Address; + Fromlen : not null access C.int) return C.int; + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Select + (Nfds : C.int; + Readfds : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int; + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + Tolen : C.int) return C.int; + + function C_Setsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : C.int) return C.int; + + function C_Shutdown + (S : C.int; + How : C.int) return C.int; + + function C_Socket + (Domain : C.int; + Typ : C.int; + Protocol : C.int) return C.int; + + function C_System + (Command : System.Address) return C.int; + + ------------------------------------------------------- + -- Signalling file descriptors for selector abortion -- + ------------------------------------------------------- + + package Signalling_Fds is + + function Create (Fds : not null access Fd_Pair) return C.int; + pragma Convention (C, Create); + -- Create a pair of connected descriptors suitable for use with C_Select + -- (used for signalling in Selector objects). + + function Read (Rsig : C.int) return C.int; + pragma Convention (C, Read); + -- Read one byte of data from rsig, the read end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + function Write (Wsig : C.int) return C.int; + pragma Convention (C, Write); + -- Write one byte of data to wsig, the write end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + procedure Close (Sig : C.int); + pragma Convention (C, Close); + -- Close one end of a pair of signalling fds (ignoring any error) + + end Signalling_Fds; + + procedure Initialize; + procedure Finalize; + +private + pragma Import (C, C_Bind, "bind"); + pragma Import (C, C_Close, "close"); + pragma Import (C, C_Gethostname, "gethostname"); + pragma Import (C, C_Getpeername, "getpeername"); + pragma Import (C, C_Getsockname, "getsockname"); + pragma Import (C, C_Getsockopt, "getsockopt"); + pragma Import (C, C_Listen, "listen"); + pragma Import (C, C_Select, "select"); + pragma Import (C, C_Setsockopt, "setsockopt"); + pragma Import (C, C_Shutdown, "shutdown"); + pragma Import (C, C_System, "system"); +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-soliop-lynxos.ads b/gcc/ada/libgnat/g-soliop-lynxos.ads deleted file mode 100644 index b514094f652..00000000000 --- a/gcc/ada/libgnat/g-soliop-lynxos.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is used to provide target specific linker_options for the --- support of sockets as required by the package GNAT.Sockets. - --- This is the LynxOS version of this package - --- This package should not be directly with'ed by an application program - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lbsd"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-soliop-mingw.ads b/gcc/ada/libgnat/g-soliop-mingw.ads deleted file mode 100644 index 25d5605824e..00000000000 --- a/gcc/ada/libgnat/g-soliop-mingw.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is used to provide target specific linker_options for the --- support of sockets as required by the package GNAT.Sockets. - --- This is the Windows/NT version of this package - --- This package should not be directly with'ed by an application program - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lws2_32"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-soliop-solaris.ads b/gcc/ada/libgnat/g-soliop-solaris.ads deleted file mode 100644 index 734a2bc78be..00000000000 --- a/gcc/ada/libgnat/g-soliop-solaris.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is used to provide target specific linker_options for the --- support of sockets as required by the package GNAT.Sockets. - --- This is the Solaris version of this package - --- This package should not be directly with'ed by an application program - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lnsl"); - pragma Linker_Options ("-lsocket"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-soliop__lynxos.ads b/gcc/ada/libgnat/g-soliop__lynxos.ads new file mode 100644 index 00000000000..b514094f652 --- /dev/null +++ b/gcc/ada/libgnat/g-soliop__lynxos.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is used to provide target specific linker_options for the +-- support of sockets as required by the package GNAT.Sockets. + +-- This is the LynxOS version of this package + +-- This package should not be directly with'ed by an application program + +package GNAT.Sockets.Linker_Options is +private + pragma Linker_Options ("-lbsd"); +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-soliop__mingw.ads b/gcc/ada/libgnat/g-soliop__mingw.ads new file mode 100644 index 00000000000..25d5605824e --- /dev/null +++ b/gcc/ada/libgnat/g-soliop__mingw.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is used to provide target specific linker_options for the +-- support of sockets as required by the package GNAT.Sockets. + +-- This is the Windows/NT version of this package + +-- This package should not be directly with'ed by an application program + +package GNAT.Sockets.Linker_Options is +private + pragma Linker_Options ("-lws2_32"); +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-soliop__solaris.ads b/gcc/ada/libgnat/g-soliop__solaris.ads new file mode 100644 index 00000000000..734a2bc78be --- /dev/null +++ b/gcc/ada/libgnat/g-soliop__solaris.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is used to provide target specific linker_options for the +-- support of sockets as required by the package GNAT.Sockets. + +-- This is the Solaris version of this package + +-- This package should not be directly with'ed by an application program + +package GNAT.Sockets.Linker_Options is +private + pragma Linker_Options ("-lnsl"); + pragma Linker_Options ("-lsocket"); +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-sothco-dummy.adb b/gcc/ada/libgnat/g-sothco-dummy.adb deleted file mode 100644 index cd2ec9c0adf..00000000000 --- a/gcc/ada/libgnat/g-sothco-dummy.adb +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N _ C O M M O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma No_Body; diff --git a/gcc/ada/libgnat/g-sothco-dummy.ads b/gcc/ada/libgnat/g-sothco-dummy.ads deleted file mode 100644 index 2f17b6c345f..00000000000 --- a/gcc/ada/libgnat/g-sothco-dummy.ads +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N _ C O M M O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is a placeholder for the sockets binding for platforms where --- it is not implemented. - -package GNAT.Sockets.Thin_Common is - pragma Unimplemented_Unit; -end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/libgnat/g-sothco__dummy.adb b/gcc/ada/libgnat/g-sothco__dummy.adb new file mode 100644 index 00000000000..cd2ec9c0adf --- /dev/null +++ b/gcc/ada/libgnat/g-sothco__dummy.adb @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N _ C O M M O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-sothco__dummy.ads b/gcc/ada/libgnat/g-sothco__dummy.ads new file mode 100644 index 00000000000..2f17b6c345f --- /dev/null +++ b/gcc/ada/libgnat/g-sothco__dummy.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N _ C O M M O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a placeholder for the sockets binding for platforms where +-- it is not implemented. + +package GNAT.Sockets.Thin_Common is + pragma Unimplemented_Unit; +end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/libgnat/g-stsifd-sockets.adb b/gcc/ada/libgnat/g-stsifd-sockets.adb deleted file mode 100644 index e491e1a7572..00000000000 --- a/gcc/ada/libgnat/g-stsifd-sockets.adb +++ /dev/null @@ -1,234 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N . S I G N A L L I N G _ F D S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds --- used for platforms that do not support UNIX pipes. - --- Note: this code used to be in GNAT.Sockets, but has been moved to a --- platform-specific file. It is now used only for non-UNIX platforms. - -separate (GNAT.Sockets.Thin) -package body Signalling_Fds is - - ----------- - -- Close -- - ----------- - - procedure Close (Sig : C.int) is - Res : C.int; - pragma Unreferenced (Res); - -- Res is assigned but never read, because we purposefully ignore - -- any error returned by the C_Close system call, as per the spec - -- of this procedure. - begin - Res := C_Close (Sig); - end Close; - - ------------ - -- Create -- - ------------ - - function Create (Fds : not null access Fd_Pair) return C.int is - L_Sock, R_Sock, W_Sock : C.int := Failure; - -- Listening socket, read socket and write socket - - Sin : aliased Sockaddr_In; - Len : aliased C.int; - -- Address of listening socket - - Res : C.int; - pragma Warnings (Off, Res); - -- Return status of system calls (usually ignored, hence warnings off) - - begin - Fds.all := (Read_End | Write_End => Failure); - - -- We open two signalling sockets. One of them is used to send data - -- to the other, which is included in a C_Select socket set. The - -- communication is used to force the call to C_Select to complete, - -- and the waiting task to resume its execution. - - loop - -- Retry loop, in case the C_Connect below fails - - -- Create a listening socket - - L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); - - if L_Sock = Failure then - goto Fail; - end if; - - -- Bind the socket to an available port on localhost - - Set_Family (Sin.Sin_Family, Family_Inet); - Sin.Sin_Addr.S_B1 := 127; - Sin.Sin_Addr.S_B2 := 0; - Sin.Sin_Addr.S_B3 := 0; - Sin.Sin_Addr.S_B4 := 1; - Sin.Sin_Port := 0; - - Len := C.int (Lengths (Family_Inet)); - Res := C_Bind (L_Sock, Sin'Address, Len); - - if Res = Failure then - goto Fail; - end if; - - -- Get assigned port - - Res := C_Getsockname (L_Sock, Sin'Address, Len'Access); - if Res = Failure then - goto Fail; - end if; - - -- Set socket to listen mode, with a backlog of 1 to guarantee that - -- exactly one call to connect(2) succeeds. - - Res := C_Listen (L_Sock, 1); - - if Res = Failure then - goto Fail; - end if; - - -- Create read end (client) socket - - R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); - - if R_Sock = Failure then - goto Fail; - end if; - - -- Connect listening socket - - Res := C_Connect (R_Sock, Sin'Address, Len); - - exit when Res /= Failure; - - if Socket_Errno /= SOSC.EADDRINUSE then - goto Fail; - end if; - - -- In rare cases, the above C_Bind chooses a port that is still - -- marked "in use", even though it has been closed (perhaps by some - -- other process that has already exited). This causes the above - -- C_Connect to fail with EADDRINUSE. In this case, we close the - -- ports, and loop back to try again. This mysterious Windows - -- behavior is documented. See, for example: - -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx - -- In an experiment with 2000 calls, 21 required exactly one retry, 7 - -- required two, and none required three or more. Note that no delay - -- is needed between retries; retrying C_Bind will typically produce - -- a different port. - - pragma Assert (Res = Failure - and then - Socket_Errno = SOSC.EADDRINUSE); - Res := C_Close (W_Sock); - W_Sock := Failure; - Res := C_Close (R_Sock); - R_Sock := Failure; - end loop; - - -- Since the call to connect(2) has succeeded and the backlog limit on - -- the listening socket is 1, we know that there is now exactly one - -- pending connection on L_Sock, which is the one from R_Sock. - - W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access); - - if W_Sock = Failure then - goto Fail; - end if; - - -- Set TCP_NODELAY on W_Sock, since we always want to send the data out - -- immediately. - - Set_Socket_Option - (Socket => Socket_Type (W_Sock), - Level => IP_Protocol_For_TCP_Level, - Option => (Name => No_Delay, Enabled => True)); - - -- Close listening socket (ignore exit status) - - Res := C_Close (L_Sock); - - Fds.all := (Read_End => R_Sock, Write_End => W_Sock); - - return Thin_Common.Success; - - <> - declare - Saved_Errno : constant Integer := Socket_Errno; - - begin - if W_Sock /= Failure then - Res := C_Close (W_Sock); - end if; - - if R_Sock /= Failure then - Res := C_Close (R_Sock); - end if; - - if L_Sock /= Failure then - Res := C_Close (L_Sock); - end if; - - Set_Socket_Errno (Saved_Errno); - end; - - return Failure; - end Create; - - ---------- - -- Read -- - ---------- - - function Read (Rsig : C.int) return C.int is - Buf : aliased Character; - begin - return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags); - end Read; - - ----------- - -- Write -- - ----------- - - function Write (Wsig : C.int) return C.int is - Buf : aliased Character := ASCII.NUL; - begin - return C_Sendto - (Wsig, Buf'Address, 1, - Flags => SOSC.MSG_Forced_Flags, - To => System.Null_Address, - Tolen => 0); - end Write; - -end Signalling_Fds; diff --git a/gcc/ada/libgnat/g-stsifd__sockets.adb b/gcc/ada/libgnat/g-stsifd__sockets.adb new file mode 100644 index 00000000000..e491e1a7572 --- /dev/null +++ b/gcc/ada/libgnat/g-stsifd__sockets.adb @@ -0,0 +1,234 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N . S I G N A L L I N G _ F D S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds +-- used for platforms that do not support UNIX pipes. + +-- Note: this code used to be in GNAT.Sockets, but has been moved to a +-- platform-specific file. It is now used only for non-UNIX platforms. + +separate (GNAT.Sockets.Thin) +package body Signalling_Fds is + + ----------- + -- Close -- + ----------- + + procedure Close (Sig : C.int) is + Res : C.int; + pragma Unreferenced (Res); + -- Res is assigned but never read, because we purposefully ignore + -- any error returned by the C_Close system call, as per the spec + -- of this procedure. + begin + Res := C_Close (Sig); + end Close; + + ------------ + -- Create -- + ------------ + + function Create (Fds : not null access Fd_Pair) return C.int is + L_Sock, R_Sock, W_Sock : C.int := Failure; + -- Listening socket, read socket and write socket + + Sin : aliased Sockaddr_In; + Len : aliased C.int; + -- Address of listening socket + + Res : C.int; + pragma Warnings (Off, Res); + -- Return status of system calls (usually ignored, hence warnings off) + + begin + Fds.all := (Read_End | Write_End => Failure); + + -- We open two signalling sockets. One of them is used to send data + -- to the other, which is included in a C_Select socket set. The + -- communication is used to force the call to C_Select to complete, + -- and the waiting task to resume its execution. + + loop + -- Retry loop, in case the C_Connect below fails + + -- Create a listening socket + + L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); + + if L_Sock = Failure then + goto Fail; + end if; + + -- Bind the socket to an available port on localhost + + Set_Family (Sin.Sin_Family, Family_Inet); + Sin.Sin_Addr.S_B1 := 127; + Sin.Sin_Addr.S_B2 := 0; + Sin.Sin_Addr.S_B3 := 0; + Sin.Sin_Addr.S_B4 := 1; + Sin.Sin_Port := 0; + + Len := C.int (Lengths (Family_Inet)); + Res := C_Bind (L_Sock, Sin'Address, Len); + + if Res = Failure then + goto Fail; + end if; + + -- Get assigned port + + Res := C_Getsockname (L_Sock, Sin'Address, Len'Access); + if Res = Failure then + goto Fail; + end if; + + -- Set socket to listen mode, with a backlog of 1 to guarantee that + -- exactly one call to connect(2) succeeds. + + Res := C_Listen (L_Sock, 1); + + if Res = Failure then + goto Fail; + end if; + + -- Create read end (client) socket + + R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); + + if R_Sock = Failure then + goto Fail; + end if; + + -- Connect listening socket + + Res := C_Connect (R_Sock, Sin'Address, Len); + + exit when Res /= Failure; + + if Socket_Errno /= SOSC.EADDRINUSE then + goto Fail; + end if; + + -- In rare cases, the above C_Bind chooses a port that is still + -- marked "in use", even though it has been closed (perhaps by some + -- other process that has already exited). This causes the above + -- C_Connect to fail with EADDRINUSE. In this case, we close the + -- ports, and loop back to try again. This mysterious Windows + -- behavior is documented. See, for example: + -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx + -- In an experiment with 2000 calls, 21 required exactly one retry, 7 + -- required two, and none required three or more. Note that no delay + -- is needed between retries; retrying C_Bind will typically produce + -- a different port. + + pragma Assert (Res = Failure + and then + Socket_Errno = SOSC.EADDRINUSE); + Res := C_Close (W_Sock); + W_Sock := Failure; + Res := C_Close (R_Sock); + R_Sock := Failure; + end loop; + + -- Since the call to connect(2) has succeeded and the backlog limit on + -- the listening socket is 1, we know that there is now exactly one + -- pending connection on L_Sock, which is the one from R_Sock. + + W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access); + + if W_Sock = Failure then + goto Fail; + end if; + + -- Set TCP_NODELAY on W_Sock, since we always want to send the data out + -- immediately. + + Set_Socket_Option + (Socket => Socket_Type (W_Sock), + Level => IP_Protocol_For_TCP_Level, + Option => (Name => No_Delay, Enabled => True)); + + -- Close listening socket (ignore exit status) + + Res := C_Close (L_Sock); + + Fds.all := (Read_End => R_Sock, Write_End => W_Sock); + + return Thin_Common.Success; + + <> + declare + Saved_Errno : constant Integer := Socket_Errno; + + begin + if W_Sock /= Failure then + Res := C_Close (W_Sock); + end if; + + if R_Sock /= Failure then + Res := C_Close (R_Sock); + end if; + + if L_Sock /= Failure then + Res := C_Close (L_Sock); + end if; + + Set_Socket_Errno (Saved_Errno); + end; + + return Failure; + end Create; + + ---------- + -- Read -- + ---------- + + function Read (Rsig : C.int) return C.int is + Buf : aliased Character; + begin + return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags); + end Read; + + ----------- + -- Write -- + ----------- + + function Write (Wsig : C.int) return C.int is + Buf : aliased Character := ASCII.NUL; + begin + return C_Sendto + (Wsig, Buf'Address, 1, + Flags => SOSC.MSG_Forced_Flags, + To => System.Null_Address, + Tolen => 0); + end Write; + +end Signalling_Fds; diff --git a/gcc/ada/libgnat/i-vxwork-x86.ads b/gcc/ada/libgnat/i-vxwork-x86.ads deleted file mode 100644 index ef515d57564..00000000000 --- a/gcc/ada/libgnat/i-vxwork-x86.ads +++ /dev/null @@ -1,220 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- I N T E R F A C E S . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2017, 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- -- --- 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the x86 VxWorks version of this package - --- This package provides a limited binding to the VxWorks API --- In particular, it interfaces with the VxWorks hardware interrupt --- facilities, allowing the use of low-latency direct-vectored --- interrupt handlers. Note that such handlers have a variety of --- restrictions regarding system calls and language constructs. In particular, --- the use of exception handlers and functions returning variable-length --- objects cannot be used. Less restrictive, but higher-latency handlers can --- be written using Ada protected procedures, Ada 83 style interrupt entries, --- or by signalling an Ada task from within an interrupt handler using a --- binary semaphore as described in the VxWorks Programmer's Manual. --- --- For complete documentation of the operations in this package, please --- consult the VxWorks Programmer's Manual and VxWorks Reference Manual. - -pragma Warnings (Off, "*foreign convention*"); -pragma Warnings (Off, "*add Convention pragma*"); - -with System.VxWorks; - -package Interfaces.VxWorks is - pragma Preelaborate; - - ------------------------------------------------------------------------ - -- Here is a complete example that shows how to handle the Interrupt 0x33 - -- with a direct-vectored interrupt handler in Ada using this package: - - -- with Interfaces.VxWorks; use Interfaces.VxWorks; - -- with System; - -- - -- package P is - -- - -- Count : Integer; - -- pragma Atomic (Count); - -- - -- procedure Handler (Parameter : System.Address); - -- - -- end P; - -- - -- package body P is - -- - -- procedure Handler (Parameter : System.Address) is - -- begin - -- Count := Count + 1; - -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL); - -- end Handler; - -- end P; - -- - -- with Interfaces.VxWorks; use Interfaces.VxWorks; - -- with Ada.Text_IO; use Ada.Text_IO; - -- with Ada.Interrupts; - -- with Machine_Code; use Machine_Code; - -- - -- with P; use P; - -- procedure Useint is - -- - -- -- Be sure to use a reasonable interrupt number for target board. - -- -- This one is an unreserved interrupt for the Pentium 3 BSP - -- - -- Interrupt : constant := 16#33#; - -- - -- task T; - -- - -- S : STATUS; - -- - -- task body T is - -- begin - -- loop - -- Put_Line ("Generating an interrupt..."); - -- delay 1.0; - -- - -- -- Generate interrupt, using interrupt number - -- - -- Asm ("int %0", - -- Inputs => - -- Ada.Interrupts.Interrupt_ID'Asm_Input - -- ("i", Interrupt)); - -- end loop; - -- end T; - -- - -- begin - -- S := intConnect (INUM_TO_IVEC (Interrupt), Handler'Access); - -- - -- loop - -- delay 2.0; - -- Put_Line ("value of count:" & P.Count'Img); - -- end loop; - -- end Useint; - ------------------------------------- - - subtype int is Integer; - - type STATUS is new int; - -- Equivalent of the C type STATUS - - OK : constant STATUS := 0; - ERROR : constant STATUS := -1; - - type VOIDFUNCPTR is access procedure (parameter : System.Address); - type Interrupt_Vector is new System.Address; - type Exception_Vector is new System.Address; - - function intConnect - (vector : Interrupt_Vector; - handler : VOIDFUNCPTR; - parameter : System.Address := System.Null_Address) return STATUS; - -- Binding to the C routine intConnect. Use this to set up an user handler. - -- The routine generates a wrapper around the user handler to save and - -- restore context - - function intContext return int; - -- Binding to the C routine intContext. This function returns 1 only if the - -- current execution state is in interrupt context. - - function intVecGet - (Vector : Interrupt_Vector) return VOIDFUNCPTR; - -- Binding to the C routine intVecGet. Use this to get the existing handler - -- for later restoral - - procedure intVecSet - (Vector : Interrupt_Vector; - Handler : VOIDFUNCPTR); - -- Binding to the C routine intVecSet. Use this to restore a handler - -- obtained using intVecGet - - procedure intVecGet2 - (vector : Interrupt_Vector; - pFunction : out VOIDFUNCPTR; - pIdtGate : not null access int; - pIdtSelector : not null access int); - -- Binding to the C routine intVecGet2. Use this to get the existing - -- handler for later restoral - - procedure intVecSet2 - (vector : Interrupt_Vector; - pFunction : VOIDFUNCPTR; - pIdtGate : not null access int; - pIdtSelector : not null access int); - -- Binding to the C routine intVecSet2. Use this to restore a - -- handler obtained using intVecGet2 - - function INUM_TO_IVEC (intNum : int) return Interrupt_Vector; - -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt - -- number to an interrupt vector - - procedure logMsg - (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); - -- Binding to the C routine logMsg. Note that it is the caller's - -- responsibility to ensure that fmt is a null-terminated string - -- (e.g logMsg ("Interrupt" & ASCII.NUL)) - - type FP_CONTEXT is private; - -- Floating point context save and restore. Handlers using floating point - -- must be bracketed with these calls. The pFpContext parameter should be - -- an object of type FP_CONTEXT that is declared local to the handler. - -- - -- See the VxWorks Intel Architecture Supplement regarding these routines - - procedure fppRestore (pFpContext : in out FP_CONTEXT); - -- Restore floating point context - old style - - procedure fppSave (pFpContext : in out FP_CONTEXT); - -- Save floating point context - old style - - procedure fppXrestore (pFpContext : in out FP_CONTEXT); - -- Restore floating point context - new style - - procedure fppXsave (pFpContext : in out FP_CONTEXT); - -- Save floating point context - new style - -private - - type FP_CONTEXT is new System.VxWorks.FP_CONTEXT; - -- Target-dependent floating point context type - - pragma Import (C, intConnect, "intConnect"); - pragma Import (C, intContext, "intContext"); - pragma Import (C, intVecGet, "intVecGet"); - pragma Import (C, intVecSet, "intVecSet"); - pragma Import (C, intVecGet2, "intVecGet2"); - pragma Import (C, intVecSet2, "intVecSet2"); - pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec"); - pragma Import (C, logMsg, "logMsg"); - pragma Import (C, fppRestore, "fppRestore"); - pragma Import (C, fppSave, "fppSave"); - pragma Import (C, fppXrestore, "fppXrestore"); - pragma Import (C, fppXsave, "fppXsave"); -end Interfaces.VxWorks; diff --git a/gcc/ada/libgnat/i-vxwork__x86.ads b/gcc/ada/libgnat/i-vxwork__x86.ads new file mode 100644 index 00000000000..ef515d57564 --- /dev/null +++ b/gcc/ada/libgnat/i-vxwork__x86.ads @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the x86 VxWorks version of this package + +-- This package provides a limited binding to the VxWorks API +-- In particular, it interfaces with the VxWorks hardware interrupt +-- facilities, allowing the use of low-latency direct-vectored +-- interrupt handlers. Note that such handlers have a variety of +-- restrictions regarding system calls and language constructs. In particular, +-- the use of exception handlers and functions returning variable-length +-- objects cannot be used. Less restrictive, but higher-latency handlers can +-- be written using Ada protected procedures, Ada 83 style interrupt entries, +-- or by signalling an Ada task from within an interrupt handler using a +-- binary semaphore as described in the VxWorks Programmer's Manual. +-- +-- For complete documentation of the operations in this package, please +-- consult the VxWorks Programmer's Manual and VxWorks Reference Manual. + +pragma Warnings (Off, "*foreign convention*"); +pragma Warnings (Off, "*add Convention pragma*"); + +with System.VxWorks; + +package Interfaces.VxWorks is + pragma Preelaborate; + + ------------------------------------------------------------------------ + -- Here is a complete example that shows how to handle the Interrupt 0x33 + -- with a direct-vectored interrupt handler in Ada using this package: + + -- with Interfaces.VxWorks; use Interfaces.VxWorks; + -- with System; + -- + -- package P is + -- + -- Count : Integer; + -- pragma Atomic (Count); + -- + -- procedure Handler (Parameter : System.Address); + -- + -- end P; + -- + -- package body P is + -- + -- procedure Handler (Parameter : System.Address) is + -- begin + -- Count := Count + 1; + -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL); + -- end Handler; + -- end P; + -- + -- with Interfaces.VxWorks; use Interfaces.VxWorks; + -- with Ada.Text_IO; use Ada.Text_IO; + -- with Ada.Interrupts; + -- with Machine_Code; use Machine_Code; + -- + -- with P; use P; + -- procedure Useint is + -- + -- -- Be sure to use a reasonable interrupt number for target board. + -- -- This one is an unreserved interrupt for the Pentium 3 BSP + -- + -- Interrupt : constant := 16#33#; + -- + -- task T; + -- + -- S : STATUS; + -- + -- task body T is + -- begin + -- loop + -- Put_Line ("Generating an interrupt..."); + -- delay 1.0; + -- + -- -- Generate interrupt, using interrupt number + -- + -- Asm ("int %0", + -- Inputs => + -- Ada.Interrupts.Interrupt_ID'Asm_Input + -- ("i", Interrupt)); + -- end loop; + -- end T; + -- + -- begin + -- S := intConnect (INUM_TO_IVEC (Interrupt), Handler'Access); + -- + -- loop + -- delay 2.0; + -- Put_Line ("value of count:" & P.Count'Img); + -- end loop; + -- end Useint; + ------------------------------------- + + subtype int is Integer; + + type STATUS is new int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := -1; + + type VOIDFUNCPTR is access procedure (parameter : System.Address); + type Interrupt_Vector is new System.Address; + type Exception_Vector is new System.Address; + + function intConnect + (vector : Interrupt_Vector; + handler : VOIDFUNCPTR; + parameter : System.Address := System.Null_Address) return STATUS; + -- Binding to the C routine intConnect. Use this to set up an user handler. + -- The routine generates a wrapper around the user handler to save and + -- restore context + + function intContext return int; + -- Binding to the C routine intContext. This function returns 1 only if the + -- current execution state is in interrupt context. + + function intVecGet + (Vector : Interrupt_Vector) return VOIDFUNCPTR; + -- Binding to the C routine intVecGet. Use this to get the existing handler + -- for later restoral + + procedure intVecSet + (Vector : Interrupt_Vector; + Handler : VOIDFUNCPTR); + -- Binding to the C routine intVecSet. Use this to restore a handler + -- obtained using intVecGet + + procedure intVecGet2 + (vector : Interrupt_Vector; + pFunction : out VOIDFUNCPTR; + pIdtGate : not null access int; + pIdtSelector : not null access int); + -- Binding to the C routine intVecGet2. Use this to get the existing + -- handler for later restoral + + procedure intVecSet2 + (vector : Interrupt_Vector; + pFunction : VOIDFUNCPTR; + pIdtGate : not null access int; + pIdtSelector : not null access int); + -- Binding to the C routine intVecSet2. Use this to restore a + -- handler obtained using intVecGet2 + + function INUM_TO_IVEC (intNum : int) return Interrupt_Vector; + -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt + -- number to an interrupt vector + + procedure logMsg + (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); + -- Binding to the C routine logMsg. Note that it is the caller's + -- responsibility to ensure that fmt is a null-terminated string + -- (e.g logMsg ("Interrupt" & ASCII.NUL)) + + type FP_CONTEXT is private; + -- Floating point context save and restore. Handlers using floating point + -- must be bracketed with these calls. The pFpContext parameter should be + -- an object of type FP_CONTEXT that is declared local to the handler. + -- + -- See the VxWorks Intel Architecture Supplement regarding these routines + + procedure fppRestore (pFpContext : in out FP_CONTEXT); + -- Restore floating point context - old style + + procedure fppSave (pFpContext : in out FP_CONTEXT); + -- Save floating point context - old style + + procedure fppXrestore (pFpContext : in out FP_CONTEXT); + -- Restore floating point context - new style + + procedure fppXsave (pFpContext : in out FP_CONTEXT); + -- Save floating point context - new style + +private + + type FP_CONTEXT is new System.VxWorks.FP_CONTEXT; + -- Target-dependent floating point context type + + pragma Import (C, intConnect, "intConnect"); + pragma Import (C, intContext, "intContext"); + pragma Import (C, intVecGet, "intVecGet"); + pragma Import (C, intVecSet, "intVecSet"); + pragma Import (C, intVecGet2, "intVecGet2"); + pragma Import (C, intVecSet2, "intVecSet2"); + pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec"); + pragma Import (C, logMsg, "logMsg"); + pragma Import (C, fppRestore, "fppRestore"); + pragma Import (C, fppSave, "fppSave"); + pragma Import (C, fppXrestore, "fppXrestore"); + pragma Import (C, fppXsave, "fppXsave"); +end Interfaces.VxWorks; diff --git a/gcc/ada/libgnat/s-atocou-builtin.adb b/gcc/ada/libgnat/s-atocou-builtin.adb deleted file mode 100644 index 1b5b66a031f..00000000000 --- a/gcc/ada/libgnat/s-atocou-builtin.adb +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A T O M I C _ C O U N T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements Atomic_Counter and Atomic_Unsigned operations --- for platforms where GCC supports __sync_add_and_fetch_4 and --- __sync_sub_and_fetch_4 builtins. - -package body System.Atomic_Counters is - - procedure Sync_Add_And_Fetch - (Ptr : access Atomic_Unsigned; - Value : Atomic_Unsigned); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); - - function Sync_Sub_And_Fetch - (Ptr : access Atomic_Unsigned; - Value : Atomic_Unsigned) return Atomic_Unsigned; - pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); - - --------------- - -- Decrement -- - --------------- - - procedure Decrement (Item : aliased in out Atomic_Unsigned) is - begin - if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then - null; - end if; - end Decrement; - - function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is - begin - return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0; - end Decrement; - - function Decrement (Item : in out Atomic_Counter) return Boolean is - begin - -- Note: the use of Unrestricted_Access here is required because we - -- are obtaining an access-to-volatile pointer to a non-volatile object. - -- This is not allowed for [Unchecked_]Access, but is safe in this case - -- because we know that no aliases are being created. - - return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0; - end Decrement; - - --------------- - -- Increment -- - --------------- - - procedure Increment (Item : aliased in out Atomic_Unsigned) is - begin - Sync_Add_And_Fetch (Item'Unrestricted_Access, 1); - end Increment; - - procedure Increment (Item : in out Atomic_Counter) is - begin - -- Note: the use of Unrestricted_Access here is required because we are - -- obtaining an access-to-volatile pointer to a non-volatile object. - -- This is not allowed for [Unchecked_]Access, but is safe in this case - -- because we know that no aliases are being created. - - Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1); - end Increment; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Item : out Atomic_Counter) is - begin - Item.Value := 1; - end Initialize; - - ------------ - -- Is_One -- - ------------ - - function Is_One (Item : Atomic_Counter) return Boolean is - begin - return Item.Value = 1; - end Is_One; - -end System.Atomic_Counters; diff --git a/gcc/ada/libgnat/s-atocou-x86.adb b/gcc/ada/libgnat/s-atocou-x86.adb deleted file mode 100644 index eb69a49e616..00000000000 --- a/gcc/ada/libgnat/s-atocou-x86.adb +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A T O M I C _ C O U N T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This implementation of the package for x86 processor. GCC can't generate --- code for atomic builtins for 386 CPU. Only increment/decrement instructions --- are supported, thus this implementaton uses machine code insertions to --- access the necessary instructions. - -with System.Machine_Code; - -package body System.Atomic_Counters is - - -- Add comments showing in normal asm language what we generate??? - - --------------- - -- Decrement -- - --------------- - - function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is - Aux : Boolean; - - begin - System.Machine_Code.Asm - (Template => - "lock%; decl" & ASCII.HT & "%0" & ASCII.LF & ASCII.HT - & "sete %1", - Outputs => - (Atomic_Unsigned'Asm_Output ("=m", Item), - Boolean'Asm_Output ("=qm", Aux)), - Inputs => Atomic_Unsigned'Asm_Input ("m", Item), - Volatile => True); - - return Aux; - end Decrement; - - procedure Decrement (Item : aliased in out Atomic_Unsigned) is - begin - if Decrement (Item) then - null; - end if; - end Decrement; - - function Decrement (Item : in out Atomic_Counter) return Boolean is - begin - return Decrement (Item.Value); - end Decrement; - - --------------- - -- Increment -- - --------------- - - procedure Increment (Item : aliased in out Atomic_Unsigned) is - begin - System.Machine_Code.Asm - (Template => "lock%; incl" & ASCII.HT & "%0", - Outputs => Atomic_Unsigned'Asm_Output ("=m", Item), - Inputs => Atomic_Unsigned'Asm_Input ("m", Item), - Volatile => True); - end Increment; - - procedure Increment (Item : in out Atomic_Counter) is - begin - Increment (Item.Value); - end Increment; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Item : out Atomic_Counter) is - begin - Item.Value := 1; - end Initialize; - - ------------ - -- Is_One -- - ------------ - - function Is_One (Item : Atomic_Counter) return Boolean is - begin - return Item.Value = 1; - end Is_One; - -end System.Atomic_Counters; diff --git a/gcc/ada/libgnat/s-atocou__builtin.adb b/gcc/ada/libgnat/s-atocou__builtin.adb new file mode 100644 index 00000000000..1b5b66a031f --- /dev/null +++ b/gcc/ada/libgnat/s-atocou__builtin.adb @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ C O U N T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements Atomic_Counter and Atomic_Unsigned operations +-- for platforms where GCC supports __sync_add_and_fetch_4 and +-- __sync_sub_and_fetch_4 builtins. + +package body System.Atomic_Counters is + + procedure Sync_Add_And_Fetch + (Ptr : access Atomic_Unsigned; + Value : Atomic_Unsigned); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Atomic_Unsigned; + Value : Atomic_Unsigned) return Atomic_Unsigned; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + --------------- + -- Decrement -- + --------------- + + procedure Decrement (Item : aliased in out Atomic_Unsigned) is + begin + if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then + null; + end if; + end Decrement; + + function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is + begin + return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0; + end Decrement; + + function Decrement (Item : in out Atomic_Counter) return Boolean is + begin + -- Note: the use of Unrestricted_Access here is required because we + -- are obtaining an access-to-volatile pointer to a non-volatile object. + -- This is not allowed for [Unchecked_]Access, but is safe in this case + -- because we know that no aliases are being created. + + return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0; + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Item : aliased in out Atomic_Unsigned) is + begin + Sync_Add_And_Fetch (Item'Unrestricted_Access, 1); + end Increment; + + procedure Increment (Item : in out Atomic_Counter) is + begin + -- Note: the use of Unrestricted_Access here is required because we are + -- obtaining an access-to-volatile pointer to a non-volatile object. + -- This is not allowed for [Unchecked_]Access, but is safe in this case + -- because we know that no aliases are being created. + + Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1); + end Increment; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Item : out Atomic_Counter) is + begin + Item.Value := 1; + end Initialize; + + ------------ + -- Is_One -- + ------------ + + function Is_One (Item : Atomic_Counter) return Boolean is + begin + return Item.Value = 1; + end Is_One; + +end System.Atomic_Counters; diff --git a/gcc/ada/libgnat/s-atocou__x86.adb b/gcc/ada/libgnat/s-atocou__x86.adb new file mode 100644 index 00000000000..eb69a49e616 --- /dev/null +++ b/gcc/ada/libgnat/s-atocou__x86.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ C O U N T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This implementation of the package for x86 processor. GCC can't generate +-- code for atomic builtins for 386 CPU. Only increment/decrement instructions +-- are supported, thus this implementaton uses machine code insertions to +-- access the necessary instructions. + +with System.Machine_Code; + +package body System.Atomic_Counters is + + -- Add comments showing in normal asm language what we generate??? + + --------------- + -- Decrement -- + --------------- + + function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is + Aux : Boolean; + + begin + System.Machine_Code.Asm + (Template => + "lock%; decl" & ASCII.HT & "%0" & ASCII.LF & ASCII.HT + & "sete %1", + Outputs => + (Atomic_Unsigned'Asm_Output ("=m", Item), + Boolean'Asm_Output ("=qm", Aux)), + Inputs => Atomic_Unsigned'Asm_Input ("m", Item), + Volatile => True); + + return Aux; + end Decrement; + + procedure Decrement (Item : aliased in out Atomic_Unsigned) is + begin + if Decrement (Item) then + null; + end if; + end Decrement; + + function Decrement (Item : in out Atomic_Counter) return Boolean is + begin + return Decrement (Item.Value); + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Item : aliased in out Atomic_Unsigned) is + begin + System.Machine_Code.Asm + (Template => "lock%; incl" & ASCII.HT & "%0", + Outputs => Atomic_Unsigned'Asm_Output ("=m", Item), + Inputs => Atomic_Unsigned'Asm_Input ("m", Item), + Volatile => True); + end Increment; + + procedure Increment (Item : in out Atomic_Counter) is + begin + Increment (Item.Value); + end Increment; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Item : out Atomic_Counter) is + begin + Item.Value := 1; + end Initialize; + + ------------ + -- Is_One -- + ------------ + + function Is_One (Item : Atomic_Counter) return Boolean is + begin + return Item.Value = 1; + end Is_One; + +end System.Atomic_Counters; diff --git a/gcc/ada/libgnat/s-excmac-arm.adb b/gcc/ada/libgnat/s-excmac-arm.adb deleted file mode 100644 index cfaa8535b38..00000000000 --- a/gcc/ada/libgnat/s-excmac-arm.adb +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S . M A C H I N E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exceptions.Machine is - function New_Occurrence return GNAT_GCC_Exception_Access is - Res : GNAT_GCC_Exception_Access; - begin - Res := new GNAT_GCC_Exception; - Res.Header.Class := GNAT_Exception_Class; - Res.Header.Unwinder_Cache. Reserved1 := 0; - return Res; - end New_Occurrence; - -end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac-arm.ads b/gcc/ada/libgnat/s-excmac-arm.ads deleted file mode 100644 index 195d337db1b..00000000000 --- a/gcc/ada/libgnat/s-excmac-arm.ads +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S . M A C H I N E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2013-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Declaration of the machine exception and some associated facilities. The --- machine exception is the object that is propagated by low level routines --- and that contains the Ada exception occurrence. - --- This is the version using the ARM EHABI mechanism - -with Ada.Unchecked_Conversion; -with Ada.Exceptions; - -package System.Exceptions.Machine is - pragma Preelaborate; - - ------------------------------------------------ - -- Entities to interface with the GCC runtime -- - ------------------------------------------------ - - -- Return codes from GCC runtime functions used to propagate an exception - - type Unwind_Reason_Code is - (URC_OK, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_Unused2, - URC_Unused3, - URC_Unused4, - URC_Unused5, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND, - URC_FAILURE); - - pragma Unreferenced - (URC_OK, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_Unused2, - URC_Unused3, - URC_Unused4, - URC_Unused5, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND, - URC_FAILURE); - - pragma Convention (C, Unwind_Reason_Code); - subtype Unwind_Action is Unwind_Reason_Code; - -- Phase identifiers - - type uint32_t is mod 2**32; - pragma Convention (C, uint32_t); - - type uint32_t_array is array (Natural range <>) of uint32_t; - pragma Convention (C, uint32_t_array); - - type Unwind_State is new uint32_t; - pragma Convention (C, Unwind_State); - - US_VIRTUAL_UNWIND_FRAME : constant Unwind_State := 0; - US_UNWIND_FRAME_STARTING : constant Unwind_State := 1; - US_UNWIND_FRAME_RESUME : constant Unwind_State := 2; - - pragma Unreferenced - (US_VIRTUAL_UNWIND_FRAME, - US_UNWIND_FRAME_STARTING, - US_UNWIND_FRAME_RESUME); - - -- Mandatory common header for any exception object handled by the - -- GCC unwinding runtime. - - type Exception_Class is array (0 .. 7) of Character; - - GNAT_Exception_Class : constant Exception_Class := "GNU-Ada" & ASCII.NUL; - -- "GNU-Ada\0" - - type Unwinder_Cache_Type is record - Reserved1 : uint32_t; - Reserved2 : uint32_t; - Reserved3 : uint32_t; - Reserved4 : uint32_t; - Reserved5 : uint32_t; - end record; - - type Barrier_Cache_Type is record - Sp : uint32_t; - Bitpattern : uint32_t_array (0 .. 4); - end record; - - type Cleanup_Cache_Type is record - Bitpattern : uint32_t_array (0 .. 3); - end record; - - type Pr_Cache_Type is record - Fnstart : uint32_t; - Ehtp : System.Address; - Additional : uint32_t; - Reserved1 : uint32_t; - end record; - - type Unwind_Control_Block is record - Class : Exception_Class; - Cleanup : System.Address; - - -- Caches - Unwinder_Cache : Unwinder_Cache_Type; - Barrier_Cache : Barrier_Cache_Type; - Cleanup_Cache : Cleanup_Cache_Type; - Pr_Cache : Pr_Cache_Type; - end record; - pragma Convention (C, Unwind_Control_Block); - for Unwind_Control_Block'Alignment use 8; - -- Map the GCC struct used for exception handling - - type Unwind_Control_Block_Access is access all Unwind_Control_Block; - subtype GCC_Exception_Access is Unwind_Control_Block_Access; - -- Pointer to a UCB - - procedure Unwind_DeleteException - (Ucbp : not null Unwind_Control_Block_Access); - pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); - -- Procedure to free any GCC exception - - -------------------------------------------------------------- - -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- - -------------------------------------------------------------- - - -- A GNAT exception object to be dealt with by the personality routine - -- called by the GCC unwinding runtime. - - type GNAT_GCC_Exception is record - Header : Unwind_Control_Block; - -- ABI Exception header first - - Occurrence : aliased Ada.Exceptions.Exception_Occurrence; - -- The Ada occurrence - end record; - - pragma Convention (C, GNAT_GCC_Exception); - - type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; - - function To_GCC_Exception is new - Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access); - - function To_GNAT_GCC_Exception is new - Ada.Unchecked_Conversion - (GCC_Exception_Access, GNAT_GCC_Exception_Access); - - function New_Occurrence return GNAT_GCC_Exception_Access; - -- Allocate and initialize a machine occurrence - -end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac-gcc.adb b/gcc/ada/libgnat/s-excmac-gcc.adb deleted file mode 100644 index 7d396514512..00000000000 --- a/gcc/ada/libgnat/s-excmac-gcc.adb +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S . M A C H I N E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exceptions.Machine is - function New_Occurrence return GNAT_GCC_Exception_Access is - Res : GNAT_GCC_Exception_Access; - begin - Res := new GNAT_GCC_Exception; - Res.Header := (Class => GNAT_Exception_Class, - Cleanup => Null_Address, - others => 0); - return Res; - end New_Occurrence; - -end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac-gcc.ads b/gcc/ada/libgnat/s-excmac-gcc.ads deleted file mode 100644 index dabf8b68b74..00000000000 --- a/gcc/ada/libgnat/s-excmac-gcc.ads +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S . M A C H I N E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2013-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Declaration of the machine exception and some associated facilities. The --- machine exception is the object that is propagated by low level routines --- and that contains the Ada exception occurrence. - --- This is the version using the GCC EH mechanism - -with Ada.Unchecked_Conversion; -with Ada.Exceptions; - -package System.Exceptions.Machine is - pragma Preelaborate; - - ------------------------------------------------ - -- Entities to interface with the GCC runtime -- - ------------------------------------------------ - - -- These come from "C++ ABI for Itanium: Exception handling", which is - -- the reference for GCC. - - -- Return codes from the GCC runtime functions used to propagate - -- an exception. - - type Unwind_Reason_Code is - (URC_NO_REASON, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_PHASE2_ERROR, - URC_PHASE1_ERROR, - URC_NORMAL_STOP, - URC_END_OF_STACK, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND); - - pragma Unreferenced - (URC_NO_REASON, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_PHASE2_ERROR, - URC_PHASE1_ERROR, - URC_NORMAL_STOP, - URC_END_OF_STACK, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND); - - pragma Convention (C, Unwind_Reason_Code); - - -- Phase identifiers - - type Unwind_Action is new Integer; - pragma Convention (C, Unwind_Action); - - UA_SEARCH_PHASE : constant Unwind_Action := 1; - UA_CLEANUP_PHASE : constant Unwind_Action := 2; - UA_HANDLER_FRAME : constant Unwind_Action := 4; - UA_FORCE_UNWIND : constant Unwind_Action := 8; - UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension - - pragma Unreferenced - (UA_SEARCH_PHASE, - UA_CLEANUP_PHASE, - UA_HANDLER_FRAME, - UA_FORCE_UNWIND, - UA_END_OF_STACK); - - -- Mandatory common header for any exception object handled by the - -- GCC unwinding runtime. - - type Exception_Class is mod 2 ** 64; - - GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#; - -- "GNU-Ada\0" - - type Unwind_Word is mod 2 ** System.Word_Size; - for Unwind_Word'Size use System.Word_Size; - -- Map the corresponding C type used in Unwind_Exception below - - type Unwind_Exception is record - Class : Exception_Class; - Cleanup : System.Address; - Private1 : Unwind_Word; - Private2 : Unwind_Word; - - -- Usual exception structure has only two private fields, but the SEH - -- one has six. To avoid making this file more complex, we use six - -- fields on all platforms, wasting a few bytes on some. - - Private3 : Unwind_Word; - Private4 : Unwind_Word; - Private5 : Unwind_Word; - Private6 : Unwind_Word; - end record; - pragma Convention (C, Unwind_Exception); - -- Map the GCC struct used for exception handling - - for Unwind_Exception'Alignment use Standard'Maximum_Alignment; - -- The C++ ABI mandates the common exception header to be at least - -- doubleword aligned, and the libGCC implementation actually makes it - -- maximally aligned (see unwind.h). See additional comments on the - -- alignment below. - - -- There is a subtle issue with the common header alignment, since the C - -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on - -- Standard'Maximum_Alignment, and those two values don't quite represent - -- the same concepts and so may be decoupled someday. One typical reason - -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system - -- allocator guarantees, and there are extra costs involved in allocating - -- objects aligned to such factors. - - -- To deal with the potential alignment differences between the C and Ada - -- representations, the Ada part of the whole structure is only accessed - -- by the personality routine through accessors. Ada specific fields are - -- thus always accessed through consistent layout, and we expect the - -- actual alignment to always be large enough to avoid traps from the C - -- accesses to the common header. Besides, accessors alleviate the need - -- for a C struct whole counterpart, both painful and error-prone to - -- maintain anyway. - - type GCC_Exception_Access is access all Unwind_Exception; - -- Pointer to a GCC exception - - procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access); - pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); - -- Procedure to free any GCC exception - - -------------------------------------------------------------- - -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- - -------------------------------------------------------------- - - -- A GNAT exception object to be dealt with by the personality routine - -- called by the GCC unwinding runtime. - - type GNAT_GCC_Exception is record - Header : Unwind_Exception; - -- ABI Exception header first - - Occurrence : aliased Ada.Exceptions.Exception_Occurrence; - -- The Ada occurrence - end record; - - pragma Convention (C, GNAT_GCC_Exception); - - type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; - - function To_GCC_Exception is new - Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access); - - function To_GNAT_GCC_Exception is new - Ada.Unchecked_Conversion - (GCC_Exception_Access, GNAT_GCC_Exception_Access); - - function New_Occurrence return GNAT_GCC_Exception_Access; - -- Allocate and initialize a machine occurrence - -end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac__arm.adb b/gcc/ada/libgnat/s-excmac__arm.adb new file mode 100644 index 00000000000..cfaa8535b38 --- /dev/null +++ b/gcc/ada/libgnat/s-excmac__arm.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S . M A C H I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exceptions.Machine is + function New_Occurrence return GNAT_GCC_Exception_Access is + Res : GNAT_GCC_Exception_Access; + begin + Res := new GNAT_GCC_Exception; + Res.Header.Class := GNAT_Exception_Class; + Res.Header.Unwinder_Cache. Reserved1 := 0; + return Res; + end New_Occurrence; + +end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac__arm.ads b/gcc/ada/libgnat/s-excmac__arm.ads new file mode 100644 index 00000000000..195d337db1b --- /dev/null +++ b/gcc/ada/libgnat/s-excmac__arm.ads @@ -0,0 +1,180 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S . M A C H I N E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Declaration of the machine exception and some associated facilities. The +-- machine exception is the object that is propagated by low level routines +-- and that contains the Ada exception occurrence. + +-- This is the version using the ARM EHABI mechanism + +with Ada.Unchecked_Conversion; +with Ada.Exceptions; + +package System.Exceptions.Machine is + pragma Preelaborate; + + ------------------------------------------------ + -- Entities to interface with the GCC runtime -- + ------------------------------------------------ + + -- Return codes from GCC runtime functions used to propagate an exception + + type Unwind_Reason_Code is + (URC_OK, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_Unused2, + URC_Unused3, + URC_Unused4, + URC_Unused5, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND, + URC_FAILURE); + + pragma Unreferenced + (URC_OK, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_Unused2, + URC_Unused3, + URC_Unused4, + URC_Unused5, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND, + URC_FAILURE); + + pragma Convention (C, Unwind_Reason_Code); + subtype Unwind_Action is Unwind_Reason_Code; + -- Phase identifiers + + type uint32_t is mod 2**32; + pragma Convention (C, uint32_t); + + type uint32_t_array is array (Natural range <>) of uint32_t; + pragma Convention (C, uint32_t_array); + + type Unwind_State is new uint32_t; + pragma Convention (C, Unwind_State); + + US_VIRTUAL_UNWIND_FRAME : constant Unwind_State := 0; + US_UNWIND_FRAME_STARTING : constant Unwind_State := 1; + US_UNWIND_FRAME_RESUME : constant Unwind_State := 2; + + pragma Unreferenced + (US_VIRTUAL_UNWIND_FRAME, + US_UNWIND_FRAME_STARTING, + US_UNWIND_FRAME_RESUME); + + -- Mandatory common header for any exception object handled by the + -- GCC unwinding runtime. + + type Exception_Class is array (0 .. 7) of Character; + + GNAT_Exception_Class : constant Exception_Class := "GNU-Ada" & ASCII.NUL; + -- "GNU-Ada\0" + + type Unwinder_Cache_Type is record + Reserved1 : uint32_t; + Reserved2 : uint32_t; + Reserved3 : uint32_t; + Reserved4 : uint32_t; + Reserved5 : uint32_t; + end record; + + type Barrier_Cache_Type is record + Sp : uint32_t; + Bitpattern : uint32_t_array (0 .. 4); + end record; + + type Cleanup_Cache_Type is record + Bitpattern : uint32_t_array (0 .. 3); + end record; + + type Pr_Cache_Type is record + Fnstart : uint32_t; + Ehtp : System.Address; + Additional : uint32_t; + Reserved1 : uint32_t; + end record; + + type Unwind_Control_Block is record + Class : Exception_Class; + Cleanup : System.Address; + + -- Caches + Unwinder_Cache : Unwinder_Cache_Type; + Barrier_Cache : Barrier_Cache_Type; + Cleanup_Cache : Cleanup_Cache_Type; + Pr_Cache : Pr_Cache_Type; + end record; + pragma Convention (C, Unwind_Control_Block); + for Unwind_Control_Block'Alignment use 8; + -- Map the GCC struct used for exception handling + + type Unwind_Control_Block_Access is access all Unwind_Control_Block; + subtype GCC_Exception_Access is Unwind_Control_Block_Access; + -- Pointer to a UCB + + procedure Unwind_DeleteException + (Ucbp : not null Unwind_Control_Block_Access); + pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); + -- Procedure to free any GCC exception + + -------------------------------------------------------------- + -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- + -------------------------------------------------------------- + + -- A GNAT exception object to be dealt with by the personality routine + -- called by the GCC unwinding runtime. + + type GNAT_GCC_Exception is record + Header : Unwind_Control_Block; + -- ABI Exception header first + + Occurrence : aliased Ada.Exceptions.Exception_Occurrence; + -- The Ada occurrence + end record; + + pragma Convention (C, GNAT_GCC_Exception); + + type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; + + function To_GCC_Exception is new + Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access); + + function To_GNAT_GCC_Exception is new + Ada.Unchecked_Conversion + (GCC_Exception_Access, GNAT_GCC_Exception_Access); + + function New_Occurrence return GNAT_GCC_Exception_Access; + -- Allocate and initialize a machine occurrence + +end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac__gcc.adb b/gcc/ada/libgnat/s-excmac__gcc.adb new file mode 100644 index 00000000000..7d396514512 --- /dev/null +++ b/gcc/ada/libgnat/s-excmac__gcc.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S . M A C H I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exceptions.Machine is + function New_Occurrence return GNAT_GCC_Exception_Access is + Res : GNAT_GCC_Exception_Access; + begin + Res := new GNAT_GCC_Exception; + Res.Header := (Class => GNAT_Exception_Class, + Cleanup => Null_Address, + others => 0); + return Res; + end New_Occurrence; + +end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac__gcc.ads b/gcc/ada/libgnat/s-excmac__gcc.ads new file mode 100644 index 00000000000..dabf8b68b74 --- /dev/null +++ b/gcc/ada/libgnat/s-excmac__gcc.ads @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S . M A C H I N E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Declaration of the machine exception and some associated facilities. The +-- machine exception is the object that is propagated by low level routines +-- and that contains the Ada exception occurrence. + +-- This is the version using the GCC EH mechanism + +with Ada.Unchecked_Conversion; +with Ada.Exceptions; + +package System.Exceptions.Machine is + pragma Preelaborate; + + ------------------------------------------------ + -- Entities to interface with the GCC runtime -- + ------------------------------------------------ + + -- These come from "C++ ABI for Itanium: Exception handling", which is + -- the reference for GCC. + + -- Return codes from the GCC runtime functions used to propagate + -- an exception. + + type Unwind_Reason_Code is + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + pragma Unreferenced + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + pragma Convention (C, Unwind_Reason_Code); + + -- Phase identifiers + + type Unwind_Action is new Integer; + pragma Convention (C, Unwind_Action); + + UA_SEARCH_PHASE : constant Unwind_Action := 1; + UA_CLEANUP_PHASE : constant Unwind_Action := 2; + UA_HANDLER_FRAME : constant Unwind_Action := 4; + UA_FORCE_UNWIND : constant Unwind_Action := 8; + UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension + + pragma Unreferenced + (UA_SEARCH_PHASE, + UA_CLEANUP_PHASE, + UA_HANDLER_FRAME, + UA_FORCE_UNWIND, + UA_END_OF_STACK); + + -- Mandatory common header for any exception object handled by the + -- GCC unwinding runtime. + + type Exception_Class is mod 2 ** 64; + + GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#; + -- "GNU-Ada\0" + + type Unwind_Word is mod 2 ** System.Word_Size; + for Unwind_Word'Size use System.Word_Size; + -- Map the corresponding C type used in Unwind_Exception below + + type Unwind_Exception is record + Class : Exception_Class; + Cleanup : System.Address; + Private1 : Unwind_Word; + Private2 : Unwind_Word; + + -- Usual exception structure has only two private fields, but the SEH + -- one has six. To avoid making this file more complex, we use six + -- fields on all platforms, wasting a few bytes on some. + + Private3 : Unwind_Word; + Private4 : Unwind_Word; + Private5 : Unwind_Word; + Private6 : Unwind_Word; + end record; + pragma Convention (C, Unwind_Exception); + -- Map the GCC struct used for exception handling + + for Unwind_Exception'Alignment use Standard'Maximum_Alignment; + -- The C++ ABI mandates the common exception header to be at least + -- doubleword aligned, and the libGCC implementation actually makes it + -- maximally aligned (see unwind.h). See additional comments on the + -- alignment below. + + -- There is a subtle issue with the common header alignment, since the C + -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on + -- Standard'Maximum_Alignment, and those two values don't quite represent + -- the same concepts and so may be decoupled someday. One typical reason + -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system + -- allocator guarantees, and there are extra costs involved in allocating + -- objects aligned to such factors. + + -- To deal with the potential alignment differences between the C and Ada + -- representations, the Ada part of the whole structure is only accessed + -- by the personality routine through accessors. Ada specific fields are + -- thus always accessed through consistent layout, and we expect the + -- actual alignment to always be large enough to avoid traps from the C + -- accesses to the common header. Besides, accessors alleviate the need + -- for a C struct whole counterpart, both painful and error-prone to + -- maintain anyway. + + type GCC_Exception_Access is access all Unwind_Exception; + -- Pointer to a GCC exception + + procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access); + pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); + -- Procedure to free any GCC exception + + -------------------------------------------------------------- + -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- + -------------------------------------------------------------- + + -- A GNAT exception object to be dealt with by the personality routine + -- called by the GCC unwinding runtime. + + type GNAT_GCC_Exception is record + Header : Unwind_Exception; + -- ABI Exception header first + + Occurrence : aliased Ada.Exceptions.Exception_Occurrence; + -- The Ada occurrence + end record; + + pragma Convention (C, GNAT_GCC_Exception); + + type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; + + function To_GCC_Exception is new + Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access); + + function To_GNAT_GCC_Exception is new + Ada.Unchecked_Conversion + (GCC_Exception_Access, GNAT_GCC_Exception_Access); + + function New_Occurrence return GNAT_GCC_Exception_Access; + -- Allocate and initialize a machine occurrence + +end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-flocon-none.adb b/gcc/ada/libgnat/s-flocon-none.adb deleted file mode 100644 index 582623797a3..00000000000 --- a/gcc/ada/libgnat/s-flocon-none.adb +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F L O A T _ C O N T R O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This implementation does nothing and can be used when the floating point --- unit is fully under control. - -package body System.Float_Control is - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - null; - end Reset; - -end System.Float_Control; diff --git a/gcc/ada/libgnat/s-flocon__none.adb b/gcc/ada/libgnat/s-flocon__none.adb new file mode 100644 index 00000000000..582623797a3 --- /dev/null +++ b/gcc/ada/libgnat/s-flocon__none.adb @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F L O A T _ C O N T R O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This implementation does nothing and can be used when the floating point +-- unit is fully under control. + +package body System.Float_Control is + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + null; + end Reset; + +end System.Float_Control; diff --git a/gcc/ada/libgnat/s-gloloc-mingw.adb b/gcc/ada/libgnat/s-gloloc-mingw.adb deleted file mode 100644 index 404f1c89a0c..00000000000 --- a/gcc/ada/libgnat/s-gloloc-mingw.adb +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . G L O B A L _ L O C K S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This implementation is specific to NT - -with System.OS_Interface; -with System.Task_Lock; -with System.Win32; - -with Interfaces.C.Strings; - -package body System.Global_Locks is - - package TSL renames System.Task_Lock; - package OSI renames System.OS_Interface; - package ICS renames Interfaces.C.Strings; - - subtype Lock_File_Entry is Win32.HANDLE; - - Last_Lock : Lock_Type := Null_Lock; - Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; - - ----------------- - -- Create_Lock -- - ----------------- - - procedure Create_Lock (Lock : out Lock_Type; Name : String) is - L : Lock_Type; - - begin - TSL.Lock; - Last_Lock := Last_Lock + 1; - L := Last_Lock; - TSL.Unlock; - - if L > Lock_Table'Last then - raise Lock_Error; - end if; - - Lock_Table (L) := - OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name)); - Lock := L; - end Create_Lock; - - ------------------ - -- Acquire_Lock -- - ------------------ - - procedure Acquire_Lock (Lock : in out Lock_Type) is - use type Win32.DWORD; - - Res : Win32.DWORD; - - begin - Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite); - - if Res = OSI.WAIT_FAILED then - raise Lock_Error; - end if; - end Acquire_Lock; - - ------------------ - -- Release_Lock -- - ------------------ - - procedure Release_Lock (Lock : in out Lock_Type) is - use type Win32.BOOL; - - Res : Win32.BOOL; - - begin - Res := OSI.ReleaseMutex (Lock_Table (Lock)); - - if Res = Win32.FALSE then - raise Lock_Error; - end if; - end Release_Lock; - -end System.Global_Locks; diff --git a/gcc/ada/libgnat/s-gloloc__mingw.adb b/gcc/ada/libgnat/s-gloloc__mingw.adb new file mode 100644 index 00000000000..404f1c89a0c --- /dev/null +++ b/gcc/ada/libgnat/s-gloloc__mingw.adb @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . G L O B A L _ L O C K S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This implementation is specific to NT + +with System.OS_Interface; +with System.Task_Lock; +with System.Win32; + +with Interfaces.C.Strings; + +package body System.Global_Locks is + + package TSL renames System.Task_Lock; + package OSI renames System.OS_Interface; + package ICS renames Interfaces.C.Strings; + + subtype Lock_File_Entry is Win32.HANDLE; + + Last_Lock : Lock_Type := Null_Lock; + Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; + + ----------------- + -- Create_Lock -- + ----------------- + + procedure Create_Lock (Lock : out Lock_Type; Name : String) is + L : Lock_Type; + + begin + TSL.Lock; + Last_Lock := Last_Lock + 1; + L := Last_Lock; + TSL.Unlock; + + if L > Lock_Table'Last then + raise Lock_Error; + end if; + + Lock_Table (L) := + OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name)); + Lock := L; + end Create_Lock; + + ------------------ + -- Acquire_Lock -- + ------------------ + + procedure Acquire_Lock (Lock : in out Lock_Type) is + use type Win32.DWORD; + + Res : Win32.DWORD; + + begin + Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite); + + if Res = OSI.WAIT_FAILED then + raise Lock_Error; + end if; + end Acquire_Lock; + + ------------------ + -- Release_Lock -- + ------------------ + + procedure Release_Lock (Lock : in out Lock_Type) is + use type Win32.BOOL; + + Res : Win32.BOOL; + + begin + Res := OSI.ReleaseMutex (Lock_Table (Lock)); + + if Res = Win32.FALSE then + raise Lock_Error; + end if; + end Release_Lock; + +end System.Global_Locks; diff --git a/gcc/ada/libgnat/s-memory-mingw.adb b/gcc/ada/libgnat/s-memory-mingw.adb deleted file mode 100644 index f7e5ff813dc..00000000000 --- a/gcc/ada/libgnat/s-memory-mingw.adb +++ /dev/null @@ -1,221 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version provides ways to limit the amount of used memory for systems --- that do not have OS support for that. - --- The amount of available memory available for dynamic allocation is limited --- by setting the environment variable GNAT_MEMORY_LIMIT to the number of --- kilobytes that can be used. --- --- Windows is currently using this version. - -with Ada.Exceptions; -with System.Soft_Links; - -package body System.Memory is - - use Ada.Exceptions; - use System.Soft_Links; - - function c_malloc (Size : size_t) return System.Address; - pragma Import (C, c_malloc, "malloc"); - - procedure c_free (Ptr : System.Address); - pragma Import (C, c_free, "free"); - - function c_realloc - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, c_realloc, "realloc"); - - function msize (Ptr : System.Address) return size_t; - pragma Import (C, msize, "_msize"); - - function getenv (Str : String) return System.Address; - pragma Import (C, getenv); - - function atoi (Str : System.Address) return Integer; - pragma Import (C, atoi); - - Available_Memory : size_t := 0; - -- Amount of memory that is available for heap allocations. - -- A value of 0 means that the amount is not yet initialized. - - Msize_Accuracy : constant := 4096; - -- Defines the amount of memory to add to requested allocation sizes, - -- because malloc may return a bigger block than requested. As msize - -- is used when by Free, it must be used on allocation as well. To - -- prevent underflow of available_memory we need to use a reserve. - - procedure Check_Available_Memory (Size : size_t); - -- This routine must be called while holding the task lock. When the - -- memory limit is not yet initialized, it will be set to the value of - -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that - -- does not exist. If the size is larger than the amount of available - -- memory, the task lock will be freed and a storage_error exception - -- will be raised. - - ----------- - -- Alloc -- - ----------- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - Lock_Task.all; - - if Actual_Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_malloc (Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory - msize (Result); - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc; - - ---------------------------- - -- Check_Available_Memory -- - ---------------------------- - - procedure Check_Available_Memory (Size : size_t) is - Gnat_Memory_Limit : System.Address; - - begin - if Available_Memory = 0 then - - -- The amount of available memory hasn't been initialized yet - - Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL); - - if Gnat_Memory_Limit /= System.Null_Address then - Available_Memory := - size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy; - else - Available_Memory := size_t'Last; - end if; - end if; - - if Size >= Available_Memory then - - -- There is a memory overflow - - Unlock_Task.all; - Raise_Exception - (Storage_Error'Identity, "heap memory limit exceeded"); - end if; - end Check_Available_Memory; - - ---------- - -- Free -- - ---------- - - procedure Free (Ptr : System.Address) is - begin - Lock_Task.all; - - if Ptr /= System.Null_Address then - Available_Memory := Available_Memory + msize (Ptr); - end if; - - c_free (Ptr); - - Unlock_Task.all; - end Free; - - ------------- - -- Realloc -- - ------------- - - function Realloc - (Ptr : System.Address; - Size : size_t) - return System.Address - is - Result : System.Address; - Actual_Size : constant size_t := Size; - Old_Size : size_t; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - Lock_Task.all; - - Old_Size := msize (Ptr); - - -- Conservative check - no need to try to be precise here - - if Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_realloc (Ptr, Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory + Old_Size - msize (Result); - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc; - -end System.Memory; diff --git a/gcc/ada/libgnat/s-memory__mingw.adb b/gcc/ada/libgnat/s-memory__mingw.adb new file mode 100644 index 00000000000..f7e5ff813dc --- /dev/null +++ b/gcc/ada/libgnat/s-memory__mingw.adb @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version provides ways to limit the amount of used memory for systems +-- that do not have OS support for that. + +-- The amount of available memory available for dynamic allocation is limited +-- by setting the environment variable GNAT_MEMORY_LIMIT to the number of +-- kilobytes that can be used. +-- +-- Windows is currently using this version. + +with Ada.Exceptions; +with System.Soft_Links; + +package body System.Memory is + + use Ada.Exceptions; + use System.Soft_Links; + + function c_malloc (Size : size_t) return System.Address; + pragma Import (C, c_malloc, "malloc"); + + procedure c_free (Ptr : System.Address); + pragma Import (C, c_free, "free"); + + function c_realloc + (Ptr : System.Address; Size : size_t) return System.Address; + pragma Import (C, c_realloc, "realloc"); + + function msize (Ptr : System.Address) return size_t; + pragma Import (C, msize, "_msize"); + + function getenv (Str : String) return System.Address; + pragma Import (C, getenv); + + function atoi (Str : System.Address) return Integer; + pragma Import (C, atoi); + + Available_Memory : size_t := 0; + -- Amount of memory that is available for heap allocations. + -- A value of 0 means that the amount is not yet initialized. + + Msize_Accuracy : constant := 4096; + -- Defines the amount of memory to add to requested allocation sizes, + -- because malloc may return a bigger block than requested. As msize + -- is used when by Free, it must be used on allocation as well. To + -- prevent underflow of available_memory we need to use a reserve. + + procedure Check_Available_Memory (Size : size_t); + -- This routine must be called while holding the task lock. When the + -- memory limit is not yet initialized, it will be set to the value of + -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that + -- does not exist. If the size is larger than the amount of available + -- memory, the task lock will be freed and a storage_error exception + -- will be raised. + + ----------- + -- Alloc -- + ----------- + + function Alloc (Size : size_t) return System.Address is + Result : System.Address; + Actual_Size : size_t := Size; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + -- Change size from zero to non-zero. We still want a proper pointer + -- for the zero case because pointers to zero length objects have to + -- be distinct, but we can't just go ahead and allocate zero bytes, + -- since some malloc's return zero for a zero argument. + + if Size = 0 then + Actual_Size := 1; + end if; + + Lock_Task.all; + + if Actual_Size + Msize_Accuracy >= Available_Memory then + Check_Available_Memory (Size + Msize_Accuracy); + end if; + + Result := c_malloc (Actual_Size); + + if Result /= System.Null_Address then + Available_Memory := Available_Memory - msize (Result); + end if; + + Unlock_Task.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Alloc; + + ---------------------------- + -- Check_Available_Memory -- + ---------------------------- + + procedure Check_Available_Memory (Size : size_t) is + Gnat_Memory_Limit : System.Address; + + begin + if Available_Memory = 0 then + + -- The amount of available memory hasn't been initialized yet + + Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL); + + if Gnat_Memory_Limit /= System.Null_Address then + Available_Memory := + size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy; + else + Available_Memory := size_t'Last; + end if; + end if; + + if Size >= Available_Memory then + + -- There is a memory overflow + + Unlock_Task.all; + Raise_Exception + (Storage_Error'Identity, "heap memory limit exceeded"); + end if; + end Check_Available_Memory; + + ---------- + -- Free -- + ---------- + + procedure Free (Ptr : System.Address) is + begin + Lock_Task.all; + + if Ptr /= System.Null_Address then + Available_Memory := Available_Memory + msize (Ptr); + end if; + + c_free (Ptr); + + Unlock_Task.all; + end Free; + + ------------- + -- Realloc -- + ------------- + + function Realloc + (Ptr : System.Address; + Size : size_t) + return System.Address + is + Result : System.Address; + Actual_Size : constant size_t := Size; + Old_Size : size_t; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + Lock_Task.all; + + Old_Size := msize (Ptr); + + -- Conservative check - no need to try to be precise here + + if Size + Msize_Accuracy >= Available_Memory then + Check_Available_Memory (Size + Msize_Accuracy); + end if; + + Result := c_realloc (Ptr, Actual_Size); + + if Result /= System.Null_Address then + Available_Memory := Available_Memory + Old_Size - msize (Result); + end if; + + Unlock_Task.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Realloc; + +end System.Memory; diff --git a/gcc/ada/libgnat/s-mmauni-long.ads b/gcc/ada/libgnat/s-mmauni-long.ads deleted file mode 100644 index 8a1f94a1ccb..00000000000 --- a/gcc/ada/libgnat/s-mmauni-long.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . U N I X -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2017, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Declaration of off_t/mmap/munmap. This particular implementation --- supposes off_t is long. - -with System.OS_Lib; -with Interfaces.C; - -package System.Mmap.Unix is - - type Mmap_Prot is new Interfaces.C.int; --- PROT_NONE : constant Mmap_Prot := 16#00#; --- PROT_EXEC : constant Mmap_Prot := 16#04#; - PROT_READ : constant Mmap_Prot := 16#01#; - PROT_WRITE : constant Mmap_Prot := 16#02#; - - type Mmap_Flags is new Interfaces.C.int; --- MAP_NONE : constant Mmap_Flags := 16#00#; --- MAP_FIXED : constant Mmap_Flags := 16#10#; - MAP_SHARED : constant Mmap_Flags := 16#01#; - MAP_PRIVATE : constant Mmap_Flags := 16#02#; - - type off_t is new Long_Integer; - - function Mmap (Start : Address := Null_Address; - Length : Interfaces.C.size_t; - Prot : Mmap_Prot := PROT_READ; - Flags : Mmap_Flags := MAP_PRIVATE; - Fd : System.OS_Lib.File_Descriptor; - Offset : off_t) return Address; - pragma Import (C, Mmap, "mmap"); - - function Munmap (Start : Address; - Length : Interfaces.C.size_t) return Integer; - pragma Import (C, Munmap, "munmap"); - - function Is_Mapping_Available return Boolean is (True); - -- Wheter memory mapping is actually available on this system. It is an - -- error to use Create_Mapping and Dispose_Mapping if this is False. -end System.Mmap.Unix; diff --git a/gcc/ada/libgnat/s-mmauni__long.ads b/gcc/ada/libgnat/s-mmauni__long.ads new file mode 100644 index 00000000000..8a1f94a1ccb --- /dev/null +++ b/gcc/ada/libgnat/s-mmauni__long.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . U N I X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Declaration of off_t/mmap/munmap. This particular implementation +-- supposes off_t is long. + +with System.OS_Lib; +with Interfaces.C; + +package System.Mmap.Unix is + + type Mmap_Prot is new Interfaces.C.int; +-- PROT_NONE : constant Mmap_Prot := 16#00#; +-- PROT_EXEC : constant Mmap_Prot := 16#04#; + PROT_READ : constant Mmap_Prot := 16#01#; + PROT_WRITE : constant Mmap_Prot := 16#02#; + + type Mmap_Flags is new Interfaces.C.int; +-- MAP_NONE : constant Mmap_Flags := 16#00#; +-- MAP_FIXED : constant Mmap_Flags := 16#10#; + MAP_SHARED : constant Mmap_Flags := 16#01#; + MAP_PRIVATE : constant Mmap_Flags := 16#02#; + + type off_t is new Long_Integer; + + function Mmap (Start : Address := Null_Address; + Length : Interfaces.C.size_t; + Prot : Mmap_Prot := PROT_READ; + Flags : Mmap_Flags := MAP_PRIVATE; + Fd : System.OS_Lib.File_Descriptor; + Offset : off_t) return Address; + pragma Import (C, Mmap, "mmap"); + + function Munmap (Start : Address; + Length : Interfaces.C.size_t) return Integer; + pragma Import (C, Munmap, "munmap"); + + function Is_Mapping_Available return Boolean is (True); + -- Wheter memory mapping is actually available on this system. It is an + -- error to use Create_Mapping and Dispose_Mapping if this is False. +end System.Mmap.Unix; diff --git a/gcc/ada/libgnat/s-mmosin-mingw.adb b/gcc/ada/libgnat/s-mmosin-mingw.adb deleted file mode 100644 index f32e540ebfe..00000000000 --- a/gcc/ada/libgnat/s-mmosin-mingw.adb +++ /dev/null @@ -1,345 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2017, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with System.Strings; use System.Strings; - -with System.OS_Lib; -pragma Unreferenced (System.OS_Lib); --- Only used to generate same runtime dependencies and same binder file on --- GNU/Linux and Windows. - -package body System.Mmap.OS_Interface is - - use Win; - - function Align - (Addr : File_Size) return File_Size; - -- Align some offset/length to the lowest page boundary - - function Open_Common - (Filename : String; - Use_Mmap_If_Available : Boolean; - Write : Boolean) return System_File; - - function From_UTF8 (Path : String) return Wide_String; - -- Convert from UTF-8 to Wide_String - - --------------- - -- From_UTF8 -- - --------------- - - function From_UTF8 (Path : String) return Wide_String is - function MultiByteToWideChar - (Codepage : Interfaces.C.unsigned; - Flags : Interfaces.C.unsigned; - Mbstr : Address; - Mb : Natural; - Wcstr : Address; - Wc : Natural) return Integer; - pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar"); - - Current_Codepage : Interfaces.C.unsigned; - pragma Import (C, Current_Codepage, "__gnat_current_codepage"); - - Len : Natural; - begin - -- Compute length of the result - Len := MultiByteToWideChar - (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0); - if Len = 0 then - raise Constraint_Error; - end if; - - declare - -- Declare result - Res : Wide_String (1 .. Len); - begin - -- And compute it - Len := MultiByteToWideChar - (Current_Codepage, 0, - Path'Address, Path'Length, - Res'Address, Len); - if Len = 0 then - raise Constraint_Error; - end if; - return Res; - end; - end From_UTF8; - - ----------------- - -- Open_Common -- - ----------------- - - function Open_Common - (Filename : String; - Use_Mmap_If_Available : Boolean; - Write : Boolean) return System_File - is - dwDesiredAccess, dwShareMode : DWORD; - PageFlags : DWORD; - - W_Filename : constant Wide_String := - From_UTF8 (Filename) & Wide_Character'Val (0); - File_Handle, Mapping_Handle : HANDLE; - - SizeH : aliased DWORD; - Size : File_Size; - begin - if Write then - dwDesiredAccess := GENERIC_READ + GENERIC_WRITE; - dwShareMode := 0; - PageFlags := Win.PAGE_READWRITE; - else - dwDesiredAccess := GENERIC_READ; - dwShareMode := Win.FILE_SHARE_READ; - PageFlags := Win.PAGE_READONLY; - end if; - - -- Actually open the file - - File_Handle := CreateFile - (W_Filename'Address, dwDesiredAccess, dwShareMode, - null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0); - - if File_Handle = Win.INVALID_HANDLE_VALUE then - return Invalid_System_File; - end if; - - -- Compute its size - - Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access)); - - if Size = Win.INVALID_FILE_SIZE then - return Invalid_System_File; - end if; - - if SizeH /= 0 and then File_Size'Size > 32 then - Size := Size + (File_Size (SizeH) * 2 ** 32); - end if; - - -- Then create a mapping object, if needed. On Win32, file memory - -- mapping is always available. - - if Use_Mmap_If_Available then - Mapping_Handle := - Win.CreateFileMapping - (File_Handle, null, PageFlags, - 0, DWORD (Size), Standard.System.Null_Address); - else - Mapping_Handle := Win.INVALID_HANDLE_VALUE; - end if; - - return - (Handle => File_Handle, - Mapped => Use_Mmap_If_Available, - Mapping_Handle => Mapping_Handle, - Write => Write, - Length => Size); - end Open_Common; - - --------------- - -- Open_Read -- - --------------- - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File is - begin - return Open_Common (Filename, Use_Mmap_If_Available, False); - end Open_Read; - - ---------------- - -- Open_Write -- - ---------------- - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File is - begin - return Open_Common (Filename, Use_Mmap_If_Available, True); - end Open_Write; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out System_File) is - Ignored : BOOL; - pragma Unreferenced (Ignored); - begin - Ignored := CloseHandle (File.Mapping_Handle); - Ignored := CloseHandle (File.Handle); - File.Handle := Win.INVALID_HANDLE_VALUE; - File.Mapping_Handle := Win.INVALID_HANDLE_VALUE; - end Close; - - -------------------- - -- Read_From_Disk -- - -------------------- - - function Read_From_Disk - (File : System_File; - Offset, Length : File_Size) return System.Strings.String_Access - is - Buffer : String_Access := new String (1 .. Integer (Length)); - - Pos : DWORD; - NbRead : aliased DWORD; - pragma Unreferenced (Pos); - begin - Pos := Win.SetFilePointer - (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); - - if Win.ReadFile - (File.Handle, Buffer.all'Address, - DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE - then - System.Strings.Free (Buffer); - raise Ada.IO_Exceptions.Device_Error; - end if; - return Buffer; - end Read_From_Disk; - - ------------------- - -- Write_To_Disk -- - ------------------- - - procedure Write_To_Disk - (File : System_File; - Offset, Length : File_Size; - Buffer : System.Strings.String_Access) - is - Pos : DWORD; - NbWritten : aliased DWORD; - pragma Unreferenced (Pos); - begin - pragma Assert (File.Write); - Pos := Win.SetFilePointer - (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); - - if Win.WriteFile - (File.Handle, Buffer.all'Address, - DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE - then - raise Ada.IO_Exceptions.Device_Error; - end if; - end Write_To_Disk; - - -------------------- - -- Create_Mapping -- - -------------------- - - procedure Create_Mapping - (File : System_File; - Offset, Length : in out File_Size; - Mutable : Boolean; - Mapping : out System_Mapping) - is - Flags : DWORD; - begin - if File.Write then - Flags := Win.FILE_MAP_WRITE; - elsif Mutable then - Flags := Win.FILE_MAP_COPY; - else - Flags := Win.FILE_MAP_READ; - end if; - - -- Adjust offset and mapping length to account for the required - -- alignment of offset on page boundary. - - declare - Queried_Offset : constant File_Size := Offset; - begin - Offset := Align (Offset); - - -- First extend the length to compensate the offset shift, then align - -- it on the upper page boundary, so that the whole queried area is - -- covered. - - Length := Length + Queried_Offset - Offset; - Length := Align (Length + Get_Page_Size - 1); - - -- But do not exceed the length of the file - if Offset + Length > File.Length then - Length := File.Length - Offset; - end if; - end; - - if Length > File_Size (Integer'Last) then - raise Ada.IO_Exceptions.Device_Error; - else - Mapping := Invalid_System_Mapping; - Mapping.Address := - Win.MapViewOfFile - (File.Mapping_Handle, Flags, - 0, DWORD (Offset), SIZE_T (Length)); - Mapping.Length := Length; - end if; - end Create_Mapping; - - --------------------- - -- Dispose_Mapping -- - --------------------- - - procedure Dispose_Mapping - (Mapping : in out System_Mapping) - is - Ignored : BOOL; - pragma Unreferenced (Ignored); - begin - Ignored := Win.UnmapViewOfFile (Mapping.Address); - Mapping := Invalid_System_Mapping; - end Dispose_Mapping; - - ------------------- - -- Get_Page_Size -- - ------------------- - - function Get_Page_Size return File_Size is - SystemInfo : aliased SYSTEM_INFO; - begin - GetSystemInfo (SystemInfo'Unchecked_Access); - return File_Size (SystemInfo.dwAllocationGranularity); - end Get_Page_Size; - - ----------- - -- Align -- - ----------- - - function Align - (Addr : File_Size) return File_Size is - begin - return Addr - Addr mod Get_Page_Size; - end Align; - -end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin-mingw.ads b/gcc/ada/libgnat/s-mmosin-mingw.ads deleted file mode 100644 index 3610065dff7..00000000000 --- a/gcc/ada/libgnat/s-mmosin-mingw.ads +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2017, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- OS pecularities abstraction package for Win32 systems. - -package System.Mmap.OS_Interface is - - -- The Win package contains copy of definition found in recent System.Win32 - -- unit provided with the GNAT compiler. The copy is needed to be able to - -- compile this unit with older compilers. Note that this internal Win - -- package can be removed when GNAT 6.1.0 is not supported anymore. - - package Win is - - subtype PVOID is Standard.System.Address; - - type HANDLE is new Interfaces.C.ptrdiff_t; - - type WORD is new Interfaces.C.unsigned_short; - type DWORD is new Interfaces.C.unsigned_long; - type LONG is new Interfaces.C.long; - type SIZE_T is new Interfaces.C.size_t; - - type BOOL is new Interfaces.C.int; - for BOOL'Size use Interfaces.C.int'Size; - - FALSE : constant := 0; - - GENERIC_READ : constant := 16#80000000#; - GENERIC_WRITE : constant := 16#40000000#; - OPEN_EXISTING : constant := 3; - - type OVERLAPPED is record - Internal : DWORD; - InternalHigh : DWORD; - Offset : DWORD; - OffsetHigh : DWORD; - hEvent : HANDLE; - end record; - - type SECURITY_ATTRIBUTES is record - nLength : DWORD; - pSecurityDescriptor : PVOID; - bInheritHandle : BOOL; - end record; - - type SYSTEM_INFO is record - dwOemId : DWORD; - dwPageSize : DWORD; - lpMinimumApplicationAddress : PVOID; - lpMaximumApplicationAddress : PVOID; - dwActiveProcessorMask : PVOID; - dwNumberOfProcessors : DWORD; - dwProcessorType : DWORD; - dwAllocationGranularity : DWORD; - wProcessorLevel : WORD; - wProcessorRevision : WORD; - end record; - type LP_SYSTEM_INFO is access all SYSTEM_INFO; - - INVALID_HANDLE_VALUE : constant HANDLE := -1; - FILE_BEGIN : constant := 0; - FILE_SHARE_READ : constant := 16#00000001#; - FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#; - FILE_MAP_COPY : constant := 1; - FILE_MAP_READ : constant := 4; - FILE_MAP_WRITE : constant := 2; - PAGE_READONLY : constant := 16#0002#; - PAGE_READWRITE : constant := 16#0004#; - INVALID_FILE_SIZE : constant := 16#FFFFFFFF#; - - function CreateFile - (lpFileName : Standard.System.Address; - dwDesiredAccess : DWORD; - dwShareMode : DWORD; - lpSecurityAttributes : access SECURITY_ATTRIBUTES; - dwCreationDisposition : DWORD; - dwFlagsAndAttributes : DWORD; - hTemplateFile : HANDLE) return HANDLE; - pragma Import (Stdcall, CreateFile, "CreateFileW"); - - function WriteFile - (hFile : HANDLE; - lpBuffer : Standard.System.Address; - nNumberOfBytesToWrite : DWORD; - lpNumberOfBytesWritten : access DWORD; - lpOverlapped : access OVERLAPPED) return BOOL; - pragma Import (Stdcall, WriteFile, "WriteFile"); - - function ReadFile - (hFile : HANDLE; - lpBuffer : Standard.System.Address; - nNumberOfBytesToRead : DWORD; - lpNumberOfBytesRead : access DWORD; - lpOverlapped : access OVERLAPPED) return BOOL; - pragma Import (Stdcall, ReadFile, "ReadFile"); - - function CloseHandle (hObject : HANDLE) return BOOL; - pragma Import (Stdcall, CloseHandle, "CloseHandle"); - - function GetFileSize - (hFile : HANDLE; lpFileSizeHigh : access DWORD) return DWORD; - pragma Import (Stdcall, GetFileSize, "GetFileSize"); - - function SetFilePointer - (hFile : HANDLE; - lDistanceToMove : LONG; - lpDistanceToMoveHigh : access LONG; - dwMoveMethod : DWORD) return DWORD; - pragma Import (Stdcall, SetFilePointer, "SetFilePointer"); - - function CreateFileMapping - (hFile : HANDLE; - lpSecurityAttributes : access SECURITY_ATTRIBUTES; - flProtect : DWORD; - dwMaximumSizeHigh : DWORD; - dwMaximumSizeLow : DWORD; - lpName : Standard.System.Address) return HANDLE; - pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingW"); - - function MapViewOfFile - (hFileMappingObject : HANDLE; - dwDesiredAccess : DWORD; - dwFileOffsetHigh : DWORD; - dwFileOffsetLow : DWORD; - dwNumberOfBytesToMap : SIZE_T) return Standard.System.Address; - pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile"); - - function UnmapViewOfFile - (lpBaseAddress : Standard.System.Address) return BOOL; - pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile"); - - procedure GetSystemInfo (lpSystemInfo : LP_SYSTEM_INFO); - pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); - - end Win; - - type System_File is record - Handle : Win.HANDLE; - - Mapped : Boolean; - -- Whether mapping is requested by the user and available on the system - - Mapping_Handle : Win.HANDLE; - - Write : Boolean; - -- Whether this file can be written to - - Length : File_Size; - -- Length of the file. Used to know what can be mapped in the file - end record; - - type System_Mapping is record - Address : Standard.System.Address; - Length : File_Size; - end record; - - Invalid_System_File : constant System_File := - (Win.INVALID_HANDLE_VALUE, False, Win.INVALID_HANDLE_VALUE, False, 0); - Invalid_System_Mapping : constant System_Mapping := - (Standard.System.Null_Address, 0); - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File; - -- Open a file for reading and return the corresponding System_File. Return - -- Invalid_System_File if unsuccessful. - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File; - -- Likewise for writing to a file - - procedure Close (File : in out System_File); - -- Close a system file - - function Read_From_Disk - (File : System_File; - Offset, Length : File_Size) return System.Strings.String_Access; - -- Read a fragment of a file. It is up to the caller to free the result - -- when done with it. - - procedure Write_To_Disk - (File : System_File; - Offset, Length : File_Size; - Buffer : System.Strings.String_Access); - -- Write some content to a fragment of a file - - procedure Create_Mapping - (File : System_File; - Offset, Length : in out File_Size; - Mutable : Boolean; - Mapping : out System_Mapping); - -- Create a memory mapping for the given File, for the area starting at - -- Offset and containing Length bytes. Store it to Mapping. - -- Note that Offset and Length may be modified according to the system - -- needs (for boudaries, for instance). The caller must cope with actually - -- wider mapped areas. - - procedure Dispose_Mapping - (Mapping : in out System_Mapping); - -- Unmap a previously-created mapping - - function Get_Page_Size return File_Size; - -- Return the number of bytes in a system page. - -end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin-unix.adb b/gcc/ada/libgnat/s-mmosin-unix.adb deleted file mode 100644 index aec253859f5..00000000000 --- a/gcc/ada/libgnat/s-mmosin-unix.adb +++ /dev/null @@ -1,229 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2017, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with System; use System; - -with System.OS_Lib; use System.OS_Lib; -with System.Mmap.Unix; use System.Mmap.Unix; - -package body System.Mmap.OS_Interface is - - function Align - (Addr : File_Size) return File_Size; - -- Align some offset/length to the lowest page boundary - - function Is_Mapping_Available return Boolean renames - System.Mmap.Unix.Is_Mapping_Available; - -- Wheter memory mapping is actually available on this system. It is an - -- error to use Create_Mapping and Dispose_Mapping if this is False. - - --------------- - -- Open_Read -- - --------------- - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File is - Fd : constant File_Descriptor := - Open_Read (Filename, Binary); - begin - if Fd = Invalid_FD then - return Invalid_System_File; - end if; - return - (Fd => Fd, - Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, - Write => False, - Length => File_Size (File_Length (Fd))); - end Open_Read; - - ---------------- - -- Open_Write -- - ---------------- - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File is - Fd : constant File_Descriptor := - Open_Read_Write (Filename, Binary); - begin - if Fd = Invalid_FD then - return Invalid_System_File; - end if; - return - (Fd => Fd, - Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, - Write => True, - Length => File_Size (File_Length (Fd))); - end Open_Write; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out System_File) is - begin - Close (File.Fd); - File.Fd := Invalid_FD; - end Close; - - -------------------- - -- Read_From_Disk -- - -------------------- - - function Read_From_Disk - (File : System_File; - Offset, Length : File_Size) return System.Strings.String_Access - is - Buffer : String_Access := new String (1 .. Integer (Length)); - begin - -- ??? Lseek offset should be a size_t instead of a Long_Integer - - Lseek (File.Fd, Long_Integer (Offset), Seek_Set); - if System.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length)) - /= Integer (Length) - then - System.Strings.Free (Buffer); - raise Ada.IO_Exceptions.Device_Error; - end if; - return Buffer; - end Read_From_Disk; - - ------------------- - -- Write_To_Disk -- - ------------------- - - procedure Write_To_Disk - (File : System_File; - Offset, Length : File_Size; - Buffer : System.Strings.String_Access) is - begin - pragma Assert (File.Write); - Lseek (File.Fd, Long_Integer (Offset), Seek_Set); - if System.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length)) - /= Integer (Length) - then - raise Ada.IO_Exceptions.Device_Error; - end if; - end Write_To_Disk; - - -------------------- - -- Create_Mapping -- - -------------------- - - procedure Create_Mapping - (File : System_File; - Offset, Length : in out File_Size; - Mutable : Boolean; - Mapping : out System_Mapping) - is - Prot : Mmap_Prot; - Flags : Mmap_Flags; - begin - if File.Write then - Prot := PROT_READ + PROT_WRITE; - Flags := MAP_SHARED; - else - Prot := PROT_READ; - if Mutable then - Prot := Prot + PROT_WRITE; - end if; - Flags := MAP_PRIVATE; - end if; - - -- Adjust offset and mapping length to account for the required - -- alignment of offset on page boundary. - - declare - Queried_Offset : constant File_Size := Offset; - begin - Offset := Align (Offset); - - -- First extend the length to compensate the offset shift, then align - -- it on the upper page boundary, so that the whole queried area is - -- covered. - - Length := Length + Queried_Offset - Offset; - Length := Align (Length + Get_Page_Size - 1); - end; - - if Length > File_Size (Integer'Last) then - raise Ada.IO_Exceptions.Device_Error; - else - Mapping := - (Address => System.Mmap.Unix.Mmap - (Offset => off_t (Offset), - Length => Interfaces.C.size_t (Length), - Prot => Prot, - Flags => Flags, - Fd => File.Fd), - Length => Length); - end if; - end Create_Mapping; - - --------------------- - -- Dispose_Mapping -- - --------------------- - - procedure Dispose_Mapping - (Mapping : in out System_Mapping) - is - Ignored : Integer; - pragma Unreferenced (Ignored); - begin - Ignored := Munmap - (Mapping.Address, Interfaces.C.size_t (Mapping.Length)); - Mapping := Invalid_System_Mapping; - end Dispose_Mapping; - - ------------------- - -- Get_Page_Size -- - ------------------- - - function Get_Page_Size return File_Size is - function Internal return Integer; - pragma Import (C, Internal, "getpagesize"); - begin - return File_Size (Internal); - end Get_Page_Size; - - ----------- - -- Align -- - ----------- - - function Align - (Addr : File_Size) return File_Size is - begin - return Addr - Addr mod Get_Page_Size; - end Align; - -end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin-unix.ads b/gcc/ada/libgnat/s-mmosin-unix.ads deleted file mode 100644 index 7162ddc351c..00000000000 --- a/gcc/ada/libgnat/s-mmosin-unix.ads +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2017, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.OS_Lib; - --- OS pecularities abstraction package for Unix systems. - -package System.Mmap.OS_Interface is - - type System_File is record - Fd : System.OS_Lib.File_Descriptor; - - Mapped : Boolean; - -- Whether mapping is requested by the user and available on the system - - Write : Boolean; - -- Whether this file can be written to - - Length : File_Size; - -- Length of the file. Used to know what can be mapped in the file - end record; - - type System_Mapping is record - Address : Standard.System.Address; - Length : File_Size; - end record; - - Invalid_System_File : constant System_File := - (System.OS_Lib.Invalid_FD, False, False, 0); - Invalid_System_Mapping : constant System_Mapping := - (Standard.System.Null_Address, 0); - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File; - -- Open a file for reading and return the corresponding System_File. Return - -- Invalid_System_File if unsuccessful. - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File; - -- Likewise for writing to a file - - procedure Close (File : in out System_File); - -- Close a system file - - function Read_From_Disk - (File : System_File; - Offset, Length : File_Size) return System.Strings.String_Access; - -- Read a fragment of a file. It is up to the caller to free the result - -- when done with it. - - procedure Write_To_Disk - (File : System_File; - Offset, Length : File_Size; - Buffer : System.Strings.String_Access); - -- Write some content to a fragment of a file - - procedure Create_Mapping - (File : System_File; - Offset, Length : in out File_Size; - Mutable : Boolean; - Mapping : out System_Mapping); - -- Create a memory mapping for the given File, for the area starting at - -- Offset and containing Length bytes. Store it to Mapping. - -- Note that Offset and Length may be modified according to the system - -- needs (for boudaries, for instance). The caller must cope with actually - -- wider mapped areas. - - procedure Dispose_Mapping - (Mapping : in out System_Mapping); - -- Unmap a previously-created mapping - - function Get_Page_Size return File_Size; - -- Return the number of bytes in a system page. - -end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin__mingw.adb b/gcc/ada/libgnat/s-mmosin__mingw.adb new file mode 100644 index 00000000000..f32e540ebfe --- /dev/null +++ b/gcc/ada/libgnat/s-mmosin__mingw.adb @@ -0,0 +1,345 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System.Strings; use System.Strings; + +with System.OS_Lib; +pragma Unreferenced (System.OS_Lib); +-- Only used to generate same runtime dependencies and same binder file on +-- GNU/Linux and Windows. + +package body System.Mmap.OS_Interface is + + use Win; + + function Align + (Addr : File_Size) return File_Size; + -- Align some offset/length to the lowest page boundary + + function Open_Common + (Filename : String; + Use_Mmap_If_Available : Boolean; + Write : Boolean) return System_File; + + function From_UTF8 (Path : String) return Wide_String; + -- Convert from UTF-8 to Wide_String + + --------------- + -- From_UTF8 -- + --------------- + + function From_UTF8 (Path : String) return Wide_String is + function MultiByteToWideChar + (Codepage : Interfaces.C.unsigned; + Flags : Interfaces.C.unsigned; + Mbstr : Address; + Mb : Natural; + Wcstr : Address; + Wc : Natural) return Integer; + pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar"); + + Current_Codepage : Interfaces.C.unsigned; + pragma Import (C, Current_Codepage, "__gnat_current_codepage"); + + Len : Natural; + begin + -- Compute length of the result + Len := MultiByteToWideChar + (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0); + if Len = 0 then + raise Constraint_Error; + end if; + + declare + -- Declare result + Res : Wide_String (1 .. Len); + begin + -- And compute it + Len := MultiByteToWideChar + (Current_Codepage, 0, + Path'Address, Path'Length, + Res'Address, Len); + if Len = 0 then + raise Constraint_Error; + end if; + return Res; + end; + end From_UTF8; + + ----------------- + -- Open_Common -- + ----------------- + + function Open_Common + (Filename : String; + Use_Mmap_If_Available : Boolean; + Write : Boolean) return System_File + is + dwDesiredAccess, dwShareMode : DWORD; + PageFlags : DWORD; + + W_Filename : constant Wide_String := + From_UTF8 (Filename) & Wide_Character'Val (0); + File_Handle, Mapping_Handle : HANDLE; + + SizeH : aliased DWORD; + Size : File_Size; + begin + if Write then + dwDesiredAccess := GENERIC_READ + GENERIC_WRITE; + dwShareMode := 0; + PageFlags := Win.PAGE_READWRITE; + else + dwDesiredAccess := GENERIC_READ; + dwShareMode := Win.FILE_SHARE_READ; + PageFlags := Win.PAGE_READONLY; + end if; + + -- Actually open the file + + File_Handle := CreateFile + (W_Filename'Address, dwDesiredAccess, dwShareMode, + null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0); + + if File_Handle = Win.INVALID_HANDLE_VALUE then + return Invalid_System_File; + end if; + + -- Compute its size + + Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access)); + + if Size = Win.INVALID_FILE_SIZE then + return Invalid_System_File; + end if; + + if SizeH /= 0 and then File_Size'Size > 32 then + Size := Size + (File_Size (SizeH) * 2 ** 32); + end if; + + -- Then create a mapping object, if needed. On Win32, file memory + -- mapping is always available. + + if Use_Mmap_If_Available then + Mapping_Handle := + Win.CreateFileMapping + (File_Handle, null, PageFlags, + 0, DWORD (Size), Standard.System.Null_Address); + else + Mapping_Handle := Win.INVALID_HANDLE_VALUE; + end if; + + return + (Handle => File_Handle, + Mapped => Use_Mmap_If_Available, + Mapping_Handle => Mapping_Handle, + Write => Write, + Length => Size); + end Open_Common; + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File is + begin + return Open_Common (Filename, Use_Mmap_If_Available, False); + end Open_Read; + + ---------------- + -- Open_Write -- + ---------------- + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File is + begin + return Open_Common (Filename, Use_Mmap_If_Available, True); + end Open_Write; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out System_File) is + Ignored : BOOL; + pragma Unreferenced (Ignored); + begin + Ignored := CloseHandle (File.Mapping_Handle); + Ignored := CloseHandle (File.Handle); + File.Handle := Win.INVALID_HANDLE_VALUE; + File.Mapping_Handle := Win.INVALID_HANDLE_VALUE; + end Close; + + -------------------- + -- Read_From_Disk -- + -------------------- + + function Read_From_Disk + (File : System_File; + Offset, Length : File_Size) return System.Strings.String_Access + is + Buffer : String_Access := new String (1 .. Integer (Length)); + + Pos : DWORD; + NbRead : aliased DWORD; + pragma Unreferenced (Pos); + begin + Pos := Win.SetFilePointer + (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); + + if Win.ReadFile + (File.Handle, Buffer.all'Address, + DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE + then + System.Strings.Free (Buffer); + raise Ada.IO_Exceptions.Device_Error; + end if; + return Buffer; + end Read_From_Disk; + + ------------------- + -- Write_To_Disk -- + ------------------- + + procedure Write_To_Disk + (File : System_File; + Offset, Length : File_Size; + Buffer : System.Strings.String_Access) + is + Pos : DWORD; + NbWritten : aliased DWORD; + pragma Unreferenced (Pos); + begin + pragma Assert (File.Write); + Pos := Win.SetFilePointer + (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); + + if Win.WriteFile + (File.Handle, Buffer.all'Address, + DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE + then + raise Ada.IO_Exceptions.Device_Error; + end if; + end Write_To_Disk; + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping + (File : System_File; + Offset, Length : in out File_Size; + Mutable : Boolean; + Mapping : out System_Mapping) + is + Flags : DWORD; + begin + if File.Write then + Flags := Win.FILE_MAP_WRITE; + elsif Mutable then + Flags := Win.FILE_MAP_COPY; + else + Flags := Win.FILE_MAP_READ; + end if; + + -- Adjust offset and mapping length to account for the required + -- alignment of offset on page boundary. + + declare + Queried_Offset : constant File_Size := Offset; + begin + Offset := Align (Offset); + + -- First extend the length to compensate the offset shift, then align + -- it on the upper page boundary, so that the whole queried area is + -- covered. + + Length := Length + Queried_Offset - Offset; + Length := Align (Length + Get_Page_Size - 1); + + -- But do not exceed the length of the file + if Offset + Length > File.Length then + Length := File.Length - Offset; + end if; + end; + + if Length > File_Size (Integer'Last) then + raise Ada.IO_Exceptions.Device_Error; + else + Mapping := Invalid_System_Mapping; + Mapping.Address := + Win.MapViewOfFile + (File.Mapping_Handle, Flags, + 0, DWORD (Offset), SIZE_T (Length)); + Mapping.Length := Length; + end if; + end Create_Mapping; + + --------------------- + -- Dispose_Mapping -- + --------------------- + + procedure Dispose_Mapping + (Mapping : in out System_Mapping) + is + Ignored : BOOL; + pragma Unreferenced (Ignored); + begin + Ignored := Win.UnmapViewOfFile (Mapping.Address); + Mapping := Invalid_System_Mapping; + end Dispose_Mapping; + + ------------------- + -- Get_Page_Size -- + ------------------- + + function Get_Page_Size return File_Size is + SystemInfo : aliased SYSTEM_INFO; + begin + GetSystemInfo (SystemInfo'Unchecked_Access); + return File_Size (SystemInfo.dwAllocationGranularity); + end Get_Page_Size; + + ----------- + -- Align -- + ----------- + + function Align + (Addr : File_Size) return File_Size is + begin + return Addr - Addr mod Get_Page_Size; + end Align; + +end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin__mingw.ads b/gcc/ada/libgnat/s-mmosin__mingw.ads new file mode 100644 index 00000000000..3610065dff7 --- /dev/null +++ b/gcc/ada/libgnat/s-mmosin__mingw.ads @@ -0,0 +1,235 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- OS pecularities abstraction package for Win32 systems. + +package System.Mmap.OS_Interface is + + -- The Win package contains copy of definition found in recent System.Win32 + -- unit provided with the GNAT compiler. The copy is needed to be able to + -- compile this unit with older compilers. Note that this internal Win + -- package can be removed when GNAT 6.1.0 is not supported anymore. + + package Win is + + subtype PVOID is Standard.System.Address; + + type HANDLE is new Interfaces.C.ptrdiff_t; + + type WORD is new Interfaces.C.unsigned_short; + type DWORD is new Interfaces.C.unsigned_long; + type LONG is new Interfaces.C.long; + type SIZE_T is new Interfaces.C.size_t; + + type BOOL is new Interfaces.C.int; + for BOOL'Size use Interfaces.C.int'Size; + + FALSE : constant := 0; + + GENERIC_READ : constant := 16#80000000#; + GENERIC_WRITE : constant := 16#40000000#; + OPEN_EXISTING : constant := 3; + + type OVERLAPPED is record + Internal : DWORD; + InternalHigh : DWORD; + Offset : DWORD; + OffsetHigh : DWORD; + hEvent : HANDLE; + end record; + + type SECURITY_ATTRIBUTES is record + nLength : DWORD; + pSecurityDescriptor : PVOID; + bInheritHandle : BOOL; + end record; + + type SYSTEM_INFO is record + dwOemId : DWORD; + dwPageSize : DWORD; + lpMinimumApplicationAddress : PVOID; + lpMaximumApplicationAddress : PVOID; + dwActiveProcessorMask : PVOID; + dwNumberOfProcessors : DWORD; + dwProcessorType : DWORD; + dwAllocationGranularity : DWORD; + wProcessorLevel : WORD; + wProcessorRevision : WORD; + end record; + type LP_SYSTEM_INFO is access all SYSTEM_INFO; + + INVALID_HANDLE_VALUE : constant HANDLE := -1; + FILE_BEGIN : constant := 0; + FILE_SHARE_READ : constant := 16#00000001#; + FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#; + FILE_MAP_COPY : constant := 1; + FILE_MAP_READ : constant := 4; + FILE_MAP_WRITE : constant := 2; + PAGE_READONLY : constant := 16#0002#; + PAGE_READWRITE : constant := 16#0004#; + INVALID_FILE_SIZE : constant := 16#FFFFFFFF#; + + function CreateFile + (lpFileName : Standard.System.Address; + dwDesiredAccess : DWORD; + dwShareMode : DWORD; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + dwCreationDisposition : DWORD; + dwFlagsAndAttributes : DWORD; + hTemplateFile : HANDLE) return HANDLE; + pragma Import (Stdcall, CreateFile, "CreateFileW"); + + function WriteFile + (hFile : HANDLE; + lpBuffer : Standard.System.Address; + nNumberOfBytesToWrite : DWORD; + lpNumberOfBytesWritten : access DWORD; + lpOverlapped : access OVERLAPPED) return BOOL; + pragma Import (Stdcall, WriteFile, "WriteFile"); + + function ReadFile + (hFile : HANDLE; + lpBuffer : Standard.System.Address; + nNumberOfBytesToRead : DWORD; + lpNumberOfBytesRead : access DWORD; + lpOverlapped : access OVERLAPPED) return BOOL; + pragma Import (Stdcall, ReadFile, "ReadFile"); + + function CloseHandle (hObject : HANDLE) return BOOL; + pragma Import (Stdcall, CloseHandle, "CloseHandle"); + + function GetFileSize + (hFile : HANDLE; lpFileSizeHigh : access DWORD) return DWORD; + pragma Import (Stdcall, GetFileSize, "GetFileSize"); + + function SetFilePointer + (hFile : HANDLE; + lDistanceToMove : LONG; + lpDistanceToMoveHigh : access LONG; + dwMoveMethod : DWORD) return DWORD; + pragma Import (Stdcall, SetFilePointer, "SetFilePointer"); + + function CreateFileMapping + (hFile : HANDLE; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + flProtect : DWORD; + dwMaximumSizeHigh : DWORD; + dwMaximumSizeLow : DWORD; + lpName : Standard.System.Address) return HANDLE; + pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingW"); + + function MapViewOfFile + (hFileMappingObject : HANDLE; + dwDesiredAccess : DWORD; + dwFileOffsetHigh : DWORD; + dwFileOffsetLow : DWORD; + dwNumberOfBytesToMap : SIZE_T) return Standard.System.Address; + pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile"); + + function UnmapViewOfFile + (lpBaseAddress : Standard.System.Address) return BOOL; + pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile"); + + procedure GetSystemInfo (lpSystemInfo : LP_SYSTEM_INFO); + pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); + + end Win; + + type System_File is record + Handle : Win.HANDLE; + + Mapped : Boolean; + -- Whether mapping is requested by the user and available on the system + + Mapping_Handle : Win.HANDLE; + + Write : Boolean; + -- Whether this file can be written to + + Length : File_Size; + -- Length of the file. Used to know what can be mapped in the file + end record; + + type System_Mapping is record + Address : Standard.System.Address; + Length : File_Size; + end record; + + Invalid_System_File : constant System_File := + (Win.INVALID_HANDLE_VALUE, False, Win.INVALID_HANDLE_VALUE, False, 0); + Invalid_System_Mapping : constant System_Mapping := + (Standard.System.Null_Address, 0); + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File; + -- Open a file for reading and return the corresponding System_File. Return + -- Invalid_System_File if unsuccessful. + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File; + -- Likewise for writing to a file + + procedure Close (File : in out System_File); + -- Close a system file + + function Read_From_Disk + (File : System_File; + Offset, Length : File_Size) return System.Strings.String_Access; + -- Read a fragment of a file. It is up to the caller to free the result + -- when done with it. + + procedure Write_To_Disk + (File : System_File; + Offset, Length : File_Size; + Buffer : System.Strings.String_Access); + -- Write some content to a fragment of a file + + procedure Create_Mapping + (File : System_File; + Offset, Length : in out File_Size; + Mutable : Boolean; + Mapping : out System_Mapping); + -- Create a memory mapping for the given File, for the area starting at + -- Offset and containing Length bytes. Store it to Mapping. + -- Note that Offset and Length may be modified according to the system + -- needs (for boudaries, for instance). The caller must cope with actually + -- wider mapped areas. + + procedure Dispose_Mapping + (Mapping : in out System_Mapping); + -- Unmap a previously-created mapping + + function Get_Page_Size return File_Size; + -- Return the number of bytes in a system page. + +end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin__unix.adb b/gcc/ada/libgnat/s-mmosin__unix.adb new file mode 100644 index 00000000000..aec253859f5 --- /dev/null +++ b/gcc/ada/libgnat/s-mmosin__unix.adb @@ -0,0 +1,229 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System; use System; + +with System.OS_Lib; use System.OS_Lib; +with System.Mmap.Unix; use System.Mmap.Unix; + +package body System.Mmap.OS_Interface is + + function Align + (Addr : File_Size) return File_Size; + -- Align some offset/length to the lowest page boundary + + function Is_Mapping_Available return Boolean renames + System.Mmap.Unix.Is_Mapping_Available; + -- Wheter memory mapping is actually available on this system. It is an + -- error to use Create_Mapping and Dispose_Mapping if this is False. + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File is + Fd : constant File_Descriptor := + Open_Read (Filename, Binary); + begin + if Fd = Invalid_FD then + return Invalid_System_File; + end if; + return + (Fd => Fd, + Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, + Write => False, + Length => File_Size (File_Length (Fd))); + end Open_Read; + + ---------------- + -- Open_Write -- + ---------------- + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File is + Fd : constant File_Descriptor := + Open_Read_Write (Filename, Binary); + begin + if Fd = Invalid_FD then + return Invalid_System_File; + end if; + return + (Fd => Fd, + Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, + Write => True, + Length => File_Size (File_Length (Fd))); + end Open_Write; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out System_File) is + begin + Close (File.Fd); + File.Fd := Invalid_FD; + end Close; + + -------------------- + -- Read_From_Disk -- + -------------------- + + function Read_From_Disk + (File : System_File; + Offset, Length : File_Size) return System.Strings.String_Access + is + Buffer : String_Access := new String (1 .. Integer (Length)); + begin + -- ??? Lseek offset should be a size_t instead of a Long_Integer + + Lseek (File.Fd, Long_Integer (Offset), Seek_Set); + if System.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length)) + /= Integer (Length) + then + System.Strings.Free (Buffer); + raise Ada.IO_Exceptions.Device_Error; + end if; + return Buffer; + end Read_From_Disk; + + ------------------- + -- Write_To_Disk -- + ------------------- + + procedure Write_To_Disk + (File : System_File; + Offset, Length : File_Size; + Buffer : System.Strings.String_Access) is + begin + pragma Assert (File.Write); + Lseek (File.Fd, Long_Integer (Offset), Seek_Set); + if System.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length)) + /= Integer (Length) + then + raise Ada.IO_Exceptions.Device_Error; + end if; + end Write_To_Disk; + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping + (File : System_File; + Offset, Length : in out File_Size; + Mutable : Boolean; + Mapping : out System_Mapping) + is + Prot : Mmap_Prot; + Flags : Mmap_Flags; + begin + if File.Write then + Prot := PROT_READ + PROT_WRITE; + Flags := MAP_SHARED; + else + Prot := PROT_READ; + if Mutable then + Prot := Prot + PROT_WRITE; + end if; + Flags := MAP_PRIVATE; + end if; + + -- Adjust offset and mapping length to account for the required + -- alignment of offset on page boundary. + + declare + Queried_Offset : constant File_Size := Offset; + begin + Offset := Align (Offset); + + -- First extend the length to compensate the offset shift, then align + -- it on the upper page boundary, so that the whole queried area is + -- covered. + + Length := Length + Queried_Offset - Offset; + Length := Align (Length + Get_Page_Size - 1); + end; + + if Length > File_Size (Integer'Last) then + raise Ada.IO_Exceptions.Device_Error; + else + Mapping := + (Address => System.Mmap.Unix.Mmap + (Offset => off_t (Offset), + Length => Interfaces.C.size_t (Length), + Prot => Prot, + Flags => Flags, + Fd => File.Fd), + Length => Length); + end if; + end Create_Mapping; + + --------------------- + -- Dispose_Mapping -- + --------------------- + + procedure Dispose_Mapping + (Mapping : in out System_Mapping) + is + Ignored : Integer; + pragma Unreferenced (Ignored); + begin + Ignored := Munmap + (Mapping.Address, Interfaces.C.size_t (Mapping.Length)); + Mapping := Invalid_System_Mapping; + end Dispose_Mapping; + + ------------------- + -- Get_Page_Size -- + ------------------- + + function Get_Page_Size return File_Size is + function Internal return Integer; + pragma Import (C, Internal, "getpagesize"); + begin + return File_Size (Internal); + end Get_Page_Size; + + ----------- + -- Align -- + ----------- + + function Align + (Addr : File_Size) return File_Size is + begin + return Addr - Addr mod Get_Page_Size; + end Align; + +end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin__unix.ads b/gcc/ada/libgnat/s-mmosin__unix.ads new file mode 100644 index 00000000000..7162ddc351c --- /dev/null +++ b/gcc/ada/libgnat/s-mmosin__unix.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.OS_Lib; + +-- OS pecularities abstraction package for Unix systems. + +package System.Mmap.OS_Interface is + + type System_File is record + Fd : System.OS_Lib.File_Descriptor; + + Mapped : Boolean; + -- Whether mapping is requested by the user and available on the system + + Write : Boolean; + -- Whether this file can be written to + + Length : File_Size; + -- Length of the file. Used to know what can be mapped in the file + end record; + + type System_Mapping is record + Address : Standard.System.Address; + Length : File_Size; + end record; + + Invalid_System_File : constant System_File := + (System.OS_Lib.Invalid_FD, False, False, 0); + Invalid_System_Mapping : constant System_Mapping := + (Standard.System.Null_Address, 0); + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File; + -- Open a file for reading and return the corresponding System_File. Return + -- Invalid_System_File if unsuccessful. + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File; + -- Likewise for writing to a file + + procedure Close (File : in out System_File); + -- Close a system file + + function Read_From_Disk + (File : System_File; + Offset, Length : File_Size) return System.Strings.String_Access; + -- Read a fragment of a file. It is up to the caller to free the result + -- when done with it. + + procedure Write_To_Disk + (File : System_File; + Offset, Length : File_Size; + Buffer : System.Strings.String_Access); + -- Write some content to a fragment of a file + + procedure Create_Mapping + (File : System_File; + Offset, Length : in out File_Size; + Mutable : Boolean; + Mapping : out System_Mapping); + -- Create a memory mapping for the given File, for the area starting at + -- Offset and containing Length bytes. Store it to Mapping. + -- Note that Offset and Length may be modified according to the system + -- needs (for boudaries, for instance). The caller must cope with actually + -- wider mapped areas. + + procedure Dispose_Mapping + (Mapping : in out System_Mapping); + -- Unmap a previously-created mapping + + function Get_Page_Size return File_Size; + -- Return the number of bytes in a system page. + +end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-osprim-darwin.adb b/gcc/ada/libgnat/s-osprim-darwin.adb deleted file mode 100644 index b0f5fff2a09..00000000000 --- a/gcc/ada/libgnat/s-osprim-darwin.adb +++ /dev/null @@ -1,169 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for darwin - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type struct_timezone is record - tz_minuteswest : Integer; - tz_dsttime : Integer; - end record; - pragma Convention (C, struct_timezone); - type struct_timezone_ptr is access all struct_timezone; - - type time_t is new Long_Integer; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : Integer; - end record; - pragma Convention (C, struct_timeval); - - function gettimeofday - (tv : not null access struct_timeval; - tz : struct_timezone_ptr) return Integer; - pragma Import (C, gettimeofday, "gettimeofday"); - - type timespec is record - tv_sec : time_t; - tv_nsec : Long_Integer; - end record; - pragma Convention (C, timespec); - - function nanosleep (rqtp, rmtp : not null access timespec) return Integer; - pragma Import (C, nanosleep, "nanosleep"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TV : aliased struct_timeval; - - Result : Integer; - pragma Unreferenced (Result); - - begin - -- The return codes for gettimeofday are as follows (from man pages): - -- EPERM settimeofday is called by someone other than the superuser - -- EINVAL Timezone (or something else) is invalid - -- EFAULT One of tv or tz pointed outside accessible address space - - -- None of these codes signal a potential clock skew, hence the return - -- value is never checked. - - Result := gettimeofday (TV'Access, null); - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end Clock; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec; - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - timespec'(tv_sec => S, - tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Request : aliased timespec; - Remaind : aliased timespec; - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - - Result : Integer; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Request := To_Timespec (Rel_Time); - Result := nanosleep (Request'Access, Remaind'Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-lynxos.ads b/gcc/ada/libgnat/s-osprim-lynxos.ads deleted file mode 100644 index 26087fd783a..00000000000 --- a/gcc/ada/libgnat/s-osprim-lynxos.ads +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides low level primitives used to implement clock and --- delays in non tasking applications, for LynxOS. - --- The choice of the real clock/delay implementation (depending on whether --- tasking is involved or not) is done via soft links (see s-soflin.ads) - --- NEVER add any dependency to tasking packages here - -package System.OS_Primitives is - pragma Preelaborate; - - Max_Sensible_Delay : constant Duration := 16#10_0000.0#; - -- LynxOS does not support delays as long as half a year, so we set this to - -- a shorter, but still fairly long, duration. Experiments show that if - -- pthread_cond_timedwait is passed an abstime much greater than about - -- 2**21, it fails, returning EAGAIN. The cutoff is somewhere between - -- 16#20_8000.0# and 16#20_F000.0#. This behavior is not documented. - - procedure Initialize; - -- Initialize global settings related to this package. This procedure - -- should be called before any other subprograms in this package. Note - -- that this procedure can be called several times. - - function Clock return Duration; - pragma Inline (Clock); - -- Returns "absolute" time, represented as an offset relative to "the - -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This - -- implementation is affected by system's clock changes. - - Relative : constant := 0; - Absolute_Calendar : constant := 1; - Absolute_RT : constant := 2; - -- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies - -- on these values. So any change here must be reflected in corresponding - -- changes in the compiler. - - procedure Timed_Delay (Time : Duration; Mode : Integer); - -- Implements the semantics of the delay statement when no tasking is used - -- in the application. - -- - -- Mode is one of the three values above - -- - -- Time is a relative or absolute duration value, depending on Mode. - -- - -- Note that currently Ada.Real_Time always uses the tasking run time, - -- so this procedure should never be called with Mode set to Absolute_RT. - -- This may change in future or bare board implementations. - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-mingw.adb b/gcc/ada/libgnat/s-osprim-mingw.adb deleted file mode 100644 index d729d857a74..00000000000 --- a/gcc/ada/libgnat/s-osprim-mingw.adb +++ /dev/null @@ -1,413 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the NT version of this package - -with System.Task_Lock; -with System.Win32.Ext; - -package body System.OS_Primitives is - - use System.Task_Lock; - use System.Win32; - use System.Win32.Ext; - - ---------------------------------------- - -- Data for the high resolution clock -- - ---------------------------------------- - - Tick_Frequency : aliased LARGE_INTEGER; - -- Holds frequency of high-performance counter used by Clock - -- Windows NT uses a 1_193_182 Hz counter on PCs. - - Base_Monotonic_Ticks : LARGE_INTEGER; - -- Holds the Tick count for the base monotonic time - - Base_Monotonic_Clock : Duration; - -- Holds the current clock for monotonic clock's base time - - type Clock_Data is record - Base_Ticks : LARGE_INTEGER; - -- Holds the Tick count for the base time - - Base_Time : Long_Long_Integer; - -- Holds the base time used to check for system time change, used with - -- the standard clock. - - Base_Clock : Duration; - -- Holds the current clock for the standard clock's base time - end record; - - type Clock_Data_Access is access all Clock_Data; - - -- Two base clock buffers. This is used to be able to update a buffer while - -- the other buffer is read. The point is that we do not want to use a lock - -- inside the Clock routine for performance reasons. We still use a lock - -- in the Get_Base_Time which is called very rarely. Current is a pointer, - -- the pragma Atomic is there to ensure that the value can be set or read - -- atomically. That's it, when Get_Base_Time has updated a buffer the - -- switch to the new value is done by changing Current pointer. - - First, Second : aliased Clock_Data; - - Current : Clock_Data_Access := First'Access; - pragma Atomic (Current); - - -- The following signature is to detect change on the base clock data - -- above. The signature is a modular type, it will wrap around without - -- raising an exception. We would need to have exactly 2**32 updates of - -- the base data for the changes to get undetected. - - type Signature_Type is mod 2**32; - Signature : Signature_Type := 0; - pragma Atomic (Signature); - - function Monotonic_Clock return Duration; - pragma Export (Ada, Monotonic_Clock, "__gnat_monotonic_clock"); - -- Return "absolute" time, represented as an offset relative to "the Unix - -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is - -- immune to the system's clock changes. Export this function so that it - -- can be imported from s-taprop-mingw.adb without changing the shared - -- spec (s-osprim.ads). - - procedure Get_Base_Time (Data : in out Clock_Data); - -- Retrieve the base time and base ticks. These values will be used by - -- clock to compute the current time by adding to it a fraction of the - -- performance counter. This is for the implementation of a high-resolution - -- clock. Note that this routine does not change the base monotonic values - -- used by the monotonic clock. - - ----------- - -- Clock -- - ----------- - - -- This implementation of clock provides high resolution timer values - -- using QueryPerformanceCounter. This call return a 64 bits values (based - -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182 - -- times per seconds. The call to QueryPerformanceCounter takes 6 - -- microsecs to complete. - - function Clock return Duration is - Max_Shift : constant Duration := 2.0; - Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7; - Data : Clock_Data; - Current_Ticks : aliased LARGE_INTEGER; - Elap_Secs_Tick : Duration; - Elap_Secs_Sys : Duration; - Now : aliased Long_Long_Integer; - Sig1, Sig2 : Signature_Type; - - begin - -- Try ten times to get a coherent set of base data. For this we just - -- check that the signature hasn't changed during the copy of the - -- current data. - -- - -- This loop will always be done once if there is no interleaved call - -- to Get_Base_Time. - - for K in 1 .. 10 loop - Sig1 := Signature; - Data := Current.all; - Sig2 := Signature; - exit when Sig1 = Sig2; - end loop; - - if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then - return 0.0; - end if; - - GetSystemTimeAsFileTime (Now'Access); - - Elap_Secs_Sys := - Duration (Long_Long_Float (abs (Now - Data.Base_Time)) / - Hundreds_Nano_In_Sec); - - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) / - Long_Long_Float (Tick_Frequency)); - - -- If we have a shift of more than Max_Shift seconds we resynchronize - -- the Clock. This is probably due to a manual Clock adjustment, a DST - -- adjustment or an NTP synchronisation. And we want to adjust the time - -- for this system (non-monotonic) clock. - - if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then - Get_Base_Time (Data); - - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) / - Long_Long_Float (Tick_Frequency)); - end if; - - return Data.Base_Clock + Elap_Secs_Tick; - end Clock; - - ------------------- - -- Get_Base_Time -- - ------------------- - - procedure Get_Base_Time (Data : in out Clock_Data) is - - -- The resolution for GetSystemTime is 1 millisecond - - -- The time to get both base times should take less than 1 millisecond. - -- Therefore, the elapsed time reported by GetSystemTime between both - -- actions should be null. - - epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch - system_time_ns : constant := 100; -- 100 ns per tick - Sec_Unit : constant := 10#1#E9; - - Max_Elapsed : constant LARGE_INTEGER := - LARGE_INTEGER (Tick_Frequency / 100_000); - -- Look for a precision of 0.01 ms - - Sig : constant Signature_Type := Signature; - - Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER; - Loc_Time, Ctrl_Time : aliased Long_Long_Integer; - Elapsed : LARGE_INTEGER; - Current_Max : LARGE_INTEGER := LARGE_INTEGER'Last; - New_Data : Clock_Data_Access; - - begin - -- Here we must be sure that both of these calls are done in a short - -- amount of time. Both are base time and should in theory be taken - -- at the very same time. - - -- The goal of the following loop is to synchronize the system time - -- with the Win32 performance counter by getting a base offset for both. - -- Using these offsets it is then possible to compute actual time using - -- a performance counter which has a better precision than the Win32 - -- time API. - - -- Try at most 10 times to reach the best synchronisation (below 1 - -- millisecond) otherwise the runtime will use the best value reached - -- during the runs. - - Lock; - - -- First check that the current value has not been updated. This - -- could happen if another task has called Clock at the same time - -- and that Max_Shift has been reached too. - -- - -- But if the current value has been changed just before we entered - -- into the critical section, we can safely return as the current - -- base data (time, clock, ticks) have already been updated. - - if Sig /= Signature then - Unlock; - return; - end if; - - -- Check for the unused data buffer and set New_Data to point to it - - if Current = First'Access then - New_Data := Second'Access; - else - New_Data := First'Access; - end if; - - for K in 1 .. 10 loop - if QueryPerformanceCounter (Loc_Ticks'Access) = Win32.FALSE then - pragma Assert - (Standard.False, - "Could not query high performance counter in Clock"); - null; - end if; - - GetSystemTimeAsFileTime (Ctrl_Time'Access); - - -- Scan for clock tick, will take up to 16ms/1ms depending on PC. - -- This cannot be an infinite loop or the system hardware is badly - -- damaged. - - loop - GetSystemTimeAsFileTime (Loc_Time'Access); - - if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then - pragma Assert - (Standard.False, - "Could not query high performance counter in Clock"); - null; - end if; - - exit when Loc_Time /= Ctrl_Time; - Loc_Ticks := Ctrl_Ticks; - end loop; - - -- Check elapsed Performance Counter between samples - -- to choose the best one. - - Elapsed := Ctrl_Ticks - Loc_Ticks; - - if Elapsed < Current_Max then - New_Data.Base_Time := Loc_Time; - New_Data.Base_Ticks := Loc_Ticks; - Current_Max := Elapsed; - - -- Exit the loop when we have reached the expected precision - - exit when Elapsed <= Max_Elapsed; - end if; - end loop; - - New_Data.Base_Clock := - Duration - (Long_Long_Float - ((New_Data.Base_Time - epoch_1970) * system_time_ns) / - Long_Long_Float (Sec_Unit)); - - -- At this point all the base values have been set into the new data - -- record. Change the pointer (atomic operation) to these new values. - - Current := New_Data; - Data := New_Data.all; - - -- Set new signature for this data set - - Signature := Signature + 1; - - Unlock; - - exception - when others => - Unlock; - raise; - end Get_Base_Time; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - Current_Ticks : aliased LARGE_INTEGER; - Elap_Secs_Tick : Duration; - - begin - if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then - return 0.0; - - else - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - Base_Monotonic_Ticks) / - Long_Long_Float (Tick_Frequency)); - return Base_Monotonic_Clock + Elap_Secs_Tick; - end if; - end Monotonic_Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay (Time : Duration; Mode : Integer) is - function Mode_Clock return Duration; - pragma Inline (Mode_Clock); - -- Return the current clock value using either the monotonic clock or - -- standard clock depending on the Mode value. - - ---------------- - -- Mode_Clock -- - ---------------- - - function Mode_Clock return Duration is - begin - case Mode is - when Absolute_RT => return Monotonic_Clock; - when others => return Clock; - end case; - end Mode_Clock; - - -- Local Variables - - Base_Time : constant Duration := Mode_Clock; - -- Base_Time is used to detect clock set backward, in this case we - -- cannot ensure the delay accuracy. - - Rel_Time : Duration; - Abs_Time : Duration; - Check_Time : Duration := Base_Time; - - -- Start of processing for Timed Delay - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Sleep (DWORD (Rel_Time * 1000.0)); - Check_Time := Mode_Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - Initialized : Boolean := False; - - procedure Initialize is - begin - if Initialized then - return; - end if; - - Initialized := True; - - -- Get starting time as base - - if QueryPerformanceFrequency (Tick_Frequency'Access) = Win32.FALSE then - raise Program_Error with - "cannot get high performance counter frequency"; - end if; - - Get_Base_Time (Current.all); - - -- Keep base clock and ticks for the monotonic clock. These values - -- should never be changed to ensure proper behavior of the monotonic - -- clock. - - Base_Monotonic_Clock := Current.Base_Clock; - Base_Monotonic_Ticks := Current.Base_Ticks; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-posix.adb b/gcc/ada/libgnat/s-osprim-posix.adb deleted file mode 100644 index 8911b16b3a9..00000000000 --- a/gcc/ada/libgnat/s-osprim-posix.adb +++ /dev/null @@ -1,172 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for POSIX-like operating systems - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type time_t is new Long_Integer; - - type timespec is record - tv_sec : time_t; - tv_nsec : Long_Integer; - end record; - pragma Convention (C, timespec); - - function nanosleep (rqtp, rmtp : not null access timespec) return Integer; - pragma Import (C, nanosleep, "nanosleep"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - - type timeval is array (1 .. 3) of Long_Integer; - -- The timeval array is sized to contain Long_Long_Integer sec and - -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then - -- it will be overly large but that will not effect the implementation - -- since it is not accessed directly. - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access Long_Long_Integer; - usec : not null access Long_Integer); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased Long_Long_Integer; - usec : aliased Long_Integer; - TV : aliased timeval; - Result : Integer; - pragma Unreferenced (Result); - - function gettimeofday - (Tv : access timeval; - Tz : System.Address := System.Null_Address) return Integer; - pragma Import (C, gettimeofday, "gettimeofday"); - - begin - -- The return codes for gettimeofday are as follows (from man pages): - -- EPERM settimeofday is called by someone other than the superuser - -- EINVAL Timezone (or something else) is invalid - -- EFAULT One of tv or tz pointed outside accessible address space - - -- None of these codes signal a potential clock skew, hence the return - -- value is never checked. - - Result := gettimeofday (TV'Access, System.Null_Address); - timeval_to_duration (TV'Access, sec'Access, usec'Access); - return Duration (sec) + Duration (usec) / Micro; - end Clock; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec; - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - timespec'(tv_sec => S, - tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Request : aliased timespec; - Remaind : aliased timespec; - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - - Result : Integer; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Request := To_Timespec (Rel_Time); - Result := nanosleep (Request'Access, Remaind'Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-posix2008.adb b/gcc/ada/libgnat/s-osprim-posix2008.adb deleted file mode 100644 index dd977a85414..00000000000 --- a/gcc/ada/libgnat/s-osprim-posix2008.adb +++ /dev/null @@ -1,172 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for POSIX.1-2008-like operating systems - -with System.CRTL; -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface because - -- we don't want to depend on any package. Consider removing these - -- declarations in System.OS_Interface and move these ones to the spec. - - type time_t is new System.CRTL.int64; - - type timespec is record - tv_sec : time_t; - tv_nsec : Long_Integer; - end record; - pragma Convention (C, timespec); - - function nanosleep (rqtp, rmtp : not null access timespec) return Integer; - pragma Import (C, nanosleep, "nanosleep"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - - type timeval is array (1 .. 3) of Long_Integer; - -- The timeval array is sized to contain Long_Long_Integer sec and - -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then - -- it will be overly large but that will not effect the implementation - -- since it is not accessed directly. - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access Long_Long_Integer; - usec : not null access Long_Integer); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased Long_Long_Integer; - usec : aliased Long_Integer; - TV : aliased timeval; - Result : Integer; - pragma Unreferenced (Result); - - function gettimeofday - (Tv : access timeval; - Tz : System.Address := System.Null_Address) return Integer; - pragma Import (C, gettimeofday, "gettimeofday"); - - begin - -- The return codes for gettimeofday are as follows (from man pages): - -- EPERM settimeofday is called by someone other than the superuser - -- EINVAL Timezone (or something else) is invalid - -- EFAULT One of tv or tz pointed outside accessible address space - - -- None of these codes signal a potential clock skew, hence the return - -- value is never checked. - - Result := gettimeofday (TV'Access, System.Null_Address); - timeval_to_duration (TV'Access, sec'Access, usec'Access); - return Duration (sec) + Duration (usec) / Micro; - end Clock; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec; - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - timespec'(tv_sec => S, - tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Request : aliased timespec; - Remaind : aliased timespec; - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - - Result : Integer; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Request := To_Timespec (Rel_Time); - Result := nanosleep (Request'Access, Remaind'Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-solaris.adb b/gcc/ada/libgnat/s-osprim-solaris.adb deleted file mode 100644 index c1c7e75401b..00000000000 --- a/gcc/ada/libgnat/s-osprim-solaris.adb +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version uses gettimeofday and select --- This file is suitable for Solaris (32 and 64 bits). - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type struct_timeval is record - tv_sec : Long_Integer; - tv_usec : Long_Integer; - end record; - pragma Convention (C, struct_timeval); - - procedure gettimeofday - (tv : not null access struct_timeval; - tz : Address := Null_Address); - pragma Import (C, gettimeofday, "gettimeofday"); - - procedure C_select - (n : Integer := 0; - readfds, - writefds, - exceptfds : Address := Null_Address; - timeout : not null access struct_timeval); - pragma Import (C, C_select, "select"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TV : aliased struct_timeval; - - begin - gettimeofday (TV'Access); - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - timeval : aliased struct_timeval; - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - timeval.tv_sec := Long_Integer (Rel_Time); - - if Duration (timeval.tv_sec) > Rel_Time then - timeval.tv_sec := timeval.tv_sec - 1; - end if; - - timeval.tv_usec := - Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); - - C_select (timeout => timeval'Unchecked_Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-unix.adb b/gcc/ada/libgnat/s-osprim-unix.adb deleted file mode 100644 index f273df65900..00000000000 --- a/gcc/ada/libgnat/s-osprim-unix.adb +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version uses gettimeofday and select --- This file is suitable for OpenNT, Dec Unix and SCO UnixWare. - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type struct_timeval is record - tv_sec : Integer; - tv_usec : Integer; - end record; - pragma Convention (C, struct_timeval); - - procedure gettimeofday - (tv : not null access struct_timeval; - tz : Address := Null_Address); - pragma Import (C, gettimeofday, "gettimeofday"); - - procedure C_select - (n : Integer := 0; - readfds, - writefds, - exceptfds : Address := Null_Address; - timeout : not null access struct_timeval); - pragma Import (C, C_select, "select"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TV : aliased struct_timeval; - - begin - gettimeofday (TV'Access); - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - timeval : aliased struct_timeval; - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - timeval.tv_sec := Integer (Rel_Time); - - if Duration (timeval.tv_sec) > Rel_Time then - timeval.tv_sec := timeval.tv_sec - 1; - end if; - - timeval.tv_usec := - Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); - - C_select (timeout => timeval'Unchecked_Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-vxworks.adb b/gcc/ada/libgnat/s-osprim-vxworks.adb deleted file mode 100644 index 2fa6cfe9025..00000000000 --- a/gcc/ada/libgnat/s-osprim-vxworks.adb +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for VxWorks targets - -with System.OS_Interface; --- Since the thread library is part of the VxWorks kernel, using OS_Interface --- is not a problem here, as long as we only use System.OS_Interface as a --- set of C imported routines: using Ada routines from this package would --- create a dependency on libgnarl in libgnat, which is not desirable. - -with System.OS_Constants; -with Interfaces.C; - -package body System.OS_Primitives is - - use System.OS_Interface; - use type Interfaces.C.int; - - package OSC renames System.OS_Constants; - - ------------------------ - -- Internal functions -- - ------------------------ - - function To_Clock_Ticks (D : Duration) return int; - -- Convert a duration value (in seconds) into clock ticks. - -- Note that this routine is duplicated from System.OS_Interface since - -- as explained above, we do not want to depend on libgnarl - - function To_Clock_Ticks (D : Duration) return int is - Ticks : Long_Long_Integer; - Rate_Duration : Duration; - Ticks_Duration : Duration; - - begin - if D < 0.0 then - return -1; - end if; - - -- Ensure that the duration can be converted to ticks - -- at the current clock tick rate without overflowing. - - Rate_Duration := Duration (sysClkRateGet); - - if D > (Duration'Last / Rate_Duration) then - Ticks := Long_Long_Integer (int'Last); - else - Ticks_Duration := D * Rate_Duration; - Ticks := Long_Long_Integer (Ticks_Duration); - - if Ticks_Duration > Duration (Ticks) then - Ticks := Ticks + 1; - end if; - - if Ticks > Long_Long_Integer (int'Last) then - Ticks := Long_Long_Integer (int'Last); - end if; - end if; - - return int (Ticks); - end To_Clock_Ticks; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TS : aliased timespec; - Result : int; - begin - Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); - pragma Assert (Result = 0); - return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; - end Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - Ticks : int; - - Result : int; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Ticks := To_Clock_Ticks (Rel_Time); - - if Mode = Relative and then Ticks < int'Last then - -- The first tick will delay anytime between 0 and - -- 1 / sysClkRateGet seconds, so we need to add one to - -- be on the safe side. - - Ticks := Ticks + 1; - end if; - - Result := taskDelay (Ticks); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-x32.adb b/gcc/ada/libgnat/s-osprim-x32.adb deleted file mode 100644 index 809e16348a0..00000000000 --- a/gcc/ada/libgnat/s-osprim-x32.adb +++ /dev/null @@ -1,167 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for Linux/x32 - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type time_t is new Long_Long_Integer; - - type timespec is record - tv_sec : time_t; - tv_nsec : Long_Long_Integer; - end record; - pragma Convention (C, timespec); - - function nanosleep (rqtp, rmtp : not null access timespec) return Integer; - pragma Import (C, nanosleep, "nanosleep"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - type timeval is array (1 .. 2) of Long_Long_Integer; - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access Long_Integer; - usec : not null access Long_Integer); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased Long_Integer; - usec : aliased Long_Integer; - TV : aliased timeval; - Result : Integer; - pragma Unreferenced (Result); - - function gettimeofday - (Tv : access timeval; - Tz : System.Address := System.Null_Address) return Integer; - pragma Import (C, gettimeofday, "gettimeofday"); - - begin - -- The return codes for gettimeofday are as follows (from man pages): - -- EPERM settimeofday is called by someone other than the superuser - -- EINVAL Timezone (or something else) is invalid - -- EFAULT One of tv or tz pointed outside accessible address space - - -- None of these codes signal a potential clock skew, hence the return - -- value is never checked. - - Result := gettimeofday (TV'Access, System.Null_Address); - timeval_to_duration (TV'Access, sec'Access, usec'Access); - return Duration (sec) + Duration (usec) / Micro; - end Clock; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return timespec; - - function To_Timespec (D : Duration) return timespec is - S : time_t; - F : Duration; - - begin - S := time_t (Long_Long_Integer (D)); - F := D - Duration (S); - - -- If F has negative value due to a round-up, adjust for positive F - -- value. - - if F < 0.0 then - S := S - 1; - F := F + 1.0; - end if; - - return - timespec'(tv_sec => S, - tv_nsec => Long_Long_Integer (F * 10#1#E9)); - end To_Timespec; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Request : aliased timespec; - Remaind : aliased timespec; - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - - Result : Integer; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Request := To_Timespec (Rel_Time); - Result := nanosleep (Request'Access, Remaind'Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__darwin.adb b/gcc/ada/libgnat/s-osprim__darwin.adb new file mode 100644 index 00000000000..b0f5fff2a09 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__darwin.adb @@ -0,0 +1,169 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for darwin + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type struct_timezone is record + tz_minuteswest : Integer; + tz_dsttime : Integer; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + type time_t is new Long_Integer; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : Integer; + end record; + pragma Convention (C, struct_timeval); + + function gettimeofday + (tv : not null access struct_timeval; + tz : struct_timezone_ptr) return Integer; + pragma Import (C, gettimeofday, "gettimeofday"); + + type timespec is record + tv_sec : time_t; + tv_nsec : Long_Integer; + end record; + pragma Convention (C, timespec); + + function nanosleep (rqtp, rmtp : not null access timespec) return Integer; + pragma Import (C, nanosleep, "nanosleep"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + Result : Integer; + pragma Unreferenced (Result); + + begin + -- The return codes for gettimeofday are as follows (from man pages): + -- EPERM settimeofday is called by someone other than the superuser + -- EINVAL Timezone (or something else) is invalid + -- EFAULT One of tv or tz pointed outside accessible address space + + -- None of these codes signal a potential clock skew, hence the return + -- value is never checked. + + Result := gettimeofday (TV'Access, null); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec; + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + timespec'(tv_sec => S, + tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + + Result : Integer; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Request := To_Timespec (Rel_Time); + Result := nanosleep (Request'Access, Remaind'Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__lynxos.ads b/gcc/ada/libgnat/s-osprim__lynxos.ads new file mode 100644 index 00000000000..26087fd783a --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__lynxos.ads @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides low level primitives used to implement clock and +-- delays in non tasking applications, for LynxOS. + +-- The choice of the real clock/delay implementation (depending on whether +-- tasking is involved or not) is done via soft links (see s-soflin.ads) + +-- NEVER add any dependency to tasking packages here + +package System.OS_Primitives is + pragma Preelaborate; + + Max_Sensible_Delay : constant Duration := 16#10_0000.0#; + -- LynxOS does not support delays as long as half a year, so we set this to + -- a shorter, but still fairly long, duration. Experiments show that if + -- pthread_cond_timedwait is passed an abstime much greater than about + -- 2**21, it fails, returning EAGAIN. The cutoff is somewhere between + -- 16#20_8000.0# and 16#20_F000.0#. This behavior is not documented. + + procedure Initialize; + -- Initialize global settings related to this package. This procedure + -- should be called before any other subprograms in this package. Note + -- that this procedure can be called several times. + + function Clock return Duration; + pragma Inline (Clock); + -- Returns "absolute" time, represented as an offset relative to "the + -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This + -- implementation is affected by system's clock changes. + + Relative : constant := 0; + Absolute_Calendar : constant := 1; + Absolute_RT : constant := 2; + -- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies + -- on these values. So any change here must be reflected in corresponding + -- changes in the compiler. + + procedure Timed_Delay (Time : Duration; Mode : Integer); + -- Implements the semantics of the delay statement when no tasking is used + -- in the application. + -- + -- Mode is one of the three values above + -- + -- Time is a relative or absolute duration value, depending on Mode. + -- + -- Note that currently Ada.Real_Time always uses the tasking run time, + -- so this procedure should never be called with Mode set to Absolute_RT. + -- This may change in future or bare board implementations. + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__mingw.adb b/gcc/ada/libgnat/s-osprim__mingw.adb new file mode 100644 index 00000000000..d729d857a74 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__mingw.adb @@ -0,0 +1,413 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the NT version of this package + +with System.Task_Lock; +with System.Win32.Ext; + +package body System.OS_Primitives is + + use System.Task_Lock; + use System.Win32; + use System.Win32.Ext; + + ---------------------------------------- + -- Data for the high resolution clock -- + ---------------------------------------- + + Tick_Frequency : aliased LARGE_INTEGER; + -- Holds frequency of high-performance counter used by Clock + -- Windows NT uses a 1_193_182 Hz counter on PCs. + + Base_Monotonic_Ticks : LARGE_INTEGER; + -- Holds the Tick count for the base monotonic time + + Base_Monotonic_Clock : Duration; + -- Holds the current clock for monotonic clock's base time + + type Clock_Data is record + Base_Ticks : LARGE_INTEGER; + -- Holds the Tick count for the base time + + Base_Time : Long_Long_Integer; + -- Holds the base time used to check for system time change, used with + -- the standard clock. + + Base_Clock : Duration; + -- Holds the current clock for the standard clock's base time + end record; + + type Clock_Data_Access is access all Clock_Data; + + -- Two base clock buffers. This is used to be able to update a buffer while + -- the other buffer is read. The point is that we do not want to use a lock + -- inside the Clock routine for performance reasons. We still use a lock + -- in the Get_Base_Time which is called very rarely. Current is a pointer, + -- the pragma Atomic is there to ensure that the value can be set or read + -- atomically. That's it, when Get_Base_Time has updated a buffer the + -- switch to the new value is done by changing Current pointer. + + First, Second : aliased Clock_Data; + + Current : Clock_Data_Access := First'Access; + pragma Atomic (Current); + + -- The following signature is to detect change on the base clock data + -- above. The signature is a modular type, it will wrap around without + -- raising an exception. We would need to have exactly 2**32 updates of + -- the base data for the changes to get undetected. + + type Signature_Type is mod 2**32; + Signature : Signature_Type := 0; + pragma Atomic (Signature); + + function Monotonic_Clock return Duration; + pragma Export (Ada, Monotonic_Clock, "__gnat_monotonic_clock"); + -- Return "absolute" time, represented as an offset relative to "the Unix + -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is + -- immune to the system's clock changes. Export this function so that it + -- can be imported from s-taprop-mingw.adb without changing the shared + -- spec (s-osprim.ads). + + procedure Get_Base_Time (Data : in out Clock_Data); + -- Retrieve the base time and base ticks. These values will be used by + -- clock to compute the current time by adding to it a fraction of the + -- performance counter. This is for the implementation of a high-resolution + -- clock. Note that this routine does not change the base monotonic values + -- used by the monotonic clock. + + ----------- + -- Clock -- + ----------- + + -- This implementation of clock provides high resolution timer values + -- using QueryPerformanceCounter. This call return a 64 bits values (based + -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182 + -- times per seconds. The call to QueryPerformanceCounter takes 6 + -- microsecs to complete. + + function Clock return Duration is + Max_Shift : constant Duration := 2.0; + Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7; + Data : Clock_Data; + Current_Ticks : aliased LARGE_INTEGER; + Elap_Secs_Tick : Duration; + Elap_Secs_Sys : Duration; + Now : aliased Long_Long_Integer; + Sig1, Sig2 : Signature_Type; + + begin + -- Try ten times to get a coherent set of base data. For this we just + -- check that the signature hasn't changed during the copy of the + -- current data. + -- + -- This loop will always be done once if there is no interleaved call + -- to Get_Base_Time. + + for K in 1 .. 10 loop + Sig1 := Signature; + Data := Current.all; + Sig2 := Signature; + exit when Sig1 = Sig2; + end loop; + + if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then + return 0.0; + end if; + + GetSystemTimeAsFileTime (Now'Access); + + Elap_Secs_Sys := + Duration (Long_Long_Float (abs (Now - Data.Base_Time)) / + Hundreds_Nano_In_Sec); + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) / + Long_Long_Float (Tick_Frequency)); + + -- If we have a shift of more than Max_Shift seconds we resynchronize + -- the Clock. This is probably due to a manual Clock adjustment, a DST + -- adjustment or an NTP synchronisation. And we want to adjust the time + -- for this system (non-monotonic) clock. + + if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then + Get_Base_Time (Data); + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) / + Long_Long_Float (Tick_Frequency)); + end if; + + return Data.Base_Clock + Elap_Secs_Tick; + end Clock; + + ------------------- + -- Get_Base_Time -- + ------------------- + + procedure Get_Base_Time (Data : in out Clock_Data) is + + -- The resolution for GetSystemTime is 1 millisecond + + -- The time to get both base times should take less than 1 millisecond. + -- Therefore, the elapsed time reported by GetSystemTime between both + -- actions should be null. + + epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch + system_time_ns : constant := 100; -- 100 ns per tick + Sec_Unit : constant := 10#1#E9; + + Max_Elapsed : constant LARGE_INTEGER := + LARGE_INTEGER (Tick_Frequency / 100_000); + -- Look for a precision of 0.01 ms + + Sig : constant Signature_Type := Signature; + + Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER; + Loc_Time, Ctrl_Time : aliased Long_Long_Integer; + Elapsed : LARGE_INTEGER; + Current_Max : LARGE_INTEGER := LARGE_INTEGER'Last; + New_Data : Clock_Data_Access; + + begin + -- Here we must be sure that both of these calls are done in a short + -- amount of time. Both are base time and should in theory be taken + -- at the very same time. + + -- The goal of the following loop is to synchronize the system time + -- with the Win32 performance counter by getting a base offset for both. + -- Using these offsets it is then possible to compute actual time using + -- a performance counter which has a better precision than the Win32 + -- time API. + + -- Try at most 10 times to reach the best synchronisation (below 1 + -- millisecond) otherwise the runtime will use the best value reached + -- during the runs. + + Lock; + + -- First check that the current value has not been updated. This + -- could happen if another task has called Clock at the same time + -- and that Max_Shift has been reached too. + -- + -- But if the current value has been changed just before we entered + -- into the critical section, we can safely return as the current + -- base data (time, clock, ticks) have already been updated. + + if Sig /= Signature then + Unlock; + return; + end if; + + -- Check for the unused data buffer and set New_Data to point to it + + if Current = First'Access then + New_Data := Second'Access; + else + New_Data := First'Access; + end if; + + for K in 1 .. 10 loop + if QueryPerformanceCounter (Loc_Ticks'Access) = Win32.FALSE then + pragma Assert + (Standard.False, + "Could not query high performance counter in Clock"); + null; + end if; + + GetSystemTimeAsFileTime (Ctrl_Time'Access); + + -- Scan for clock tick, will take up to 16ms/1ms depending on PC. + -- This cannot be an infinite loop or the system hardware is badly + -- damaged. + + loop + GetSystemTimeAsFileTime (Loc_Time'Access); + + if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then + pragma Assert + (Standard.False, + "Could not query high performance counter in Clock"); + null; + end if; + + exit when Loc_Time /= Ctrl_Time; + Loc_Ticks := Ctrl_Ticks; + end loop; + + -- Check elapsed Performance Counter between samples + -- to choose the best one. + + Elapsed := Ctrl_Ticks - Loc_Ticks; + + if Elapsed < Current_Max then + New_Data.Base_Time := Loc_Time; + New_Data.Base_Ticks := Loc_Ticks; + Current_Max := Elapsed; + + -- Exit the loop when we have reached the expected precision + + exit when Elapsed <= Max_Elapsed; + end if; + end loop; + + New_Data.Base_Clock := + Duration + (Long_Long_Float + ((New_Data.Base_Time - epoch_1970) * system_time_ns) / + Long_Long_Float (Sec_Unit)); + + -- At this point all the base values have been set into the new data + -- record. Change the pointer (atomic operation) to these new values. + + Current := New_Data; + Data := New_Data.all; + + -- Set new signature for this data set + + Signature := Signature + 1; + + Unlock; + + exception + when others => + Unlock; + raise; + end Get_Base_Time; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + Current_Ticks : aliased LARGE_INTEGER; + Elap_Secs_Tick : Duration; + + begin + if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then + return 0.0; + + else + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - Base_Monotonic_Ticks) / + Long_Long_Float (Tick_Frequency)); + return Base_Monotonic_Clock + Elap_Secs_Tick; + end if; + end Monotonic_Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay (Time : Duration; Mode : Integer) is + function Mode_Clock return Duration; + pragma Inline (Mode_Clock); + -- Return the current clock value using either the monotonic clock or + -- standard clock depending on the Mode value. + + ---------------- + -- Mode_Clock -- + ---------------- + + function Mode_Clock return Duration is + begin + case Mode is + when Absolute_RT => return Monotonic_Clock; + when others => return Clock; + end case; + end Mode_Clock; + + -- Local Variables + + Base_Time : constant Duration := Mode_Clock; + -- Base_Time is used to detect clock set backward, in this case we + -- cannot ensure the delay accuracy. + + Rel_Time : Duration; + Abs_Time : Duration; + Check_Time : Duration := Base_Time; + + -- Start of processing for Timed Delay + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Sleep (DWORD (Rel_Time * 1000.0)); + Check_Time := Mode_Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Get starting time as base + + if QueryPerformanceFrequency (Tick_Frequency'Access) = Win32.FALSE then + raise Program_Error with + "cannot get high performance counter frequency"; + end if; + + Get_Base_Time (Current.all); + + -- Keep base clock and ticks for the monotonic clock. These values + -- should never be changed to ensure proper behavior of the monotonic + -- clock. + + Base_Monotonic_Clock := Current.Base_Clock; + Base_Monotonic_Ticks := Current.Base_Ticks; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__posix.adb b/gcc/ada/libgnat/s-osprim__posix.adb new file mode 100644 index 00000000000..8911b16b3a9 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__posix.adb @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for POSIX-like operating systems + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type time_t is new Long_Integer; + + type timespec is record + tv_sec : time_t; + tv_nsec : Long_Integer; + end record; + pragma Convention (C, timespec); + + function nanosleep (rqtp, rmtp : not null access timespec) return Integer; + pragma Import (C, nanosleep, "nanosleep"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + + type timeval is array (1 .. 3) of Long_Integer; + -- The timeval array is sized to contain Long_Long_Integer sec and + -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then + -- it will be overly large but that will not effect the implementation + -- since it is not accessed directly. + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access Long_Long_Integer; + usec : not null access Long_Integer); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased Long_Long_Integer; + usec : aliased Long_Integer; + TV : aliased timeval; + Result : Integer; + pragma Unreferenced (Result); + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return Integer; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + -- The return codes for gettimeofday are as follows (from man pages): + -- EPERM settimeofday is called by someone other than the superuser + -- EINVAL Timezone (or something else) is invalid + -- EFAULT One of tv or tz pointed outside accessible address space + + -- None of these codes signal a potential clock skew, hence the return + -- value is never checked. + + Result := gettimeofday (TV'Access, System.Null_Address); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end Clock; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec; + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + timespec'(tv_sec => S, + tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + + Result : Integer; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Request := To_Timespec (Rel_Time); + Result := nanosleep (Request'Access, Remaind'Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__posix2008.adb b/gcc/ada/libgnat/s-osprim__posix2008.adb new file mode 100644 index 00000000000..dd977a85414 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__posix2008.adb @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for POSIX.1-2008-like operating systems + +with System.CRTL; +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface because + -- we don't want to depend on any package. Consider removing these + -- declarations in System.OS_Interface and move these ones to the spec. + + type time_t is new System.CRTL.int64; + + type timespec is record + tv_sec : time_t; + tv_nsec : Long_Integer; + end record; + pragma Convention (C, timespec); + + function nanosleep (rqtp, rmtp : not null access timespec) return Integer; + pragma Import (C, nanosleep, "nanosleep"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + + type timeval is array (1 .. 3) of Long_Integer; + -- The timeval array is sized to contain Long_Long_Integer sec and + -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then + -- it will be overly large but that will not effect the implementation + -- since it is not accessed directly. + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access Long_Long_Integer; + usec : not null access Long_Integer); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased Long_Long_Integer; + usec : aliased Long_Integer; + TV : aliased timeval; + Result : Integer; + pragma Unreferenced (Result); + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return Integer; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + -- The return codes for gettimeofday are as follows (from man pages): + -- EPERM settimeofday is called by someone other than the superuser + -- EINVAL Timezone (or something else) is invalid + -- EFAULT One of tv or tz pointed outside accessible address space + + -- None of these codes signal a potential clock skew, hence the return + -- value is never checked. + + Result := gettimeofday (TV'Access, System.Null_Address); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end Clock; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec; + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + timespec'(tv_sec => S, + tv_nsec => Long_Integer (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + + Result : Integer; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Request := To_Timespec (Rel_Time); + Result := nanosleep (Request'Access, Remaind'Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__solaris.adb b/gcc/ada/libgnat/s-osprim__solaris.adb new file mode 100644 index 00000000000..c1c7e75401b --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__solaris.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version uses gettimeofday and select +-- This file is suitable for Solaris (32 and 64 bits). + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type struct_timeval is record + tv_sec : Long_Integer; + tv_usec : Long_Integer; + end record; + pragma Convention (C, struct_timeval); + + procedure gettimeofday + (tv : not null access struct_timeval; + tz : Address := Null_Address); + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure C_select + (n : Integer := 0; + readfds, + writefds, + exceptfds : Address := Null_Address; + timeout : not null access struct_timeval); + pragma Import (C, C_select, "select"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + begin + gettimeofday (TV'Access); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + timeval : aliased struct_timeval; + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + timeval.tv_sec := Long_Integer (Rel_Time); + + if Duration (timeval.tv_sec) > Rel_Time then + timeval.tv_sec := timeval.tv_sec - 1; + end if; + + timeval.tv_usec := + Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); + + C_select (timeout => timeval'Unchecked_Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__unix.adb b/gcc/ada/libgnat/s-osprim__unix.adb new file mode 100644 index 00000000000..f273df65900 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__unix.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version uses gettimeofday and select +-- This file is suitable for OpenNT, Dec Unix and SCO UnixWare. + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type struct_timeval is record + tv_sec : Integer; + tv_usec : Integer; + end record; + pragma Convention (C, struct_timeval); + + procedure gettimeofday + (tv : not null access struct_timeval; + tz : Address := Null_Address); + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure C_select + (n : Integer := 0; + readfds, + writefds, + exceptfds : Address := Null_Address; + timeout : not null access struct_timeval); + pragma Import (C, C_select, "select"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + begin + gettimeofday (TV'Access); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + timeval : aliased struct_timeval; + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + timeval.tv_sec := Integer (Rel_Time); + + if Duration (timeval.tv_sec) > Rel_Time then + timeval.tv_sec := timeval.tv_sec - 1; + end if; + + timeval.tv_usec := + Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); + + C_select (timeout => timeval'Unchecked_Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__vxworks.adb b/gcc/ada/libgnat/s-osprim__vxworks.adb new file mode 100644 index 00000000000..2fa6cfe9025 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__vxworks.adb @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for VxWorks targets + +with System.OS_Interface; +-- Since the thread library is part of the VxWorks kernel, using OS_Interface +-- is not a problem here, as long as we only use System.OS_Interface as a +-- set of C imported routines: using Ada routines from this package would +-- create a dependency on libgnarl in libgnat, which is not desirable. + +with System.OS_Constants; +with Interfaces.C; + +package body System.OS_Primitives is + + use System.OS_Interface; + use type Interfaces.C.int; + + package OSC renames System.OS_Constants; + + ------------------------ + -- Internal functions -- + ------------------------ + + function To_Clock_Ticks (D : Duration) return int; + -- Convert a duration value (in seconds) into clock ticks. + -- Note that this routine is duplicated from System.OS_Interface since + -- as explained above, we do not want to depend on libgnarl + + function To_Clock_Ticks (D : Duration) return int is + Ticks : Long_Long_Integer; + Rate_Duration : Duration; + Ticks_Duration : Duration; + + begin + if D < 0.0 then + return -1; + end if; + + -- Ensure that the duration can be converted to ticks + -- at the current clock tick rate without overflowing. + + Rate_Duration := Duration (sysClkRateGet); + + if D > (Duration'Last / Rate_Duration) then + Ticks := Long_Long_Integer (int'Last); + else + Ticks_Duration := D * Rate_Duration; + Ticks := Long_Long_Integer (Ticks_Duration); + + if Ticks_Duration > Duration (Ticks) then + Ticks := Ticks + 1; + end if; + + if Ticks > Long_Long_Integer (int'Last) then + Ticks := Long_Long_Integer (int'Last); + end if; + end if; + + return int (Ticks); + end To_Clock_Ticks; + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TS : aliased timespec; + Result : int; + begin + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); + pragma Assert (Result = 0); + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + end Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + Ticks : int; + + Result : int; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Ticks := To_Clock_Ticks (Rel_Time); + + if Mode = Relative and then Ticks < int'Last then + -- The first tick will delay anytime between 0 and + -- 1 / sysClkRateGet seconds, so we need to add one to + -- be on the safe side. + + Ticks := Ticks + 1; + end if; + + Result := taskDelay (Ticks); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim__x32.adb b/gcc/ada/libgnat/s-osprim__x32.adb new file mode 100644 index 00000000000..809e16348a0 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim__x32.adb @@ -0,0 +1,167 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for Linux/x32 + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type time_t is new Long_Long_Integer; + + type timespec is record + tv_sec : time_t; + tv_nsec : Long_Long_Integer; + end record; + pragma Convention (C, timespec); + + function nanosleep (rqtp, rmtp : not null access timespec) return Integer; + pragma Import (C, nanosleep, "nanosleep"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + type timeval is array (1 .. 2) of Long_Long_Integer; + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access Long_Integer; + usec : not null access Long_Integer); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased Long_Integer; + usec : aliased Long_Integer; + TV : aliased timeval; + Result : Integer; + pragma Unreferenced (Result); + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return Integer; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + -- The return codes for gettimeofday are as follows (from man pages): + -- EPERM settimeofday is called by someone other than the superuser + -- EINVAL Timezone (or something else) is invalid + -- EFAULT One of tv or tz pointed outside accessible address space + + -- None of these codes signal a potential clock skew, hence the return + -- value is never checked. + + Result := gettimeofday (TV'Access, System.Null_Address); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end Clock; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return timespec; + + function To_Timespec (D : Duration) return timespec is + S : time_t; + F : Duration; + + begin + S := time_t (Long_Long_Integer (D)); + F := D - Duration (S); + + -- If F has negative value due to a round-up, adjust for positive F + -- value. + + if F < 0.0 then + S := S - 1; + F := F + 1.0; + end if; + + return + timespec'(tv_sec => S, + tv_nsec => Long_Long_Integer (F * 10#1#E9)); + end To_Timespec; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + + Result : Integer; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Request := To_Timespec (Rel_Time); + Result := nanosleep (Request'Access, Remaind'Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osvers__vxworks-653.ads b/gcc/ada/libgnat/s-osvers__vxworks-653.ads new file mode 100644 index 00000000000..48256b3c87d --- /dev/null +++ b/gcc/ada/libgnat/s-osvers__vxworks-653.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . O S _ V E R S I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010-2017, 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- -- +-- 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 -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks 653 Partition OS version of this file. If you add an OS +-- variant please be sure to update type OS_Version in all variants of this +-- file, which is part of the Level A certified run-time libraries. + +package System.OS_Versions is + pragma Pure (System.OS_Versions); + type OS_Version is + (LynxOS_178, VxWorks_Cert, VxWorks_Cert_RTP, VxWorks_653, VxWorks_MILS); + OS : constant OS_Version := VxWorks_653; +end System.OS_Versions; diff --git a/gcc/ada/libgnat/s-parame-ae653.ads b/gcc/ada/libgnat/s-parame-ae653.ads deleted file mode 100644 index 8a787f007bc..00000000000 --- a/gcc/ada/libgnat/s-parame-ae653.ads +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version is used by VxWorks 653, VxWorks MILS, and VxWorks6 cert Ravenscar - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := 25; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - 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 := 14_336; - -- 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. - -- This value is chosen as the VxWorks default stack size is 20kB, - -- and a little more than 4kB is necessary for the run time. - - 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. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this may not be true - -- 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. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- 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 := 8; - -- Number of task attributes stored in the task control block - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 32; - -- 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/gcc/ada/libgnat/s-parame-hpux.ads b/gcc/ada/libgnat/s-parame-hpux.ads deleted file mode 100644 index f20cfbebe7e..00000000000 --- a/gcc/ada/libgnat/s-parame-hpux.ads +++ /dev/null @@ -1,199 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the HP version of this package - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - 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 := False; - -- 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. - - ---------------------------------------------- - -- Characteristics of Types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this may not be true - -- 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. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- 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/gcc/ada/libgnat/s-parame-rtems.adb b/gcc/ada/libgnat/s-parame-rtems.adb deleted file mode 100644 index aa131147eb6..00000000000 --- a/gcc/ada/libgnat/s-parame-rtems.adb +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2009 Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, or (at your option) any later ver- -- --- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- --- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- --- or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the RTEMS specific version - -with Interfaces.C; - -package body System.Parameters is - - function ada_pthread_minimum_stack_size return Interfaces.C.size_t; - pragma Import (C, ada_pthread_minimum_stack_size, - "_ada_pthread_minimum_stack_size"); - - ------------------------ - -- Default_Stack_Size -- - ------------------------ - - function Default_Stack_Size return Size_Type is - begin - return Size_Type (ada_pthread_minimum_stack_size); - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - - begin - return Size_Type (ada_pthread_minimum_stack_size); - end Minimum_Stack_Size; - - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - - else - return Size; - end if; - end Adjust_Storage_Size; - -end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame-vxworks.adb b/gcc/ada/libgnat/s-parame-vxworks.adb deleted file mode 100644 index 325aa2e4f08..00000000000 --- a/gcc/ada/libgnat/s-parame-vxworks.adb +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2017, 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version used on all VxWorks targets - -package body System.Parameters is - - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - else - return Size; - end if; - end Adjust_Storage_Size; - - ------------------------ - -- Default_Stack_Size -- - ------------------------ - - function Default_Stack_Size return Size_Type is - Default_Stack_Size : Integer; - pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); - begin - if Default_Stack_Size = -1 then - if Stack_Check_Limits then - return 32 * 1024; - -- Extra stack to allow for 12K exception area. - else - return 20 * 1024; - end if; - else - return Size_Type (Default_Stack_Size); - end if; - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - begin - return 8 * 1024; - end Minimum_Stack_Size; - -end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame-vxworks.ads b/gcc/ada/libgnat/s-parame-vxworks.ads deleted file mode 100644 index 919361ad10d..00000000000 --- a/gcc/ada/libgnat/s-parame-vxworks.ads +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 -- --- . -- --- -- --- 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 VxWorks version of the package - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - 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 := 14_336; - -- 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. - -- This value is chosen as the VxWorks default stack size is 20kB, - -- and a little more than 4kB is necessary for the run time. - - 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. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this may not be true - -- 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. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- 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 := 16; - -- Number of task attributes stored in the task control block - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 32; - -- 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/gcc/ada/libgnat/s-parame__ae653.ads b/gcc/ada/libgnat/s-parame__ae653.ads new file mode 100644 index 00000000000..8a787f007bc --- /dev/null +++ b/gcc/ada/libgnat/s-parame__ae653.ads @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version is used by VxWorks 653, VxWorks MILS, and VxWorks6 cert Ravenscar + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Percentage is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Percentage : constant Percentage := 25; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + 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 := 14_336; + -- 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. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + 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. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this may not be true + -- 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. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- 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 := 8; + -- Number of task attributes stored in the task control block + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 32; + -- 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/gcc/ada/libgnat/s-parame__hpux.ads b/gcc/ada/libgnat/s-parame__hpux.ads new file mode 100644 index 00000000000..f20cfbebe7e --- /dev/null +++ b/gcc/ada/libgnat/s-parame__hpux.ads @@ -0,0 +1,199 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the HP version of this package + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Percentage is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Percentage : constant Percentage := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + 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 := False; + -- 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. + + ---------------------------------------------- + -- Characteristics of Types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this may not be true + -- 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. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- 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/gcc/ada/libgnat/s-parame__rtems.adb b/gcc/ada/libgnat/s-parame__rtems.adb new file mode 100644 index 00000000000..aa131147eb6 --- /dev/null +++ b/gcc/ada/libgnat/s-parame__rtems.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS specific version + +with Interfaces.C; + +package body System.Parameters is + + function ada_pthread_minimum_stack_size return Interfaces.C.size_t; + pragma Import (C, ada_pthread_minimum_stack_size, + "_ada_pthread_minimum_stack_size"); + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + begin + return Size_Type (ada_pthread_minimum_stack_size); + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + + begin + return Size_Type (ada_pthread_minimum_stack_size); + end Minimum_Stack_Size; + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame__vxworks.adb b/gcc/ada/libgnat/s-parame__vxworks.adb new file mode 100644 index 00000000000..325aa2e4f08 --- /dev/null +++ b/gcc/ada/libgnat/s-parame__vxworks.adb @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version used on all VxWorks targets + +package body System.Parameters is + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + else + return Size; + end if; + end Adjust_Storage_Size; + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + Default_Stack_Size : Integer; + pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); + begin + if Default_Stack_Size = -1 then + if Stack_Check_Limits then + return 32 * 1024; + -- Extra stack to allow for 12K exception area. + else + return 20 * 1024; + end if; + else + return Size_Type (Default_Stack_Size); + end if; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + return 8 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame__vxworks.ads b/gcc/ada/libgnat/s-parame__vxworks.ads new file mode 100644 index 00000000000..919361ad10d --- /dev/null +++ b/gcc/ada/libgnat/s-parame__vxworks.ads @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- 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 VxWorks version of the package + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Percentage is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Percentage : constant Percentage := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + 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 := 14_336; + -- 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. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + 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. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this may not be true + -- 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. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- 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 := 16; + -- Number of task attributes stored in the task control block + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 32; + -- 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/gcc/ada/libgnat/s-stchop-limit.ads b/gcc/ada/libgnat/s-stchop-limit.ads deleted file mode 100644 index 6ab2f0a5787..00000000000 --- a/gcc/ada/libgnat/s-stchop-limit.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of this package is for implementations which use --- the stack limit approach (the limit of the stack is stored into a per --- thread variable). - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the binder --- does not handle references to this package. - -pragma Polling (Off); --- Turn off polling, we do not want polling to take place during stack --- checking operations. It causes infinite loops and other problems. - -package System.Stack_Checking.Operations is - pragma Preelaborate; - - procedure Initialize_Stack_Limit; - pragma Export (C, Initialize_Stack_Limit, - "__gnat_initialize_stack_limit"); - -- This procedure is called before elaboration to setup the stack limit - -- for the environment task and to register the hook to be called at - -- task creation. -end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop-rtems.adb b/gcc/ada/libgnat/s-stchop-rtems.adb deleted file mode 100644 index ac0cfd0f489..00000000000 --- a/gcc/ada/libgnat/s-stchop-rtems.adb +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the RTEMS version of this package. --- This file should be kept synchronized with the general implementation --- provided by s-stchop.adb. - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the --- binder does not handle references to this package. - -with Ada.Exceptions; - -with Interfaces.C; use Interfaces.C; - -package body System.Stack_Checking.Operations is - - ---------------------------- - -- Invalidate_Stack_Cache -- - ---------------------------- - - procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is - pragma Warnings (Off, Any_Stack); - begin - Cache := Null_Stack; - end Invalidate_Stack_Cache; - - ----------------------------- - -- Notify_Stack_Attributes -- - ----------------------------- - - procedure Notify_Stack_Attributes - (Initial_SP : System.Address; - Size : System.Storage_Elements.Storage_Offset) - is - - -- RTEMS keeps all the information we need. - - pragma Unreferenced (Size); - pragma Unreferenced (Initial_SP); - - begin - null; - end Notify_Stack_Attributes; - - ----------------- - -- Stack_Check -- - ----------------- - - function Stack_Check - (Stack_Address : System.Address) return Stack_Access - is - pragma Unreferenced (Stack_Address); - - -- RTEMS has a routine to check if the stack is blown. - -- It returns a C99 bool. - function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char; - pragma Import (C, - rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown"); - - begin - -- RTEMS has a routine to check this. So use it. - - if rtems_stack_checker_is_blown /= 0 then - Ada.Exceptions.Raise_Exception - (E => Storage_Error'Identity, - Message => "stack overflow detected"); - end if; - - return null; - - end Stack_Check; - - ------------------------ - -- Update_Stack_Cache -- - ------------------------ - - procedure Update_Stack_Cache (Stack : Stack_Access) is - begin - if not Multi_Processor then - Cache := Stack; - end if; - end Update_Stack_Cache; - -end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop-vxworks.adb b/gcc/ada/libgnat/s-stchop-vxworks.adb deleted file mode 100644 index 25b07db7a4e..00000000000 --- a/gcc/ada/libgnat/s-stchop-vxworks.adb +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- --- -- --- GNARL 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 -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the verson for VxWorks 5, VxWorks 6 Cert and VxWorks MILS - --- This file should be kept synchronized with the general implementation --- provided by s-stchop.adb. - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the --- binder does not handle references to this package. - -with System.Storage_Elements; use System.Storage_Elements; -with System.Parameters; use System.Parameters; -with Interfaces.C; - -package body System.Stack_Checking.Operations is - - -- In order to have stack checking working appropriately on VxWorks we need - -- to extract the stack size information from the VxWorks kernel itself. - - -- For VxWorks 5 & 6 the library for showing task-related information - -- needs to be linked into the VxWorks system, when using stack checking. - -- The taskShow library can be linked into the VxWorks system by either: - - -- * defining INCLUDE_SHOW_ROUTINES in config.h when using - -- configuration header files, or - - -- * selecting INCLUDE_TASK_SHOW when using the Tornado project - -- facility. - - -- VxWorks MILS includes the necessary routine in taskLib, so nothing - -- special needs to be done there. - - Stack_Limit : Address; - - pragma Import (C, Stack_Limit, "__gnat_stack_limit"); - - -- Stack_Limit contains the limit of the stack. This variable is later made - -- a task variable (by calling taskVarAdd) and then correctly set to the - -- stack limit of the task. Before being so initialized its value must be - -- valid so that any subprogram with stack checking enabled will run. We - -- use extreme values according to the direction of the stack. - - type Set_Stack_Limit_Proc_Acc is access procedure; - pragma Convention (C, Set_Stack_Limit_Proc_Acc); - - Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; - pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); - -- Procedure to be called when a task is created to set stack - -- limit. - - procedure Set_Stack_Limit_For_Current_Task; - pragma Convention (C, Set_Stack_Limit_For_Current_Task); - -- Register Initial_SP as the initial stack pointer value for the current - -- task when it starts and Size as the associated stack area size. This - -- should be called once, after the soft-links have been initialized? - - ----------------------------- - -- Initialize_Stack_Limit -- - ----------------------------- - - procedure Initialize_Stack_Limit is - begin - - Set_Stack_Limit_For_Current_Task; - - -- Will be called by every created task - - Set_Stack_Limit_Hook := Set_Stack_Limit_For_Current_Task'Access; - end Initialize_Stack_Limit; - - -------------------------------------- - -- Set_Stack_Limit_For_Current_Task -- - -------------------------------------- - - procedure Set_Stack_Limit_For_Current_Task is - use Interfaces.C; - - type OS_Stack_Info is record - Size : Interfaces.C.int; - Base : System.Address; - Limit : System.Address; - end record; - pragma Convention (C, OS_Stack_Info); - -- Type representing the information that we want to extract from the - -- underlying kernel. - - procedure Get_Stack_Info (Stack : not null access OS_Stack_Info); - pragma Import (C, Get_Stack_Info, "__gnat_get_stack_info"); - -- Procedure that fills the stack information associated to the - -- currently executing task. - - Stack_Info : aliased OS_Stack_Info; - - Limit : System.Address; - - begin - - -- Get stack bounds from VxWorks - - Get_Stack_Info (Stack_Info'Access); - - if Stack_Grows_Down then - Limit := - Stack_Info.Base - Storage_Offset (Stack_Info.Size) + - Storage_Offset'(12_000); - else - Limit := - Stack_Info.Base + Storage_Offset (Stack_Info.Size) - - Storage_Offset'(12_000); - end if; - - Stack_Limit := Limit; - - end Set_Stack_Limit_For_Current_Task; -end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop__limit.ads b/gcc/ada/libgnat/s-stchop__limit.ads new file mode 100644 index 00000000000..6ab2f0a5787 --- /dev/null +++ b/gcc/ada/libgnat/s-stchop__limit.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of this package is for implementations which use +-- the stack limit approach (the limit of the stack is stored into a per +-- thread variable). + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the binder +-- does not handle references to this package. + +pragma Polling (Off); +-- Turn off polling, we do not want polling to take place during stack +-- checking operations. It causes infinite loops and other problems. + +package System.Stack_Checking.Operations is + pragma Preelaborate; + + procedure Initialize_Stack_Limit; + pragma Export (C, Initialize_Stack_Limit, + "__gnat_initialize_stack_limit"); + -- This procedure is called before elaboration to setup the stack limit + -- for the environment task and to register the hook to be called at + -- task creation. +end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop__rtems.adb b/gcc/ada/libgnat/s-stchop__rtems.adb new file mode 100644 index 00000000000..ac0cfd0f489 --- /dev/null +++ b/gcc/ada/libgnat/s-stchop__rtems.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS version of this package. +-- This file should be kept synchronized with the general implementation +-- provided by s-stchop.adb. + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the +-- binder does not handle references to this package. + +with Ada.Exceptions; + +with Interfaces.C; use Interfaces.C; + +package body System.Stack_Checking.Operations is + + ---------------------------- + -- Invalidate_Stack_Cache -- + ---------------------------- + + procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is + pragma Warnings (Off, Any_Stack); + begin + Cache := Null_Stack; + end Invalidate_Stack_Cache; + + ----------------------------- + -- Notify_Stack_Attributes -- + ----------------------------- + + procedure Notify_Stack_Attributes + (Initial_SP : System.Address; + Size : System.Storage_Elements.Storage_Offset) + is + + -- RTEMS keeps all the information we need. + + pragma Unreferenced (Size); + pragma Unreferenced (Initial_SP); + + begin + null; + end Notify_Stack_Attributes; + + ----------------- + -- Stack_Check -- + ----------------- + + function Stack_Check + (Stack_Address : System.Address) return Stack_Access + is + pragma Unreferenced (Stack_Address); + + -- RTEMS has a routine to check if the stack is blown. + -- It returns a C99 bool. + function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char; + pragma Import (C, + rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown"); + + begin + -- RTEMS has a routine to check this. So use it. + + if rtems_stack_checker_is_blown /= 0 then + Ada.Exceptions.Raise_Exception + (E => Storage_Error'Identity, + Message => "stack overflow detected"); + end if; + + return null; + + end Stack_Check; + + ------------------------ + -- Update_Stack_Cache -- + ------------------------ + + procedure Update_Stack_Cache (Stack : Stack_Access) is + begin + if not Multi_Processor then + Cache := Stack; + end if; + end Update_Stack_Cache; + +end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop__vxworks.adb b/gcc/ada/libgnat/s-stchop__vxworks.adb new file mode 100644 index 00000000000..25b07db7a4e --- /dev/null +++ b/gcc/ada/libgnat/s-stchop__vxworks.adb @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNARL 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 -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the verson for VxWorks 5, VxWorks 6 Cert and VxWorks MILS + +-- This file should be kept synchronized with the general implementation +-- provided by s-stchop.adb. + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the +-- binder does not handle references to this package. + +with System.Storage_Elements; use System.Storage_Elements; +with System.Parameters; use System.Parameters; +with Interfaces.C; + +package body System.Stack_Checking.Operations is + + -- In order to have stack checking working appropriately on VxWorks we need + -- to extract the stack size information from the VxWorks kernel itself. + + -- For VxWorks 5 & 6 the library for showing task-related information + -- needs to be linked into the VxWorks system, when using stack checking. + -- The taskShow library can be linked into the VxWorks system by either: + + -- * defining INCLUDE_SHOW_ROUTINES in config.h when using + -- configuration header files, or + + -- * selecting INCLUDE_TASK_SHOW when using the Tornado project + -- facility. + + -- VxWorks MILS includes the necessary routine in taskLib, so nothing + -- special needs to be done there. + + Stack_Limit : Address; + + pragma Import (C, Stack_Limit, "__gnat_stack_limit"); + + -- Stack_Limit contains the limit of the stack. This variable is later made + -- a task variable (by calling taskVarAdd) and then correctly set to the + -- stack limit of the task. Before being so initialized its value must be + -- valid so that any subprogram with stack checking enabled will run. We + -- use extreme values according to the direction of the stack. + + type Set_Stack_Limit_Proc_Acc is access procedure; + pragma Convention (C, Set_Stack_Limit_Proc_Acc); + + Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; + pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); + -- Procedure to be called when a task is created to set stack + -- limit. + + procedure Set_Stack_Limit_For_Current_Task; + pragma Convention (C, Set_Stack_Limit_For_Current_Task); + -- Register Initial_SP as the initial stack pointer value for the current + -- task when it starts and Size as the associated stack area size. This + -- should be called once, after the soft-links have been initialized? + + ----------------------------- + -- Initialize_Stack_Limit -- + ----------------------------- + + procedure Initialize_Stack_Limit is + begin + + Set_Stack_Limit_For_Current_Task; + + -- Will be called by every created task + + Set_Stack_Limit_Hook := Set_Stack_Limit_For_Current_Task'Access; + end Initialize_Stack_Limit; + + -------------------------------------- + -- Set_Stack_Limit_For_Current_Task -- + -------------------------------------- + + procedure Set_Stack_Limit_For_Current_Task is + use Interfaces.C; + + type OS_Stack_Info is record + Size : Interfaces.C.int; + Base : System.Address; + Limit : System.Address; + end record; + pragma Convention (C, OS_Stack_Info); + -- Type representing the information that we want to extract from the + -- underlying kernel. + + procedure Get_Stack_Info (Stack : not null access OS_Stack_Info); + pragma Import (C, Get_Stack_Info, "__gnat_get_stack_info"); + -- Procedure that fills the stack information associated to the + -- currently executing task. + + Stack_Info : aliased OS_Stack_Info; + + Limit : System.Address; + + begin + + -- Get stack bounds from VxWorks + + Get_Stack_Info (Stack_Info'Access); + + if Stack_Grows_Down then + Limit := + Stack_Info.Base - Storage_Offset (Stack_Info.Size) + + Storage_Offset'(12_000); + else + Limit := + Stack_Info.Base + Storage_Offset (Stack_Info.Size) - + Storage_Offset'(12_000); + end if; + + Stack_Limit := Limit; + + end Set_Stack_Limit_For_Current_Task; +end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stratt-xdr.adb b/gcc/ada/libgnat/s-stratt-xdr.adb deleted file mode 100644 index f7c63ce1b71..00000000000 --- a/gcc/ada/libgnat/s-stratt-xdr.adb +++ /dev/null @@ -1,1901 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R E A M _ A T T R I B U T E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- --- -- --- GARLIC 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This file is an alternate version of s-stratt.adb based on the XDR --- standard. It is especially useful for exchanging streams between two --- different systems with different basic type representations and endianness. - -pragma Warnings (Off, "*not allowed in compiler unit"); --- This body is used only when rebuilding the runtime library, not when --- building the compiler, so it's OK to depend on features that would --- otherwise break bootstrap (e.g. IF-expressions). - -with Ada.IO_Exceptions; -with Ada.Streams; use Ada.Streams; -with Ada.Unchecked_Conversion; - -package body System.Stream_Attributes is - - pragma Suppress (Range_Check); - pragma Suppress (Overflow_Check); - - use UST; - - Data_Error : exception renames Ada.IO_Exceptions.End_Error; - -- Exception raised if insufficient data read (End_Error is mandated by - -- AI95-00132). - - SU : constant := System.Storage_Unit; - -- The code in this body assumes that SU = 8 - - BB : constant := 2 ** SU; -- Byte base - BL : constant := 2 ** SU - 1; -- Byte last - BS : constant := 2 ** (SU - 1); -- Byte sign - - US : constant := Unsigned'Size; -- Unsigned size - UB : constant := (US - 1) / SU + 1; -- Unsigned byte - UL : constant := 2 ** US - 1; -- Unsigned last - - subtype SE is Ada.Streams.Stream_Element; - subtype SEA is Ada.Streams.Stream_Element_Array; - subtype SEO is Ada.Streams.Stream_Element_Offset; - - generic function UC renames Ada.Unchecked_Conversion; - - type Field_Type is - record - E_Size : Integer; -- Exponent bit size - E_Bias : Integer; -- Exponent bias - F_Size : Integer; -- Fraction bit size - E_Last : Integer; -- Max exponent value - F_Mask : SE; -- Mask to apply on first fraction byte - E_Bytes : SEO; -- N. of exponent bytes completely used - F_Bytes : SEO; -- N. of fraction bytes completely used - F_Bits : Integer; -- N. of bits used on first fraction word - end record; - - type Precision is (Single, Double, Quadruple); - - Fields : constant array (Precision) of Field_Type := ( - - -- Single precision - - (E_Size => 8, - E_Bias => 127, - F_Size => 23, - E_Last => 2 ** 8 - 1, - F_Mask => 16#7F#, -- 2 ** 7 - 1, - E_Bytes => 2, - F_Bytes => 3, - F_Bits => 23 mod US), - - -- Double precision - - (E_Size => 11, - E_Bias => 1023, - F_Size => 52, - E_Last => 2 ** 11 - 1, - F_Mask => 16#0F#, -- 2 ** 4 - 1, - E_Bytes => 2, - F_Bytes => 7, - F_Bits => 52 mod US), - - -- Quadruple precision - - (E_Size => 15, - E_Bias => 16383, - F_Size => 112, - E_Last => 2 ** 8 - 1, - F_Mask => 16#FF#, -- 2 ** 8 - 1, - E_Bytes => 2, - F_Bytes => 14, - F_Bits => 112 mod US)); - - -- The representation of all items requires a multiple of four bytes - -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes - -- are read or written to some byte stream such that byte m always - -- precedes byte m+1. If the n bytes needed to contain the data are not - -- a multiple of four, then the n bytes are followed by enough (0 to 3) - -- residual zero bytes, r, to make the total byte count a multiple of 4. - - -- An XDR signed integer is a 32-bit datum that encodes an integer - -- in the range [-2147483648,2147483647]. The integer is represented - -- in two's complement notation. The most and least significant bytes - -- are 0 and 3, respectively. Integers are declared as follows: - - -- (MSB) (LSB) - -- +-------+-------+-------+-------+ - -- |byte 0 |byte 1 |byte 2 |byte 3 | - -- +-------+-------+-------+-------+ - -- <------------32 bits------------> - - SSI_L : constant := 1; - SI_L : constant := 2; - I_L : constant := 4; - LI_L : constant := 8; - LLI_L : constant := 8; - - subtype XDR_S_SSI is SEA (1 .. SSI_L); - subtype XDR_S_SI is SEA (1 .. SI_L); - subtype XDR_S_I is SEA (1 .. I_L); - subtype XDR_S_LI is SEA (1 .. LI_L); - subtype XDR_S_LLI is SEA (1 .. LLI_L); - - function Short_Short_Integer_To_XDR_S_SSI is - new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI); - function XDR_S_SSI_To_Short_Short_Integer is - new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer); - - function Short_Integer_To_XDR_S_SI is - new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI); - function XDR_S_SI_To_Short_Integer is - new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer); - - function Integer_To_XDR_S_I is - new Ada.Unchecked_Conversion (Integer, XDR_S_I); - function XDR_S_I_To_Integer is - new Ada.Unchecked_Conversion (XDR_S_I, Integer); - - function Long_Long_Integer_To_XDR_S_LI is - new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI); - function XDR_S_LI_To_Long_Long_Integer is - new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer); - - function Long_Long_Integer_To_XDR_S_LLI is - new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI); - function XDR_S_LLI_To_Long_Long_Integer is - new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer); - - -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative - -- integer in the range [0,4294967295]. It is represented by an unsigned - -- binary number whose most and least significant bytes are 0 and 3, - -- respectively. An unsigned integer is declared as follows: - - -- (MSB) (LSB) - -- +-------+-------+-------+-------+ - -- |byte 0 |byte 1 |byte 2 |byte 3 | - -- +-------+-------+-------+-------+ - -- <------------32 bits------------> - - SSU_L : constant := 1; - SU_L : constant := 2; - U_L : constant := 4; - LU_L : constant := 8; - LLU_L : constant := 8; - - subtype XDR_S_SSU is SEA (1 .. SSU_L); - subtype XDR_S_SU is SEA (1 .. SU_L); - subtype XDR_S_U is SEA (1 .. U_L); - subtype XDR_S_LU is SEA (1 .. LU_L); - subtype XDR_S_LLU is SEA (1 .. LLU_L); - - type XDR_SSU is mod BB ** SSU_L; - type XDR_SU is mod BB ** SU_L; - type XDR_U is mod BB ** U_L; - - function Short_Unsigned_To_XDR_S_SU is - new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU); - function XDR_S_SU_To_Short_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned); - - function Unsigned_To_XDR_S_U is - new Ada.Unchecked_Conversion (Unsigned, XDR_S_U); - function XDR_S_U_To_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_U, Unsigned); - - function Long_Long_Unsigned_To_XDR_S_LU is - new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU); - function XDR_S_LU_To_Long_Long_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned); - - function Long_Long_Unsigned_To_XDR_S_LLU is - new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU); - function XDR_S_LLU_To_Long_Long_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned); - - -- The standard defines the floating-point data type "float" (32 bits - -- or 4 bytes). The encoding used is the IEEE standard for normalized - -- single-precision floating-point numbers. - - -- The standard defines the encoding used for the double-precision - -- floating-point data type "double" (64 bits or 8 bytes). The encoding - -- used is the IEEE standard for normalized double-precision floating-point - -- numbers. - - SF_L : constant := 4; -- Single precision - F_L : constant := 4; -- Single precision - LF_L : constant := 8; -- Double precision - LLF_L : constant := 16; -- Quadruple precision - - TM_L : constant := 8; - subtype XDR_S_TM is SEA (1 .. TM_L); - type XDR_TM is mod BB ** TM_L; - - type XDR_SA is mod 2 ** Standard'Address_Size; - function To_XDR_SA is new UC (System.Address, XDR_SA); - function To_XDR_SA is new UC (XDR_SA, System.Address); - - -- Enumerations have the same representation as signed integers. - -- Enumerations are handy for describing subsets of the integers. - - -- Booleans are important enough and occur frequently enough to warrant - -- their own explicit type in the standard. Booleans are declared as - -- an enumeration, with FALSE = 0 and TRUE = 1. - - -- The standard defines a string of n (numbered 0 through n-1) ASCII - -- bytes to be the number n encoded as an unsigned integer (as described - -- above), and followed by the n bytes of the string. Byte m of the string - -- always precedes byte m+1 of the string, and byte 0 of the string always - -- follows the string's length. If n is not a multiple of four, then the - -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make - -- the total byte count a multiple of four. - - -- To fit with XDR string, do not consider character as an enumeration - -- type. - - C_L : constant := 1; - subtype XDR_S_C is SEA (1 .. C_L); - - -- Consider Wide_Character as an enumeration type - - WC_L : constant := 4; - subtype XDR_S_WC is SEA (1 .. WC_L); - type XDR_WC is mod BB ** WC_L; - - -- Consider Wide_Wide_Character as an enumeration type - - WWC_L : constant := 8; - subtype XDR_S_WWC is SEA (1 .. WWC_L); - type XDR_WWC is mod BB ** WWC_L; - - -- Optimization: if we already have the correct Bit_Order, then some - -- computations can be avoided since the source and the target will be - -- identical anyway. They will be replaced by direct unchecked - -- conversions. - - Optimize_Integers : constant Boolean := - Default_Bit_Order = High_Order_First; - - ----------------- - -- Block_IO_OK -- - ----------------- - - -- We must inhibit Block_IO, because in XDR mode, each element is output - -- according to XDR requirements, which is not at all the same as writing - -- the whole array in one block. - - function Block_IO_OK return Boolean is - begin - return False; - end Block_IO_OK; - - ---------- - -- I_AD -- - ---------- - - function I_AD (Stream : not null access RST) return Fat_Pointer is - FP : Fat_Pointer; - - begin - FP.P1 := I_AS (Stream).P1; - FP.P2 := I_AS (Stream).P1; - - return FP; - end I_AD; - - ---------- - -- I_AS -- - ---------- - - function I_AS (Stream : not null access RST) return Thin_Pointer is - S : XDR_S_TM; - L : SEO; - U : XDR_TM := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_TM (S (N)); - end loop; - - return (P1 => To_XDR_SA (XDR_SA (U))); - end if; - end I_AS; - - --------- - -- I_B -- - --------- - - function I_B (Stream : not null access RST) return Boolean is - begin - case I_SSU (Stream) is - when 0 => return False; - when 1 => return True; - when others => raise Data_Error; - end case; - end I_B; - - --------- - -- I_C -- - --------- - - function I_C (Stream : not null access RST) return Character is - S : XDR_S_C; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - -- Use Ada requirements on Character representation clause - - return Character'Val (S (1)); - end if; - end I_C; - - --------- - -- I_F -- - --------- - - function I_F (Stream : not null access RST) return Float is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Is_Positive : Boolean; - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Result : Float; - S : SEA (1 .. F_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask); - for N in F_L + 2 - F_Bytes .. F_L loop - Fraction := Fraction * BB + Long_Unsigned (S (N)); - end loop; - Result := Float'Scaling (Float (Fraction), -F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_F; - - --------- - -- I_I -- - --------- - - function I_I (Stream : not null access RST) return Integer is - S : XDR_S_I; - L : SEO; - U : XDR_U := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_I_To_Integer (S); - - else - for N in S'Range loop - U := U * BB + XDR_U (S (N)); - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Integer (U); - - else - return Integer (-((XDR_U'Last xor U) + 1)); - end if; - end if; - end I_I; - - ---------- - -- I_LF -- - ---------- - - function I_LF (Stream : not null access RST) return Long_Float is - I : constant Precision := Double; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Is_Positive : Boolean; - Exponent : Long_Unsigned; - Fraction : Long_Long_Unsigned; - Result : Long_Float; - S : SEA (1 .. LF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask); - for N in LF_L + 2 - F_Bytes .. LF_L loop - Fraction := Fraction * BB + Long_Long_Unsigned (S (N)); - end loop; - - Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Long_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Long_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_LF; - - ---------- - -- I_LI -- - ---------- - - function I_LI (Stream : not null access RST) return Long_Integer is - S : XDR_S_LI; - L : SEO; - U : Unsigned := 0; - X : Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S)); - - else - - -- Compute using machine unsigned - -- rather than long_long_unsigned - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Unsigned (U); - U := 0; - end if; - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Long_Integer (X); - else - return Long_Integer (-((Long_Unsigned'Last xor X) + 1)); - end if; - - end if; - end I_LI; - - ----------- - -- I_LLF -- - ----------- - - function I_LLF (Stream : not null access RST) return Long_Long_Float is - I : constant Precision := Quadruple; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Is_Positive : Boolean; - Exponent : Long_Unsigned; - Fraction_1 : Long_Long_Unsigned := 0; - Fraction_2 : Long_Long_Unsigned := 0; - Result : Long_Long_Float; - HF : constant Natural := F_Size / 2; - S : SEA (1 .. LLF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop - Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I)); - end loop; - - for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop - Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I)); - end loop; - - Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF); - Result := Long_Long_Float (Fraction_1) + Result; - Result := Long_Long_Float'Scaling (Result, HF - F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction_1 = 0 and then Fraction_2 = 0 then - null; - - -- Denormalized float - - else - Result := Long_Long_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Long_Long_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_LLF; - - ----------- - -- I_LLI -- - ----------- - - function I_LLI (Stream : not null access RST) return Long_Long_Integer is - S : XDR_S_LLI; - L : SEO; - U : Unsigned := 0; - X : Long_Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_LLI_To_Long_Long_Integer (S); - - else - -- Compute using machine unsigned for computing - -- rather than long_long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Long_Unsigned (U); - U := 0; - end if; - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Long_Long_Integer (X); - else - return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1)); - end if; - end if; - end I_LLI; - - ----------- - -- I_LLU -- - ----------- - - function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is - S : XDR_S_LLU; - L : SEO; - U : Unsigned := 0; - X : Long_Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_LLU_To_Long_Long_Unsigned (S); - - else - -- Compute using machine unsigned - -- rather than long_long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Long_Unsigned (U); - U := 0; - end if; - end loop; - - return X; - end if; - end I_LLU; - - ---------- - -- I_LU -- - ---------- - - function I_LU (Stream : not null access RST) return Long_Unsigned is - S : XDR_S_LU; - L : SEO; - U : Unsigned := 0; - X : Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); - - else - -- Compute using machine unsigned - -- rather than long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Unsigned (U); - U := 0; - end if; - end loop; - - return X; - end if; - end I_LU; - - ---------- - -- I_SF -- - ---------- - - function I_SF (Stream : not null access RST) return Short_Float is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - Result : Short_Float; - S : SEA (1 .. SF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask); - for N in SF_L + 2 - F_Bytes .. SF_L loop - Fraction := Fraction * BB + Long_Unsigned (S (N)); - end loop; - Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Short_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Short_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_SF; - - ---------- - -- I_SI -- - ---------- - - function I_SI (Stream : not null access RST) return Short_Integer is - S : XDR_S_SI; - L : SEO; - U : XDR_SU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SI_To_Short_Integer (S); - - else - for N in S'Range loop - U := U * BB + XDR_SU (S (N)); - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Short_Integer (U); - else - return Short_Integer (-((XDR_SU'Last xor U) + 1)); - end if; - end if; - end I_SI; - - ----------- - -- I_SSI -- - ----------- - - function I_SSI (Stream : not null access RST) return Short_Short_Integer is - S : XDR_S_SSI; - L : SEO; - U : XDR_SSU; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SSI_To_Short_Short_Integer (S); - - else - U := XDR_SSU (S (1)); - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Short_Short_Integer (U); - else - return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); - end if; - end if; - end I_SSI; - - ----------- - -- I_SSU -- - ----------- - - function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is - S : XDR_S_SSU; - L : SEO; - U : XDR_SSU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - U := XDR_SSU (S (1)); - return Short_Short_Unsigned (U); - end if; - end I_SSU; - - ---------- - -- I_SU -- - ---------- - - function I_SU (Stream : not null access RST) return Short_Unsigned is - S : XDR_S_SU; - L : SEO; - U : XDR_SU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SU_To_Short_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_SU (S (N)); - end loop; - - return Short_Unsigned (U); - end if; - end I_SU; - - --------- - -- I_U -- - --------- - - function I_U (Stream : not null access RST) return Unsigned is - S : XDR_S_U; - L : SEO; - U : XDR_U := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_U_To_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_U (S (N)); - end loop; - - return Unsigned (U); - end if; - end I_U; - - ---------- - -- I_WC -- - ---------- - - function I_WC (Stream : not null access RST) return Wide_Character is - S : XDR_S_WC; - L : SEO; - U : XDR_WC := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_WC (S (N)); - end loop; - - -- Use Ada requirements on Wide_Character representation clause - - return Wide_Character'Val (U); - end if; - end I_WC; - - ----------- - -- I_WWC -- - ----------- - - function I_WWC (Stream : not null access RST) return Wide_Wide_Character is - S : XDR_S_WWC; - L : SEO; - U : XDR_WWC := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_WWC (S (N)); - end loop; - - -- Use Ada requirements on Wide_Wide_Character representation clause - - return Wide_Wide_Character'Val (U); - end if; - end I_WWC; - - ---------- - -- W_AD -- - ---------- - - procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is - S : XDR_S_TM; - U : XDR_TM; - - begin - U := XDR_TM (To_XDR_SA (Item.P1)); - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - U := XDR_TM (To_XDR_SA (Item.P2)); - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_AD; - - ---------- - -- W_AS -- - ---------- - - procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is - S : XDR_S_TM; - U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); - - begin - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_AS; - - --------- - -- W_B -- - --------- - - procedure W_B (Stream : not null access RST; Item : Boolean) is - begin - if Item then - W_SSU (Stream, 1); - else - W_SSU (Stream, 0); - end if; - end W_B; - - --------- - -- W_C -- - --------- - - procedure W_C (Stream : not null access RST; Item : Character) is - S : XDR_S_C; - - pragma Assert (C_L = 1); - - begin - -- Use Ada requirements on Character representation clause - - S (1) := SE (Character'Pos (Item)); - - Ada.Streams.Write (Stream.all, S); - end W_C; - - --------- - -- W_F -- - --------- - - procedure W_F (Stream : not null access RST; Item : Float) is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Float; - S : SEA (1 .. F_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - F := Float'Scaling (F, F_Size + E_Bias - 1); - E := -E_Bias; - else - F := Float'Scaling (Float'Fraction (F), F_Size + 1); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse F_L - F_Bytes + 1 .. F_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_F; - - --------- - -- W_I -- - --------- - - procedure W_I (Stream : not null access RST; Item : Integer) is - S : XDR_S_I; - U : XDR_U; - - begin - if Optimize_Integers then - S := Integer_To_XDR_S_I (Item); - - else - -- Test sign and apply two complement notation - - U := (if Item < 0 - then XDR_U'Last xor XDR_U (-(Item + 1)) - else XDR_U (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_I; - - ---------- - -- W_LF -- - ---------- - - procedure W_LF (Stream : not null access RST; Item : Long_Float) is - I : constant Precision := Double; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Long_Float; - S : SEA (1 .. LF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Long_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - E := -E_Bias; - F := Long_Float'Scaling (F, F_Size + E_Bias - 1); - else - F := Long_Float'Scaling (F, F_Size - E); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse LF_L - F_Bytes + 1 .. LF_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LF; - - ---------- - -- W_LI -- - ---------- - - procedure W_LI (Stream : not null access RST; Item : Long_Integer) is - S : XDR_S_LI; - U : Unsigned; - X : Long_Unsigned; - - begin - if Optimize_Integers then - S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); - - else - -- Test sign and apply two complement notation - - if Item < 0 then - X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); - else - X := Long_Unsigned (Item); - end if; - - -- Compute using machine unsigned rather than long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LI; - - ----------- - -- W_LLF -- - ----------- - - procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is - I : constant Precision := Quadruple; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - HFS : constant Integer := F_Size / 2; - - Exponent : Long_Unsigned; - Fraction_1 : Long_Long_Unsigned; - Fraction_2 : Long_Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Long_Long_Float := Item; - S : SEA (1 .. LLF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - - if F < 0.0 then - F := -Item; - end if; - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction_1 := 0; - Fraction_2 := 0; - - else - E := Long_Long_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - F := Long_Long_Float'Scaling (F, E_Bias - 1); - E := -E_Bias; - else - F := Long_Long_Float'Scaling - (Long_Long_Float'Fraction (F), 1); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - F := Long_Long_Float'Scaling (F, F_Size - HFS); - Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); - F := F - Long_Long_Float (Fraction_1); - F := Long_Long_Float'Scaling (F, HFS); - Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); - end if; - - -- Store Fraction_1 - - for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop - S (I) := SE (Fraction_1 mod BB); - Fraction_1 := Fraction_1 / BB; - end loop; - - -- Store Fraction_2 - - for I in reverse LLF_L - 6 .. LLF_L loop - S (SEO (I)) := SE (Fraction_2 mod BB); - Fraction_2 := Fraction_2 / BB; - end loop; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLF; - - ----------- - -- W_LLI -- - ----------- - - procedure W_LLI - (Stream : not null access RST; - Item : Long_Long_Integer) - is - S : XDR_S_LLI; - U : Unsigned; - X : Long_Long_Unsigned; - - begin - if Optimize_Integers then - S := Long_Long_Integer_To_XDR_S_LLI (Item); - - else - -- Test sign and apply two complement notation - - if Item < 0 then - X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); - else - X := Long_Long_Unsigned (Item); - end if; - - -- Compute using machine unsigned rather than long_long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LLU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLI; - - ----------- - -- W_LLU -- - ----------- - - procedure W_LLU - (Stream : not null access RST; - Item : Long_Long_Unsigned) - is - S : XDR_S_LLU; - U : Unsigned; - X : Long_Long_Unsigned := Item; - - begin - if Optimize_Integers then - S := Long_Long_Unsigned_To_XDR_S_LLU (Item); - - else - -- Compute using machine unsigned rather than long_long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LLU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLU; - - ---------- - -- W_LU -- - ---------- - - procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is - S : XDR_S_LU; - U : Unsigned; - X : Long_Unsigned := Item; - - begin - if Optimize_Integers then - S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); - - else - -- Compute using machine unsigned rather than long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LU; - - ---------- - -- W_SF -- - ---------- - - procedure W_SF (Stream : not null access RST; Item : Short_Float) is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Short_Float; - S : SEA (1 .. SF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Short_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - E := -E_Bias; - F := Short_Float'Scaling (F, F_Size + E_Bias - 1); - else - F := Short_Float'Scaling (F, F_Size - E); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse SF_L - F_Bytes + 1 .. SF_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SF; - - ---------- - -- W_SI -- - ---------- - - procedure W_SI (Stream : not null access RST; Item : Short_Integer) is - S : XDR_S_SI; - U : XDR_SU; - - begin - if Optimize_Integers then - S := Short_Integer_To_XDR_S_SI (Item); - - else - -- Test sign and apply two complement's notation - - U := (if Item < 0 - then XDR_SU'Last xor XDR_SU (-(Item + 1)) - else XDR_SU (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SI; - - ----------- - -- W_SSI -- - ----------- - - procedure W_SSI - (Stream : not null access RST; - Item : Short_Short_Integer) - is - S : XDR_S_SSI; - U : XDR_SSU; - - begin - if Optimize_Integers then - S := Short_Short_Integer_To_XDR_S_SSI (Item); - - else - -- Test sign and apply two complement's notation - - U := (if Item < 0 - then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) - else XDR_SSU (Item)); - - S (1) := SE (U); - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SSI; - - ----------- - -- W_SSU -- - ----------- - - procedure W_SSU - (Stream : not null access RST; - Item : Short_Short_Unsigned) - is - U : constant XDR_SSU := XDR_SSU (Item); - S : XDR_S_SSU; - - begin - S (1) := SE (U); - Ada.Streams.Write (Stream.all, S); - end W_SSU; - - ---------- - -- W_SU -- - ---------- - - procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is - S : XDR_S_SU; - U : XDR_SU := XDR_SU (Item); - - begin - if Optimize_Integers then - S := Short_Unsigned_To_XDR_S_SU (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SU; - - --------- - -- W_U -- - --------- - - procedure W_U (Stream : not null access RST; Item : Unsigned) is - S : XDR_S_U; - U : XDR_U := XDR_U (Item); - - begin - if Optimize_Integers then - S := Unsigned_To_XDR_S_U (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_U; - - ---------- - -- W_WC -- - ---------- - - procedure W_WC (Stream : not null access RST; Item : Wide_Character) is - S : XDR_S_WC; - U : XDR_WC; - - begin - -- Use Ada requirements on Wide_Character representation clause - - U := XDR_WC (Wide_Character'Pos (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_WC; - - ----------- - -- W_WWC -- - ----------- - - procedure W_WWC - (Stream : not null access RST; Item : Wide_Wide_Character) - is - S : XDR_S_WWC; - U : XDR_WWC; - - begin - -- Use Ada requirements on Wide_Wide_Character representation clause - - U := XDR_WWC (Wide_Wide_Character'Pos (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_WWC; - -end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-stratt__xdr.adb b/gcc/ada/libgnat/s-stratt__xdr.adb new file mode 100644 index 00000000000..f7c63ce1b71 --- /dev/null +++ b/gcc/ada/libgnat/s-stratt__xdr.adb @@ -0,0 +1,1901 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R E A M _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GARLIC 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This file is an alternate version of s-stratt.adb based on the XDR +-- standard. It is especially useful for exchanging streams between two +-- different systems with different basic type representations and endianness. + +pragma Warnings (Off, "*not allowed in compiler unit"); +-- This body is used only when rebuilding the runtime library, not when +-- building the compiler, so it's OK to depend on features that would +-- otherwise break bootstrap (e.g. IF-expressions). + +with Ada.IO_Exceptions; +with Ada.Streams; use Ada.Streams; +with Ada.Unchecked_Conversion; + +package body System.Stream_Attributes is + + pragma Suppress (Range_Check); + pragma Suppress (Overflow_Check); + + use UST; + + Data_Error : exception renames Ada.IO_Exceptions.End_Error; + -- Exception raised if insufficient data read (End_Error is mandated by + -- AI95-00132). + + SU : constant := System.Storage_Unit; + -- The code in this body assumes that SU = 8 + + BB : constant := 2 ** SU; -- Byte base + BL : constant := 2 ** SU - 1; -- Byte last + BS : constant := 2 ** (SU - 1); -- Byte sign + + US : constant := Unsigned'Size; -- Unsigned size + UB : constant := (US - 1) / SU + 1; -- Unsigned byte + UL : constant := 2 ** US - 1; -- Unsigned last + + subtype SE is Ada.Streams.Stream_Element; + subtype SEA is Ada.Streams.Stream_Element_Array; + subtype SEO is Ada.Streams.Stream_Element_Offset; + + generic function UC renames Ada.Unchecked_Conversion; + + type Field_Type is + record + E_Size : Integer; -- Exponent bit size + E_Bias : Integer; -- Exponent bias + F_Size : Integer; -- Fraction bit size + E_Last : Integer; -- Max exponent value + F_Mask : SE; -- Mask to apply on first fraction byte + E_Bytes : SEO; -- N. of exponent bytes completely used + F_Bytes : SEO; -- N. of fraction bytes completely used + F_Bits : Integer; -- N. of bits used on first fraction word + end record; + + type Precision is (Single, Double, Quadruple); + + Fields : constant array (Precision) of Field_Type := ( + + -- Single precision + + (E_Size => 8, + E_Bias => 127, + F_Size => 23, + E_Last => 2 ** 8 - 1, + F_Mask => 16#7F#, -- 2 ** 7 - 1, + E_Bytes => 2, + F_Bytes => 3, + F_Bits => 23 mod US), + + -- Double precision + + (E_Size => 11, + E_Bias => 1023, + F_Size => 52, + E_Last => 2 ** 11 - 1, + F_Mask => 16#0F#, -- 2 ** 4 - 1, + E_Bytes => 2, + F_Bytes => 7, + F_Bits => 52 mod US), + + -- Quadruple precision + + (E_Size => 15, + E_Bias => 16383, + F_Size => 112, + E_Last => 2 ** 8 - 1, + F_Mask => 16#FF#, -- 2 ** 8 - 1, + E_Bytes => 2, + F_Bytes => 14, + F_Bits => 112 mod US)); + + -- The representation of all items requires a multiple of four bytes + -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes + -- are read or written to some byte stream such that byte m always + -- precedes byte m+1. If the n bytes needed to contain the data are not + -- a multiple of four, then the n bytes are followed by enough (0 to 3) + -- residual zero bytes, r, to make the total byte count a multiple of 4. + + -- An XDR signed integer is a 32-bit datum that encodes an integer + -- in the range [-2147483648,2147483647]. The integer is represented + -- in two's complement notation. The most and least significant bytes + -- are 0 and 3, respectively. Integers are declared as follows: + + -- (MSB) (LSB) + -- +-------+-------+-------+-------+ + -- |byte 0 |byte 1 |byte 2 |byte 3 | + -- +-------+-------+-------+-------+ + -- <------------32 bits------------> + + SSI_L : constant := 1; + SI_L : constant := 2; + I_L : constant := 4; + LI_L : constant := 8; + LLI_L : constant := 8; + + subtype XDR_S_SSI is SEA (1 .. SSI_L); + subtype XDR_S_SI is SEA (1 .. SI_L); + subtype XDR_S_I is SEA (1 .. I_L); + subtype XDR_S_LI is SEA (1 .. LI_L); + subtype XDR_S_LLI is SEA (1 .. LLI_L); + + function Short_Short_Integer_To_XDR_S_SSI is + new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI); + function XDR_S_SSI_To_Short_Short_Integer is + new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer); + + function Short_Integer_To_XDR_S_SI is + new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI); + function XDR_S_SI_To_Short_Integer is + new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer); + + function Integer_To_XDR_S_I is + new Ada.Unchecked_Conversion (Integer, XDR_S_I); + function XDR_S_I_To_Integer is + new Ada.Unchecked_Conversion (XDR_S_I, Integer); + + function Long_Long_Integer_To_XDR_S_LI is + new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI); + function XDR_S_LI_To_Long_Long_Integer is + new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer); + + function Long_Long_Integer_To_XDR_S_LLI is + new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI); + function XDR_S_LLI_To_Long_Long_Integer is + new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer); + + -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative + -- integer in the range [0,4294967295]. It is represented by an unsigned + -- binary number whose most and least significant bytes are 0 and 3, + -- respectively. An unsigned integer is declared as follows: + + -- (MSB) (LSB) + -- +-------+-------+-------+-------+ + -- |byte 0 |byte 1 |byte 2 |byte 3 | + -- +-------+-------+-------+-------+ + -- <------------32 bits------------> + + SSU_L : constant := 1; + SU_L : constant := 2; + U_L : constant := 4; + LU_L : constant := 8; + LLU_L : constant := 8; + + subtype XDR_S_SSU is SEA (1 .. SSU_L); + subtype XDR_S_SU is SEA (1 .. SU_L); + subtype XDR_S_U is SEA (1 .. U_L); + subtype XDR_S_LU is SEA (1 .. LU_L); + subtype XDR_S_LLU is SEA (1 .. LLU_L); + + type XDR_SSU is mod BB ** SSU_L; + type XDR_SU is mod BB ** SU_L; + type XDR_U is mod BB ** U_L; + + function Short_Unsigned_To_XDR_S_SU is + new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU); + function XDR_S_SU_To_Short_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned); + + function Unsigned_To_XDR_S_U is + new Ada.Unchecked_Conversion (Unsigned, XDR_S_U); + function XDR_S_U_To_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_U, Unsigned); + + function Long_Long_Unsigned_To_XDR_S_LU is + new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU); + function XDR_S_LU_To_Long_Long_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned); + + function Long_Long_Unsigned_To_XDR_S_LLU is + new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU); + function XDR_S_LLU_To_Long_Long_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned); + + -- The standard defines the floating-point data type "float" (32 bits + -- or 4 bytes). The encoding used is the IEEE standard for normalized + -- single-precision floating-point numbers. + + -- The standard defines the encoding used for the double-precision + -- floating-point data type "double" (64 bits or 8 bytes). The encoding + -- used is the IEEE standard for normalized double-precision floating-point + -- numbers. + + SF_L : constant := 4; -- Single precision + F_L : constant := 4; -- Single precision + LF_L : constant := 8; -- Double precision + LLF_L : constant := 16; -- Quadruple precision + + TM_L : constant := 8; + subtype XDR_S_TM is SEA (1 .. TM_L); + type XDR_TM is mod BB ** TM_L; + + type XDR_SA is mod 2 ** Standard'Address_Size; + function To_XDR_SA is new UC (System.Address, XDR_SA); + function To_XDR_SA is new UC (XDR_SA, System.Address); + + -- Enumerations have the same representation as signed integers. + -- Enumerations are handy for describing subsets of the integers. + + -- Booleans are important enough and occur frequently enough to warrant + -- their own explicit type in the standard. Booleans are declared as + -- an enumeration, with FALSE = 0 and TRUE = 1. + + -- The standard defines a string of n (numbered 0 through n-1) ASCII + -- bytes to be the number n encoded as an unsigned integer (as described + -- above), and followed by the n bytes of the string. Byte m of the string + -- always precedes byte m+1 of the string, and byte 0 of the string always + -- follows the string's length. If n is not a multiple of four, then the + -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make + -- the total byte count a multiple of four. + + -- To fit with XDR string, do not consider character as an enumeration + -- type. + + C_L : constant := 1; + subtype XDR_S_C is SEA (1 .. C_L); + + -- Consider Wide_Character as an enumeration type + + WC_L : constant := 4; + subtype XDR_S_WC is SEA (1 .. WC_L); + type XDR_WC is mod BB ** WC_L; + + -- Consider Wide_Wide_Character as an enumeration type + + WWC_L : constant := 8; + subtype XDR_S_WWC is SEA (1 .. WWC_L); + type XDR_WWC is mod BB ** WWC_L; + + -- Optimization: if we already have the correct Bit_Order, then some + -- computations can be avoided since the source and the target will be + -- identical anyway. They will be replaced by direct unchecked + -- conversions. + + Optimize_Integers : constant Boolean := + Default_Bit_Order = High_Order_First; + + ----------------- + -- Block_IO_OK -- + ----------------- + + -- We must inhibit Block_IO, because in XDR mode, each element is output + -- according to XDR requirements, which is not at all the same as writing + -- the whole array in one block. + + function Block_IO_OK return Boolean is + begin + return False; + end Block_IO_OK; + + ---------- + -- I_AD -- + ---------- + + function I_AD (Stream : not null access RST) return Fat_Pointer is + FP : Fat_Pointer; + + begin + FP.P1 := I_AS (Stream).P1; + FP.P2 := I_AS (Stream).P1; + + return FP; + end I_AD; + + ---------- + -- I_AS -- + ---------- + + function I_AS (Stream : not null access RST) return Thin_Pointer is + S : XDR_S_TM; + L : SEO; + U : XDR_TM := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_TM (S (N)); + end loop; + + return (P1 => To_XDR_SA (XDR_SA (U))); + end if; + end I_AS; + + --------- + -- I_B -- + --------- + + function I_B (Stream : not null access RST) return Boolean is + begin + case I_SSU (Stream) is + when 0 => return False; + when 1 => return True; + when others => raise Data_Error; + end case; + end I_B; + + --------- + -- I_C -- + --------- + + function I_C (Stream : not null access RST) return Character is + S : XDR_S_C; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + -- Use Ada requirements on Character representation clause + + return Character'Val (S (1)); + end if; + end I_C; + + --------- + -- I_F -- + --------- + + function I_F (Stream : not null access RST) return Float is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Is_Positive : Boolean; + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Result : Float; + S : SEA (1 .. F_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask); + for N in F_L + 2 - F_Bytes .. F_L loop + Fraction := Fraction * BB + Long_Unsigned (S (N)); + end loop; + Result := Float'Scaling (Float (Fraction), -F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_F; + + --------- + -- I_I -- + --------- + + function I_I (Stream : not null access RST) return Integer is + S : XDR_S_I; + L : SEO; + U : XDR_U := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_I_To_Integer (S); + + else + for N in S'Range loop + U := U * BB + XDR_U (S (N)); + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Integer (U); + + else + return Integer (-((XDR_U'Last xor U) + 1)); + end if; + end if; + end I_I; + + ---------- + -- I_LF -- + ---------- + + function I_LF (Stream : not null access RST) return Long_Float is + I : constant Precision := Double; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Is_Positive : Boolean; + Exponent : Long_Unsigned; + Fraction : Long_Long_Unsigned; + Result : Long_Float; + S : SEA (1 .. LF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask); + for N in LF_L + 2 - F_Bytes .. LF_L loop + Fraction := Fraction * BB + Long_Long_Unsigned (S (N)); + end loop; + + Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Long_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Long_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_LF; + + ---------- + -- I_LI -- + ---------- + + function I_LI (Stream : not null access RST) return Long_Integer is + S : XDR_S_LI; + L : SEO; + U : Unsigned := 0; + X : Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S)); + + else + + -- Compute using machine unsigned + -- rather than long_long_unsigned + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Unsigned (U); + U := 0; + end if; + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Long_Integer (X); + else + return Long_Integer (-((Long_Unsigned'Last xor X) + 1)); + end if; + + end if; + end I_LI; + + ----------- + -- I_LLF -- + ----------- + + function I_LLF (Stream : not null access RST) return Long_Long_Float is + I : constant Precision := Quadruple; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Is_Positive : Boolean; + Exponent : Long_Unsigned; + Fraction_1 : Long_Long_Unsigned := 0; + Fraction_2 : Long_Long_Unsigned := 0; + Result : Long_Long_Float; + HF : constant Natural := F_Size / 2; + S : SEA (1 .. LLF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop + Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I)); + end loop; + + for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop + Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I)); + end loop; + + Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF); + Result := Long_Long_Float (Fraction_1) + Result; + Result := Long_Long_Float'Scaling (Result, HF - F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction_1 = 0 and then Fraction_2 = 0 then + null; + + -- Denormalized float + + else + Result := Long_Long_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Long_Long_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_LLF; + + ----------- + -- I_LLI -- + ----------- + + function I_LLI (Stream : not null access RST) return Long_Long_Integer is + S : XDR_S_LLI; + L : SEO; + U : Unsigned := 0; + X : Long_Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_LLI_To_Long_Long_Integer (S); + + else + -- Compute using machine unsigned for computing + -- rather than long_long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Long_Unsigned (U); + U := 0; + end if; + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Long_Long_Integer (X); + else + return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1)); + end if; + end if; + end I_LLI; + + ----------- + -- I_LLU -- + ----------- + + function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is + S : XDR_S_LLU; + L : SEO; + U : Unsigned := 0; + X : Long_Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_LLU_To_Long_Long_Unsigned (S); + + else + -- Compute using machine unsigned + -- rather than long_long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Long_Unsigned (U); + U := 0; + end if; + end loop; + + return X; + end if; + end I_LLU; + + ---------- + -- I_LU -- + ---------- + + function I_LU (Stream : not null access RST) return Long_Unsigned is + S : XDR_S_LU; + L : SEO; + U : Unsigned := 0; + X : Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); + + else + -- Compute using machine unsigned + -- rather than long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Unsigned (U); + U := 0; + end if; + end loop; + + return X; + end if; + end I_LU; + + ---------- + -- I_SF -- + ---------- + + function I_SF (Stream : not null access RST) return Short_Float is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + Result : Short_Float; + S : SEA (1 .. SF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask); + for N in SF_L + 2 - F_Bytes .. SF_L loop + Fraction := Fraction * BB + Long_Unsigned (S (N)); + end loop; + Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Short_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Short_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_SF; + + ---------- + -- I_SI -- + ---------- + + function I_SI (Stream : not null access RST) return Short_Integer is + S : XDR_S_SI; + L : SEO; + U : XDR_SU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SI_To_Short_Integer (S); + + else + for N in S'Range loop + U := U * BB + XDR_SU (S (N)); + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Short_Integer (U); + else + return Short_Integer (-((XDR_SU'Last xor U) + 1)); + end if; + end if; + end I_SI; + + ----------- + -- I_SSI -- + ----------- + + function I_SSI (Stream : not null access RST) return Short_Short_Integer is + S : XDR_S_SSI; + L : SEO; + U : XDR_SSU; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SSI_To_Short_Short_Integer (S); + + else + U := XDR_SSU (S (1)); + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Short_Short_Integer (U); + else + return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); + end if; + end if; + end I_SSI; + + ----------- + -- I_SSU -- + ----------- + + function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is + S : XDR_S_SSU; + L : SEO; + U : XDR_SSU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + U := XDR_SSU (S (1)); + return Short_Short_Unsigned (U); + end if; + end I_SSU; + + ---------- + -- I_SU -- + ---------- + + function I_SU (Stream : not null access RST) return Short_Unsigned is + S : XDR_S_SU; + L : SEO; + U : XDR_SU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SU_To_Short_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_SU (S (N)); + end loop; + + return Short_Unsigned (U); + end if; + end I_SU; + + --------- + -- I_U -- + --------- + + function I_U (Stream : not null access RST) return Unsigned is + S : XDR_S_U; + L : SEO; + U : XDR_U := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_U_To_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_U (S (N)); + end loop; + + return Unsigned (U); + end if; + end I_U; + + ---------- + -- I_WC -- + ---------- + + function I_WC (Stream : not null access RST) return Wide_Character is + S : XDR_S_WC; + L : SEO; + U : XDR_WC := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_WC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Character representation clause + + return Wide_Character'Val (U); + end if; + end I_WC; + + ----------- + -- I_WWC -- + ----------- + + function I_WWC (Stream : not null access RST) return Wide_Wide_Character is + S : XDR_S_WWC; + L : SEO; + U : XDR_WWC := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_WWC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Wide_Character representation clause + + return Wide_Wide_Character'Val (U); + end if; + end I_WWC; + + ---------- + -- W_AD -- + ---------- + + procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is + S : XDR_S_TM; + U : XDR_TM; + + begin + U := XDR_TM (To_XDR_SA (Item.P1)); + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + U := XDR_TM (To_XDR_SA (Item.P2)); + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_AD; + + ---------- + -- W_AS -- + ---------- + + procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is + S : XDR_S_TM; + U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); + + begin + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_AS; + + --------- + -- W_B -- + --------- + + procedure W_B (Stream : not null access RST; Item : Boolean) is + begin + if Item then + W_SSU (Stream, 1); + else + W_SSU (Stream, 0); + end if; + end W_B; + + --------- + -- W_C -- + --------- + + procedure W_C (Stream : not null access RST; Item : Character) is + S : XDR_S_C; + + pragma Assert (C_L = 1); + + begin + -- Use Ada requirements on Character representation clause + + S (1) := SE (Character'Pos (Item)); + + Ada.Streams.Write (Stream.all, S); + end W_C; + + --------- + -- W_F -- + --------- + + procedure W_F (Stream : not null access RST; Item : Float) is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Float; + S : SEA (1 .. F_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + F := Float'Scaling (F, F_Size + E_Bias - 1); + E := -E_Bias; + else + F := Float'Scaling (Float'Fraction (F), F_Size + 1); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse F_L - F_Bytes + 1 .. F_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_F; + + --------- + -- W_I -- + --------- + + procedure W_I (Stream : not null access RST; Item : Integer) is + S : XDR_S_I; + U : XDR_U; + + begin + if Optimize_Integers then + S := Integer_To_XDR_S_I (Item); + + else + -- Test sign and apply two complement notation + + U := (if Item < 0 + then XDR_U'Last xor XDR_U (-(Item + 1)) + else XDR_U (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_I; + + ---------- + -- W_LF -- + ---------- + + procedure W_LF (Stream : not null access RST; Item : Long_Float) is + I : constant Precision := Double; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Long_Float; + S : SEA (1 .. LF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Long_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + E := -E_Bias; + F := Long_Float'Scaling (F, F_Size + E_Bias - 1); + else + F := Long_Float'Scaling (F, F_Size - E); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse LF_L - F_Bytes + 1 .. LF_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LF; + + ---------- + -- W_LI -- + ---------- + + procedure W_LI (Stream : not null access RST; Item : Long_Integer) is + S : XDR_S_LI; + U : Unsigned; + X : Long_Unsigned; + + begin + if Optimize_Integers then + S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); + + else + -- Test sign and apply two complement notation + + if Item < 0 then + X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); + else + X := Long_Unsigned (Item); + end if; + + -- Compute using machine unsigned rather than long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LI; + + ----------- + -- W_LLF -- + ----------- + + procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is + I : constant Precision := Quadruple; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + HFS : constant Integer := F_Size / 2; + + Exponent : Long_Unsigned; + Fraction_1 : Long_Long_Unsigned; + Fraction_2 : Long_Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Long_Long_Float := Item; + S : SEA (1 .. LLF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + + if F < 0.0 then + F := -Item; + end if; + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction_1 := 0; + Fraction_2 := 0; + + else + E := Long_Long_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + F := Long_Long_Float'Scaling (F, E_Bias - 1); + E := -E_Bias; + else + F := Long_Long_Float'Scaling + (Long_Long_Float'Fraction (F), 1); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + F := Long_Long_Float'Scaling (F, F_Size - HFS); + Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); + F := F - Long_Long_Float (Fraction_1); + F := Long_Long_Float'Scaling (F, HFS); + Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); + end if; + + -- Store Fraction_1 + + for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop + S (I) := SE (Fraction_1 mod BB); + Fraction_1 := Fraction_1 / BB; + end loop; + + -- Store Fraction_2 + + for I in reverse LLF_L - 6 .. LLF_L loop + S (SEO (I)) := SE (Fraction_2 mod BB); + Fraction_2 := Fraction_2 / BB; + end loop; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLF; + + ----------- + -- W_LLI -- + ----------- + + procedure W_LLI + (Stream : not null access RST; + Item : Long_Long_Integer) + is + S : XDR_S_LLI; + U : Unsigned; + X : Long_Long_Unsigned; + + begin + if Optimize_Integers then + S := Long_Long_Integer_To_XDR_S_LLI (Item); + + else + -- Test sign and apply two complement notation + + if Item < 0 then + X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); + else + X := Long_Long_Unsigned (Item); + end if; + + -- Compute using machine unsigned rather than long_long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LLU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLI; + + ----------- + -- W_LLU -- + ----------- + + procedure W_LLU + (Stream : not null access RST; + Item : Long_Long_Unsigned) + is + S : XDR_S_LLU; + U : Unsigned; + X : Long_Long_Unsigned := Item; + + begin + if Optimize_Integers then + S := Long_Long_Unsigned_To_XDR_S_LLU (Item); + + else + -- Compute using machine unsigned rather than long_long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LLU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLU; + + ---------- + -- W_LU -- + ---------- + + procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is + S : XDR_S_LU; + U : Unsigned; + X : Long_Unsigned := Item; + + begin + if Optimize_Integers then + S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); + + else + -- Compute using machine unsigned rather than long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LU; + + ---------- + -- W_SF -- + ---------- + + procedure W_SF (Stream : not null access RST; Item : Short_Float) is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Short_Float; + S : SEA (1 .. SF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Short_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + E := -E_Bias; + F := Short_Float'Scaling (F, F_Size + E_Bias - 1); + else + F := Short_Float'Scaling (F, F_Size - E); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse SF_L - F_Bytes + 1 .. SF_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SF; + + ---------- + -- W_SI -- + ---------- + + procedure W_SI (Stream : not null access RST; Item : Short_Integer) is + S : XDR_S_SI; + U : XDR_SU; + + begin + if Optimize_Integers then + S := Short_Integer_To_XDR_S_SI (Item); + + else + -- Test sign and apply two complement's notation + + U := (if Item < 0 + then XDR_SU'Last xor XDR_SU (-(Item + 1)) + else XDR_SU (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SI; + + ----------- + -- W_SSI -- + ----------- + + procedure W_SSI + (Stream : not null access RST; + Item : Short_Short_Integer) + is + S : XDR_S_SSI; + U : XDR_SSU; + + begin + if Optimize_Integers then + S := Short_Short_Integer_To_XDR_S_SSI (Item); + + else + -- Test sign and apply two complement's notation + + U := (if Item < 0 + then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) + else XDR_SSU (Item)); + + S (1) := SE (U); + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SSI; + + ----------- + -- W_SSU -- + ----------- + + procedure W_SSU + (Stream : not null access RST; + Item : Short_Short_Unsigned) + is + U : constant XDR_SSU := XDR_SSU (Item); + S : XDR_S_SSU; + + begin + S (1) := SE (U); + Ada.Streams.Write (Stream.all, S); + end W_SSU; + + ---------- + -- W_SU -- + ---------- + + procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is + S : XDR_S_SU; + U : XDR_SU := XDR_SU (Item); + + begin + if Optimize_Integers then + S := Short_Unsigned_To_XDR_S_SU (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SU; + + --------- + -- W_U -- + --------- + + procedure W_U (Stream : not null access RST; Item : Unsigned) is + S : XDR_S_U; + U : XDR_U := XDR_U (Item); + + begin + if Optimize_Integers then + S := Unsigned_To_XDR_S_U (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_U; + + ---------- + -- W_WC -- + ---------- + + procedure W_WC (Stream : not null access RST; Item : Wide_Character) is + S : XDR_S_WC; + U : XDR_WC; + + begin + -- Use Ada requirements on Wide_Character representation clause + + U := XDR_WC (Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WC; + + ----------- + -- W_WWC -- + ----------- + + procedure W_WWC + (Stream : not null access RST; Item : Wide_Wide_Character) + is + S : XDR_S_WWC; + U : XDR_WWC; + + begin + -- Use Ada requirements on Wide_Wide_Character representation clause + + U := XDR_WWC (Wide_Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WWC; + +end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-traceb-hpux.adb b/gcc/ada/libgnat/s-traceb-hpux.adb deleted file mode 100644 index a261104d4d6..00000000000 --- a/gcc/ada/libgnat/s-traceb-hpux.adb +++ /dev/null @@ -1,627 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K -- --- (HP/UX Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2017, 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 -- --- . -- --- -- --- 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.Traceback is - - -- This package implements the backtracing facility by way of a dedicated - -- HP library for stack unwinding described in the "Runtime Architecture - -- Document". - - pragma Linker_Options ("/usr/lib/libcl.a"); - - -- The library basically offers services to fetch information about a - -- "previous" frame based on information about a "current" one. - - type Current_Frame_Descriptor is record - cur_fsz : Address; -- Frame size of current routine. - cur_sp : Address; -- The current value of stack pointer. - cur_rls : Address; -- PC-space of the caller. - cur_rlo : Address; -- PC-offset of the caller. - cur_dp : Address; -- Data Pointer of the current routine. - top_rp : Address; -- Initial value of RP. - top_mrp : Address; -- Initial value of MRP. - top_sr0 : Address; -- Initial value of sr0. - top_sr4 : Address; -- Initial value of sr4. - top_r3 : Address; -- Initial value of gr3. - cur_r19 : Address; -- GR19 value of the calling routine. - top_r4 : Address; -- Initial value of gr4. - dummy : Address; -- Reserved. - out_rlo : Address; -- PC-offset of the caller after get_previous. - end record; - - type Previous_Frame_Descriptor is record - prev_fsz : Address; -- frame size of calling routine. - prev_sp : Address; -- SP of calling routine. - prev_rls : Address; -- PC_space of calling routine's caller. - prev_rlo : Address; -- PC_offset of calling routine's caller. - prev_dp : Address; -- DP of calling routine. - udescr0 : Address; -- low word of calling routine's unwind desc. - udescr1 : Address; -- high word of calling routine's unwind desc. - ustart : Address; -- start of the unwind region. - uend : Address; -- end of the unwind region. - uw_index : Address; -- index into the unwind table. - prev_r19 : Address; -- GR19 value of the caller's caller. - top_r3 : Address; -- Caller's initial gr3. - top_r4 : Address; -- Caller's initial gr4. - end record; - - -- Provide useful shortcuts for the names - - subtype CFD is Current_Frame_Descriptor; - subtype PFD is Previous_Frame_Descriptor; - - -- Frames with dynamic stack allocation are handled using the associated - -- frame pointer, but HP compilers and GCC setup this pointer differently. - -- HP compilers set it to point at the top (highest address) of the static - -- part of the frame, whereas GCC sets it to point at the bottom of this - -- region. We have to fake the unwinder to compensate for this difference, - -- for which we'll need to access some subprograms unwind descriptors. - - type Bits_2_Value is mod 2 ** 2; - for Bits_2_Value'Size use 2; - - type Bits_4_Value is mod 2 ** 4; - for Bits_4_Value'Size use 4; - - type Bits_5_Value is mod 2 ** 5; - for Bits_5_Value'Size use 5; - - type Bits_27_Value is mod 2 ** 27; - for Bits_27_Value'Size use 27; - - type Unwind_Descriptor is record - cannot_unwind : Boolean; - mcode : Boolean; - mcode_save_restore : Boolean; - region_desc : Bits_2_Value; - reserved0 : Boolean; - entry_sr : Boolean; - entry_fr : Bits_4_Value; - entry_gr : Bits_5_Value; - - args_stored : Boolean; - variable_frame : Boolean; - separate_package_body : Boolean; - frame_extension_mcode : Boolean; - - stack_overflow_check : Boolean; - two_steps_sp_adjust : Boolean; - sr4_export : Boolean; - cxx_info : Boolean; - - cxx_try_catch : Boolean; - sched_entry_seq : Boolean; - reserved1 : Boolean; - save_sp : Boolean; - - save_rp : Boolean; - save_mrp : Boolean; - save_r19 : Boolean; - cleanups : Boolean; - - hpe_interrupt_marker : Boolean; - hpux_interrupt_marker : Boolean; - large_frame : Boolean; - alloca_frame : Boolean; - - reserved2 : Boolean; - frame_size : Bits_27_Value; - end record; - - for Unwind_Descriptor'Size use 64; - - for Unwind_Descriptor use record - cannot_unwind at 0 range 0 .. 0; - mcode at 0 range 1 .. 1; - mcode_save_restore at 0 range 2 .. 2; - region_desc at 0 range 3 .. 4; - reserved0 at 0 range 5 .. 5; - entry_sr at 0 range 6 .. 6; - entry_fr at 0 range 7 .. 10; - - entry_gr at 1 range 3 .. 7; - - args_stored at 2 range 0 .. 0; - variable_frame at 2 range 1 .. 1; - separate_package_body at 2 range 2 .. 2; - frame_extension_mcode at 2 range 3 .. 3; - stack_overflow_check at 2 range 4 .. 4; - two_steps_sp_adjust at 2 range 5 .. 5; - sr4_export at 2 range 6 .. 6; - cxx_info at 2 range 7 .. 7; - - cxx_try_catch at 3 range 0 .. 0; - sched_entry_seq at 3 range 1 .. 1; - reserved1 at 3 range 2 .. 2; - save_sp at 3 range 3 .. 3; - save_rp at 3 range 4 .. 4; - save_mrp at 3 range 5 .. 5; - save_r19 at 3 range 6 .. 6; - cleanups at 3 range 7 .. 7; - - hpe_interrupt_marker at 4 range 0 .. 0; - hpux_interrupt_marker at 4 range 1 .. 1; - large_frame at 4 range 2 .. 2; - alloca_frame at 4 range 3 .. 3; - - reserved2 at 4 range 4 .. 4; - frame_size at 4 range 5 .. 31; - end record; - - subtype UWD is Unwind_Descriptor; - type UWD_Ptr is access all UWD; - - function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr); - - -- The descriptor associated with a given code location is retrieved - -- using functions imported from the HP library, requiring the definition - -- of additional structures. - - type Unwind_Table_Region is record - Table_Start : Address; - Table_End : Address; - end record; - -- An Unwind Table region, which is a memory area containing Unwind - -- Descriptors. - - subtype UWT is Unwind_Table_Region; - - -- The subprograms imported below are provided by the HP library - - function U_get_unwind_table return UWT; - pragma Import (C, U_get_unwind_table, "U_get_unwind_table"); - -- Get the unwind table region associated with the current executable. - -- This function is actually documented as having an argument, but which - -- is only used for the MPE/iX targets. - - function U_get_shLib_unwind_table (r19 : Address) return UWT; - pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl"); - -- Return the unwind table region associated with a possible shared - -- library, as determined by the provided r19 value. - - function U_get_shLib_text_addr (r19 : Address) return Address; - pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr"); - -- Return the address at which the code for a shared library begins, or - -- -1 if the value provided for r19 does not identify shared library code. - - function U_get_unwind_entry - (Pc : Address; - Space : Address; - Table_Start : Address; - Table_End : Address) return Address; - pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); - -- Given the bounds of an unwind table, return the address of the - -- unwind descriptor associated with a code location/space. In the case - -- of shared library code, the offset from the beginning of the library - -- is expected as Pc. - - procedure U_init_frame_record (Frame : not null access CFD); - pragma Import (C, U_init_frame_record, "U_init_frame_record"); - - procedure U_prep_frame_rec_for_unwind (Frame : not null access CFD); - pragma Import (C, U_prep_frame_rec_for_unwind, - "U_prep_frame_rec_for_unwind"); - - -- Fetch the description data of the frame in which these two procedures - -- are called. - - function U_get_u_rlo - (Cur : not null access CFD; Prev : not null access PFD) return Integer; - pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX"); - -- From a complete current frame with a return location possibly located - -- into a linker generated stub, and basic information about the previous - -- frame, place the first non stub return location into the current frame. - -- Return -1 if something went wrong during the computation. - - function U_is_shared_pc (rlo : Address; r19 : Address) return Address; - pragma Import (C, U_is_shared_pc, "U_is_shared_pc"); - -- Return 0 if the provided return location does not correspond to code - -- in a shared library, or something non null otherwise. - - function U_get_previous_frame_x - (current_frame : not null access CFD; - previous_frame : not null access PFD; - previous_size : Integer) return Integer; - pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); - -- Fetch the data describing the "previous" frame relatively to the - -- "current" one. "previous_size" should be the size of the "previous" - -- frame descriptor provided. - -- - -- The library provides a simpler interface without the size parameter - -- but it is not usable when frames with dynamically allocated space are - -- on the way. - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1); - -- Same as the exported version, but takes Traceback as an Address - - ------------------ - -- C_Call_Chain -- - ------------------ - - function C_Call_Chain - (Traceback : System.Address; - Max_Len : Natural) return Natural - is - Val : Natural; - begin - Call_Chain (Traceback, Max_Len, Val); - return Val; - end C_Call_Chain; - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - type Tracebacks_Array is array (1 .. Max_Len) of System.Address; - pragma Suppress_Initialization (Tracebacks_Array); - - -- The code location returned by the unwinder is a return location but - -- what we need is a call point. Under HP-UX call instructions are 4 - -- bytes long and the return point they specify is 4 bytes beyond the - -- next instruction because of the delay slot. - - Call_Size : constant := 4; - DSlot_Size : constant := 4; - Rlo_Offset : constant := Call_Size + DSlot_Size; - - -- Moreover, the return point is passed via a register which two least - -- significant bits specify a privilege level that we will have to mask. - - Priv_Mask : constant := 16#00000003#; - - Frame : aliased CFD; - Code : System.Address; - J : Natural := 1; - Pop_Success : Boolean; - Trace : Tracebacks_Array; - for Trace'Address use Traceback; - - -- The backtracing process needs a set of subprograms : - - function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr; - -- Return an access to the unwind descriptor for the caller of - -- a given frame, using only the provided return location. - - function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr; - -- Return an access to the unwind descriptor for the user code caller - -- of a given frame, or null if the information is not available. - - function Pop_Frame (Frame : not null access CFD) return Boolean; - -- Update the provided machine state structure so that it reflects - -- the state one call frame "above" the initial one. - -- - -- Return True if the operation has been successful, False otherwise. - -- Failure typically occurs when the top of the call stack has been - -- reached. - - function Prepare_For_Unwind_Of - (Frame : not null access CFD) return Boolean; - -- Perform the necessary adaptations to the machine state before - -- calling the unwinder. Currently used for the specific case of - -- dynamically sized previous frames. - -- - -- Return True if everything went fine, or False otherwise. - - Program_UWT : constant UWT := U_get_unwind_table; - - --------------- - -- Pop_Frame -- - --------------- - - function Pop_Frame (Frame : not null access CFD) return Boolean is - Up_Frame : aliased PFD; - State_Ready : Boolean; - - begin - -- Check/adapt the state before calling the unwinder and return - -- if anything went wrong. - - State_Ready := Prepare_For_Unwind_Of (Frame); - - if not State_Ready then - return False; - end if; - - -- Now, safely call the unwinder and use the results - - if U_get_previous_frame_x (Frame, - Up_Frame'Access, - Up_Frame'Size) /= 0 - then - return False; - end if; - - -- In case a stub is on the way, the usual previous return location - -- (the one in prev_rlo) is the one in the stub and the "real" one - -- is placed in the "current" record, so let's take this one into - -- account. - - Frame.out_rlo := Frame.cur_rlo; - - Frame.cur_fsz := Up_Frame.prev_fsz; - Frame.cur_sp := Up_Frame.prev_sp; - Frame.cur_rls := Up_Frame.prev_rls; - Frame.cur_rlo := Up_Frame.prev_rlo; - Frame.cur_dp := Up_Frame.prev_dp; - Frame.cur_r19 := Up_Frame.prev_r19; - Frame.top_r3 := Up_Frame.top_r3; - Frame.top_r4 := Up_Frame.top_r4; - - return True; - end Pop_Frame; - - --------------------------------- - -- Prepare_State_For_Unwind_Of -- - --------------------------------- - - function Prepare_For_Unwind_Of - (Frame : not null access CFD) return Boolean - is - Caller_UWD : UWD_Ptr; - FP_Adjustment : Integer; - - begin - -- No need to bother doing anything if the stack is already fully - -- unwound. - - if Frame.cur_rlo = 0 then - return False; - end if; - - -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder - -- uses the value provided in current.top_r3 or current.top_r4 as - -- a frame pointer to compute the size of the frame. What decides - -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with - -- r4 chosen if the bit is set. - - -- The size computed by the unwinder is STATIC_PART + (SP - FP), - -- which is correct with HP's frame pointer convention, but not - -- with GCC's one since we end up with the static part accounted - -- for twice. - - -- We have to compute r4 when it is required because the unwinder - -- has looked for it at a place where it was not if we went through - -- GCC frames. - - -- The size of the static part of a frame can be found in the - -- associated unwind descriptor. - - Caller_UWD := UWD_For_Caller_Of (Frame); - - -- If we cannot get it, we are unable to compute the potentially - -- necessary adjustments. We'd better not try to go on then. - - if Caller_UWD = null then - return False; - end if; - - -- If the caller frame is a GCC one, r3 is its frame pointer and - -- points to the bottom of the frame. The value to provide for r4 - -- can then be computed directly from the one of r3, compensating - -- for the static part of the frame. - - -- If the caller frame is an HP one, r3 is used to locate the - -- previous frame marker, that is it also points to the bottom of - -- the frame (this is why r3 cannot be used as the frame pointer in - -- the HP sense for large frames). The value to provide for r4 can - -- then also be computed from the one of r3 with the compensation - -- for the static part of the frame. - - FP_Adjustment := Integer (Caller_UWD.frame_size * 8); - Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment); - - return True; - end Prepare_For_Unwind_Of; - - ----------------------- - -- UWD_For_Caller_Of -- - ----------------------- - - function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr - is - UWD_Access : UWD_Ptr; - - begin - -- First try the most direct path, using the return location data - -- associated with the frame. - - UWD_Access := UWD_For_RLO_Of (Frame); - - if UWD_Access /= null then - return UWD_Access; - end if; - - -- If we did not get a result, we might face an in-stub return - -- address. In this case U_get_previous_frame can tell us what the - -- first not-in-stub return point is. We cannot call it directly, - -- though, because we haven't computed the potentially necessary - -- frame pointer adjustments, which might lead to SEGV in some - -- circumstances. Instead, we directly call the libcl routine which - -- is called by U_get_previous_frame and which only requires few - -- information. Take care, however, that the information is provided - -- in the "current" argument, so we need to work on a copy to avoid - -- disturbing our caller. - - declare - U_Current : aliased CFD := Frame.all; - U_Previous : aliased PFD; - - begin - U_Previous.prev_dp := U_Current.cur_dp; - U_Previous.prev_rls := U_Current.cur_rls; - U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz; - - if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then - UWD_Access := UWD_For_RLO_Of (U_Current'Access); - end if; - end; - - return UWD_Access; - end UWD_For_Caller_Of; - - -------------------- - -- UWD_For_RLO_Of -- - -------------------- - - function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr - is - UWD_Address : Address; - - -- The addresses returned by the library point to full descriptors - -- including the frame information bits but also the applicable PC - -- range. We need to account for this. - - Frame_Info_Offset : constant := 8; - - begin - -- First try to locate the descriptor in the program's unwind table - - UWD_Address := U_get_unwind_entry (Frame.cur_rlo, - Frame.cur_rls, - Program_UWT.Table_Start, - Program_UWT.Table_End); - - -- If we did not get it, we might have a frame from code in a - -- stub or shared library. For code in stub we would have to - -- compute the first non-stub return location but this is not - -- the role of this subprogram, so let's just try to see if we - -- can get a result from the tables in shared libraries. - - if UWD_Address = -1 - and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 - then - declare - Shlib_UWT : constant UWT := - U_get_shLib_unwind_table (Frame.cur_r19); - Shlib_Start : constant Address := - U_get_shLib_text_addr (Frame.cur_r19); - Rlo_Offset : constant Address := - Frame.cur_rlo - Shlib_Start; - begin - UWD_Address := U_get_unwind_entry (Rlo_Offset, - Frame.cur_rls, - Shlib_UWT.Table_Start, - Shlib_UWT.Table_End); - end; - end if; - - if UWD_Address /= -1 then - return To_UWD_Access (UWD_Address + Frame_Info_Offset); - else - return null; - end if; - end UWD_For_RLO_Of; - - -- Start of processing for Call_Chain - - begin - -- Fetch the state for this subprogram's frame and pop it so that we - -- start with an initial out_rlo "here". - - U_init_frame_record (Frame'Access); - Frame.top_sr0 := 0; - Frame.top_sr4 := 0; - - U_prep_frame_rec_for_unwind (Frame'Access); - - Pop_Success := Pop_Frame (Frame'Access); - - -- Skip the requested number of frames - - for I in 1 .. Skip_Frames loop - Pop_Success := Pop_Frame (Frame'Access); - end loop; - - -- Loop popping frames and storing locations until either a problem - -- occurs, or the top of the call chain is reached, or the provided - -- array is full. - - loop - -- We have to test some conditions against the return location - -- as it is returned, so get it as is first. - - Code := Frame.out_rlo; - - exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1; - - -- Compute the call point from the retrieved return location : - -- Mask the privilege bits and account for the delta between the - -- call site and the return point. - - Code := (Code and not Priv_Mask) - Rlo_Offset; - - if Code < Exclude_Min or else Code > Exclude_Max then - Trace (J) := Code; - J := J + 1; - end if; - - Pop_Success := Pop_Frame (Frame'Access); - end loop; - - Len := J - 1; - end Call_Chain; - - procedure Call_Chain - (Traceback : in out System.Traceback_Entries.Tracebacks_Array; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - begin - Call_Chain - (Traceback'Address, Max_Len, Len, - Exclude_Min, Exclude_Max, - - -- Skip one extra frame to skip the other Call_Chain entry as well - - Skip_Frames => Skip_Frames + 1); - end Call_Chain; - -end System.Traceback; diff --git a/gcc/ada/libgnat/s-traceb-mastop.adb b/gcc/ada/libgnat/s-traceb-mastop.adb deleted file mode 100644 index 422d5c591a3..00000000000 --- a/gcc/ada/libgnat/s-traceb-mastop.adb +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version uses System.Machine_State_Operations routines - -with System.Machine_State_Operations; - -package body System.Traceback is - - use System.Machine_State_Operations; - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1); - -- Same as the exported version, but takes Traceback as an Address - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc; - pragma Suppress_Initialization (Tracebacks_Array); - - M : Machine_State; - Code : Code_Loc; - - Trace : Tracebacks_Array; - for Trace'Address use Traceback; - - N_Skips : Natural := 0; - - begin - M := Allocate_Machine_State; - Set_Machine_State (M); - - -- Skip the requested number of frames - - loop - Code := Get_Code_Loc (M); - exit when Code = Null_Address or else N_Skips = Skip_Frames; - - Pop_Frame (M); - N_Skips := N_Skips + 1; - end loop; - - -- Now, record the frames outside the exclusion bounds, updating - -- the Len output value along the way. - - Len := 0; - loop - Code := Get_Code_Loc (M); - exit when Code = Null_Address or else Len = Max_Len; - - if Code < Exclude_Min or else Code > Exclude_Max then - Len := Len + 1; - Trace (Len) := Code; - end if; - - Pop_Frame (M); - end loop; - - Free_Machine_State (M); - end Call_Chain; - - procedure Call_Chain - (Traceback : in out System.Traceback_Entries.Tracebacks_Array; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - begin - Call_Chain - (Traceback'Address, Max_Len, Len, - Exclude_Min, Exclude_Max, - - -- Skip one extra frame to skip the other Call_Chain entry as well - - Skip_Frames => Skip_Frames + 1); - end Call_Chain; - - ------------------ - -- C_Call_Chain -- - ------------------ - - function C_Call_Chain - (Traceback : System.Address; - Max_Len : Natural) return Natural - is - Val : Natural; - begin - Call_Chain (Traceback, Max_Len, Val); - return Val; - end C_Call_Chain; - -end System.Traceback; diff --git a/gcc/ada/libgnat/s-traceb__hpux.adb b/gcc/ada/libgnat/s-traceb__hpux.adb new file mode 100644 index 00000000000..a261104d4d6 --- /dev/null +++ b/gcc/ada/libgnat/s-traceb__hpux.adb @@ -0,0 +1,627 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- (HP/UX Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, 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 -- +-- . -- +-- -- +-- 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.Traceback is + + -- This package implements the backtracing facility by way of a dedicated + -- HP library for stack unwinding described in the "Runtime Architecture + -- Document". + + pragma Linker_Options ("/usr/lib/libcl.a"); + + -- The library basically offers services to fetch information about a + -- "previous" frame based on information about a "current" one. + + type Current_Frame_Descriptor is record + cur_fsz : Address; -- Frame size of current routine. + cur_sp : Address; -- The current value of stack pointer. + cur_rls : Address; -- PC-space of the caller. + cur_rlo : Address; -- PC-offset of the caller. + cur_dp : Address; -- Data Pointer of the current routine. + top_rp : Address; -- Initial value of RP. + top_mrp : Address; -- Initial value of MRP. + top_sr0 : Address; -- Initial value of sr0. + top_sr4 : Address; -- Initial value of sr4. + top_r3 : Address; -- Initial value of gr3. + cur_r19 : Address; -- GR19 value of the calling routine. + top_r4 : Address; -- Initial value of gr4. + dummy : Address; -- Reserved. + out_rlo : Address; -- PC-offset of the caller after get_previous. + end record; + + type Previous_Frame_Descriptor is record + prev_fsz : Address; -- frame size of calling routine. + prev_sp : Address; -- SP of calling routine. + prev_rls : Address; -- PC_space of calling routine's caller. + prev_rlo : Address; -- PC_offset of calling routine's caller. + prev_dp : Address; -- DP of calling routine. + udescr0 : Address; -- low word of calling routine's unwind desc. + udescr1 : Address; -- high word of calling routine's unwind desc. + ustart : Address; -- start of the unwind region. + uend : Address; -- end of the unwind region. + uw_index : Address; -- index into the unwind table. + prev_r19 : Address; -- GR19 value of the caller's caller. + top_r3 : Address; -- Caller's initial gr3. + top_r4 : Address; -- Caller's initial gr4. + end record; + + -- Provide useful shortcuts for the names + + subtype CFD is Current_Frame_Descriptor; + subtype PFD is Previous_Frame_Descriptor; + + -- Frames with dynamic stack allocation are handled using the associated + -- frame pointer, but HP compilers and GCC setup this pointer differently. + -- HP compilers set it to point at the top (highest address) of the static + -- part of the frame, whereas GCC sets it to point at the bottom of this + -- region. We have to fake the unwinder to compensate for this difference, + -- for which we'll need to access some subprograms unwind descriptors. + + type Bits_2_Value is mod 2 ** 2; + for Bits_2_Value'Size use 2; + + type Bits_4_Value is mod 2 ** 4; + for Bits_4_Value'Size use 4; + + type Bits_5_Value is mod 2 ** 5; + for Bits_5_Value'Size use 5; + + type Bits_27_Value is mod 2 ** 27; + for Bits_27_Value'Size use 27; + + type Unwind_Descriptor is record + cannot_unwind : Boolean; + mcode : Boolean; + mcode_save_restore : Boolean; + region_desc : Bits_2_Value; + reserved0 : Boolean; + entry_sr : Boolean; + entry_fr : Bits_4_Value; + entry_gr : Bits_5_Value; + + args_stored : Boolean; + variable_frame : Boolean; + separate_package_body : Boolean; + frame_extension_mcode : Boolean; + + stack_overflow_check : Boolean; + two_steps_sp_adjust : Boolean; + sr4_export : Boolean; + cxx_info : Boolean; + + cxx_try_catch : Boolean; + sched_entry_seq : Boolean; + reserved1 : Boolean; + save_sp : Boolean; + + save_rp : Boolean; + save_mrp : Boolean; + save_r19 : Boolean; + cleanups : Boolean; + + hpe_interrupt_marker : Boolean; + hpux_interrupt_marker : Boolean; + large_frame : Boolean; + alloca_frame : Boolean; + + reserved2 : Boolean; + frame_size : Bits_27_Value; + end record; + + for Unwind_Descriptor'Size use 64; + + for Unwind_Descriptor use record + cannot_unwind at 0 range 0 .. 0; + mcode at 0 range 1 .. 1; + mcode_save_restore at 0 range 2 .. 2; + region_desc at 0 range 3 .. 4; + reserved0 at 0 range 5 .. 5; + entry_sr at 0 range 6 .. 6; + entry_fr at 0 range 7 .. 10; + + entry_gr at 1 range 3 .. 7; + + args_stored at 2 range 0 .. 0; + variable_frame at 2 range 1 .. 1; + separate_package_body at 2 range 2 .. 2; + frame_extension_mcode at 2 range 3 .. 3; + stack_overflow_check at 2 range 4 .. 4; + two_steps_sp_adjust at 2 range 5 .. 5; + sr4_export at 2 range 6 .. 6; + cxx_info at 2 range 7 .. 7; + + cxx_try_catch at 3 range 0 .. 0; + sched_entry_seq at 3 range 1 .. 1; + reserved1 at 3 range 2 .. 2; + save_sp at 3 range 3 .. 3; + save_rp at 3 range 4 .. 4; + save_mrp at 3 range 5 .. 5; + save_r19 at 3 range 6 .. 6; + cleanups at 3 range 7 .. 7; + + hpe_interrupt_marker at 4 range 0 .. 0; + hpux_interrupt_marker at 4 range 1 .. 1; + large_frame at 4 range 2 .. 2; + alloca_frame at 4 range 3 .. 3; + + reserved2 at 4 range 4 .. 4; + frame_size at 4 range 5 .. 31; + end record; + + subtype UWD is Unwind_Descriptor; + type UWD_Ptr is access all UWD; + + function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr); + + -- The descriptor associated with a given code location is retrieved + -- using functions imported from the HP library, requiring the definition + -- of additional structures. + + type Unwind_Table_Region is record + Table_Start : Address; + Table_End : Address; + end record; + -- An Unwind Table region, which is a memory area containing Unwind + -- Descriptors. + + subtype UWT is Unwind_Table_Region; + + -- The subprograms imported below are provided by the HP library + + function U_get_unwind_table return UWT; + pragma Import (C, U_get_unwind_table, "U_get_unwind_table"); + -- Get the unwind table region associated with the current executable. + -- This function is actually documented as having an argument, but which + -- is only used for the MPE/iX targets. + + function U_get_shLib_unwind_table (r19 : Address) return UWT; + pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl"); + -- Return the unwind table region associated with a possible shared + -- library, as determined by the provided r19 value. + + function U_get_shLib_text_addr (r19 : Address) return Address; + pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr"); + -- Return the address at which the code for a shared library begins, or + -- -1 if the value provided for r19 does not identify shared library code. + + function U_get_unwind_entry + (Pc : Address; + Space : Address; + Table_Start : Address; + Table_End : Address) return Address; + pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); + -- Given the bounds of an unwind table, return the address of the + -- unwind descriptor associated with a code location/space. In the case + -- of shared library code, the offset from the beginning of the library + -- is expected as Pc. + + procedure U_init_frame_record (Frame : not null access CFD); + pragma Import (C, U_init_frame_record, "U_init_frame_record"); + + procedure U_prep_frame_rec_for_unwind (Frame : not null access CFD); + pragma Import (C, U_prep_frame_rec_for_unwind, + "U_prep_frame_rec_for_unwind"); + + -- Fetch the description data of the frame in which these two procedures + -- are called. + + function U_get_u_rlo + (Cur : not null access CFD; Prev : not null access PFD) return Integer; + pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX"); + -- From a complete current frame with a return location possibly located + -- into a linker generated stub, and basic information about the previous + -- frame, place the first non stub return location into the current frame. + -- Return -1 if something went wrong during the computation. + + function U_is_shared_pc (rlo : Address; r19 : Address) return Address; + pragma Import (C, U_is_shared_pc, "U_is_shared_pc"); + -- Return 0 if the provided return location does not correspond to code + -- in a shared library, or something non null otherwise. + + function U_get_previous_frame_x + (current_frame : not null access CFD; + previous_frame : not null access PFD; + previous_size : Integer) return Integer; + pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); + -- Fetch the data describing the "previous" frame relatively to the + -- "current" one. "previous_size" should be the size of the "previous" + -- frame descriptor provided. + -- + -- The library provides a simpler interface without the size parameter + -- but it is not usable when frames with dynamically allocated space are + -- on the way. + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address + + ------------------ + -- C_Call_Chain -- + ------------------ + + function C_Call_Chain + (Traceback : System.Address; + Max_Len : Natural) return Natural + is + Val : Natural; + begin + Call_Chain (Traceback, Max_Len, Val); + return Val; + end C_Call_Chain; + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + type Tracebacks_Array is array (1 .. Max_Len) of System.Address; + pragma Suppress_Initialization (Tracebacks_Array); + + -- The code location returned by the unwinder is a return location but + -- what we need is a call point. Under HP-UX call instructions are 4 + -- bytes long and the return point they specify is 4 bytes beyond the + -- next instruction because of the delay slot. + + Call_Size : constant := 4; + DSlot_Size : constant := 4; + Rlo_Offset : constant := Call_Size + DSlot_Size; + + -- Moreover, the return point is passed via a register which two least + -- significant bits specify a privilege level that we will have to mask. + + Priv_Mask : constant := 16#00000003#; + + Frame : aliased CFD; + Code : System.Address; + J : Natural := 1; + Pop_Success : Boolean; + Trace : Tracebacks_Array; + for Trace'Address use Traceback; + + -- The backtracing process needs a set of subprograms : + + function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr; + -- Return an access to the unwind descriptor for the caller of + -- a given frame, using only the provided return location. + + function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr; + -- Return an access to the unwind descriptor for the user code caller + -- of a given frame, or null if the information is not available. + + function Pop_Frame (Frame : not null access CFD) return Boolean; + -- Update the provided machine state structure so that it reflects + -- the state one call frame "above" the initial one. + -- + -- Return True if the operation has been successful, False otherwise. + -- Failure typically occurs when the top of the call stack has been + -- reached. + + function Prepare_For_Unwind_Of + (Frame : not null access CFD) return Boolean; + -- Perform the necessary adaptations to the machine state before + -- calling the unwinder. Currently used for the specific case of + -- dynamically sized previous frames. + -- + -- Return True if everything went fine, or False otherwise. + + Program_UWT : constant UWT := U_get_unwind_table; + + --------------- + -- Pop_Frame -- + --------------- + + function Pop_Frame (Frame : not null access CFD) return Boolean is + Up_Frame : aliased PFD; + State_Ready : Boolean; + + begin + -- Check/adapt the state before calling the unwinder and return + -- if anything went wrong. + + State_Ready := Prepare_For_Unwind_Of (Frame); + + if not State_Ready then + return False; + end if; + + -- Now, safely call the unwinder and use the results + + if U_get_previous_frame_x (Frame, + Up_Frame'Access, + Up_Frame'Size) /= 0 + then + return False; + end if; + + -- In case a stub is on the way, the usual previous return location + -- (the one in prev_rlo) is the one in the stub and the "real" one + -- is placed in the "current" record, so let's take this one into + -- account. + + Frame.out_rlo := Frame.cur_rlo; + + Frame.cur_fsz := Up_Frame.prev_fsz; + Frame.cur_sp := Up_Frame.prev_sp; + Frame.cur_rls := Up_Frame.prev_rls; + Frame.cur_rlo := Up_Frame.prev_rlo; + Frame.cur_dp := Up_Frame.prev_dp; + Frame.cur_r19 := Up_Frame.prev_r19; + Frame.top_r3 := Up_Frame.top_r3; + Frame.top_r4 := Up_Frame.top_r4; + + return True; + end Pop_Frame; + + --------------------------------- + -- Prepare_State_For_Unwind_Of -- + --------------------------------- + + function Prepare_For_Unwind_Of + (Frame : not null access CFD) return Boolean + is + Caller_UWD : UWD_Ptr; + FP_Adjustment : Integer; + + begin + -- No need to bother doing anything if the stack is already fully + -- unwound. + + if Frame.cur_rlo = 0 then + return False; + end if; + + -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder + -- uses the value provided in current.top_r3 or current.top_r4 as + -- a frame pointer to compute the size of the frame. What decides + -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with + -- r4 chosen if the bit is set. + + -- The size computed by the unwinder is STATIC_PART + (SP - FP), + -- which is correct with HP's frame pointer convention, but not + -- with GCC's one since we end up with the static part accounted + -- for twice. + + -- We have to compute r4 when it is required because the unwinder + -- has looked for it at a place where it was not if we went through + -- GCC frames. + + -- The size of the static part of a frame can be found in the + -- associated unwind descriptor. + + Caller_UWD := UWD_For_Caller_Of (Frame); + + -- If we cannot get it, we are unable to compute the potentially + -- necessary adjustments. We'd better not try to go on then. + + if Caller_UWD = null then + return False; + end if; + + -- If the caller frame is a GCC one, r3 is its frame pointer and + -- points to the bottom of the frame. The value to provide for r4 + -- can then be computed directly from the one of r3, compensating + -- for the static part of the frame. + + -- If the caller frame is an HP one, r3 is used to locate the + -- previous frame marker, that is it also points to the bottom of + -- the frame (this is why r3 cannot be used as the frame pointer in + -- the HP sense for large frames). The value to provide for r4 can + -- then also be computed from the one of r3 with the compensation + -- for the static part of the frame. + + FP_Adjustment := Integer (Caller_UWD.frame_size * 8); + Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment); + + return True; + end Prepare_For_Unwind_Of; + + ----------------------- + -- UWD_For_Caller_Of -- + ----------------------- + + function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr + is + UWD_Access : UWD_Ptr; + + begin + -- First try the most direct path, using the return location data + -- associated with the frame. + + UWD_Access := UWD_For_RLO_Of (Frame); + + if UWD_Access /= null then + return UWD_Access; + end if; + + -- If we did not get a result, we might face an in-stub return + -- address. In this case U_get_previous_frame can tell us what the + -- first not-in-stub return point is. We cannot call it directly, + -- though, because we haven't computed the potentially necessary + -- frame pointer adjustments, which might lead to SEGV in some + -- circumstances. Instead, we directly call the libcl routine which + -- is called by U_get_previous_frame and which only requires few + -- information. Take care, however, that the information is provided + -- in the "current" argument, so we need to work on a copy to avoid + -- disturbing our caller. + + declare + U_Current : aliased CFD := Frame.all; + U_Previous : aliased PFD; + + begin + U_Previous.prev_dp := U_Current.cur_dp; + U_Previous.prev_rls := U_Current.cur_rls; + U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz; + + if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then + UWD_Access := UWD_For_RLO_Of (U_Current'Access); + end if; + end; + + return UWD_Access; + end UWD_For_Caller_Of; + + -------------------- + -- UWD_For_RLO_Of -- + -------------------- + + function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr + is + UWD_Address : Address; + + -- The addresses returned by the library point to full descriptors + -- including the frame information bits but also the applicable PC + -- range. We need to account for this. + + Frame_Info_Offset : constant := 8; + + begin + -- First try to locate the descriptor in the program's unwind table + + UWD_Address := U_get_unwind_entry (Frame.cur_rlo, + Frame.cur_rls, + Program_UWT.Table_Start, + Program_UWT.Table_End); + + -- If we did not get it, we might have a frame from code in a + -- stub or shared library. For code in stub we would have to + -- compute the first non-stub return location but this is not + -- the role of this subprogram, so let's just try to see if we + -- can get a result from the tables in shared libraries. + + if UWD_Address = -1 + and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 + then + declare + Shlib_UWT : constant UWT := + U_get_shLib_unwind_table (Frame.cur_r19); + Shlib_Start : constant Address := + U_get_shLib_text_addr (Frame.cur_r19); + Rlo_Offset : constant Address := + Frame.cur_rlo - Shlib_Start; + begin + UWD_Address := U_get_unwind_entry (Rlo_Offset, + Frame.cur_rls, + Shlib_UWT.Table_Start, + Shlib_UWT.Table_End); + end; + end if; + + if UWD_Address /= -1 then + return To_UWD_Access (UWD_Address + Frame_Info_Offset); + else + return null; + end if; + end UWD_For_RLO_Of; + + -- Start of processing for Call_Chain + + begin + -- Fetch the state for this subprogram's frame and pop it so that we + -- start with an initial out_rlo "here". + + U_init_frame_record (Frame'Access); + Frame.top_sr0 := 0; + Frame.top_sr4 := 0; + + U_prep_frame_rec_for_unwind (Frame'Access); + + Pop_Success := Pop_Frame (Frame'Access); + + -- Skip the requested number of frames + + for I in 1 .. Skip_Frames loop + Pop_Success := Pop_Frame (Frame'Access); + end loop; + + -- Loop popping frames and storing locations until either a problem + -- occurs, or the top of the call chain is reached, or the provided + -- array is full. + + loop + -- We have to test some conditions against the return location + -- as it is returned, so get it as is first. + + Code := Frame.out_rlo; + + exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1; + + -- Compute the call point from the retrieved return location : + -- Mask the privilege bits and account for the delta between the + -- call site and the return point. + + Code := (Code and not Priv_Mask) - Rlo_Offset; + + if Code < Exclude_Min or else Code > Exclude_Max then + Trace (J) := Code; + J := J + 1; + end if; + + Pop_Success := Pop_Frame (Frame'Access); + end loop; + + Len := J - 1; + end Call_Chain; + + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + Call_Chain + (Traceback'Address, Max_Len, Len, + Exclude_Min, Exclude_Max, + + -- Skip one extra frame to skip the other Call_Chain entry as well + + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + +end System.Traceback; diff --git a/gcc/ada/libgnat/s-traceb__mastop.adb b/gcc/ada/libgnat/s-traceb__mastop.adb new file mode 100644 index 00000000000..422d5c591a3 --- /dev/null +++ b/gcc/ada/libgnat/s-traceb__mastop.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version uses System.Machine_State_Operations routines + +with System.Machine_State_Operations; + +package body System.Traceback is + + use System.Machine_State_Operations; + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc; + pragma Suppress_Initialization (Tracebacks_Array); + + M : Machine_State; + Code : Code_Loc; + + Trace : Tracebacks_Array; + for Trace'Address use Traceback; + + N_Skips : Natural := 0; + + begin + M := Allocate_Machine_State; + Set_Machine_State (M); + + -- Skip the requested number of frames + + loop + Code := Get_Code_Loc (M); + exit when Code = Null_Address or else N_Skips = Skip_Frames; + + Pop_Frame (M); + N_Skips := N_Skips + 1; + end loop; + + -- Now, record the frames outside the exclusion bounds, updating + -- the Len output value along the way. + + Len := 0; + loop + Code := Get_Code_Loc (M); + exit when Code = Null_Address or else Len = Max_Len; + + if Code < Exclude_Min or else Code > Exclude_Max then + Len := Len + 1; + Trace (Len) := Code; + end if; + + Pop_Frame (M); + end loop; + + Free_Machine_State (M); + end Call_Chain; + + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + Call_Chain + (Traceback'Address, Max_Len, Len, + Exclude_Min, Exclude_Max, + + -- Skip one extra frame to skip the other Call_Chain entry as well + + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + + ------------------ + -- C_Call_Chain -- + ------------------ + + function C_Call_Chain + (Traceback : System.Address; + Max_Len : Natural) return Natural + is + Val : Natural; + begin + Call_Chain (Traceback, Max_Len, Val); + return Val; + end C_Call_Chain; + +end System.Traceback; diff --git a/gcc/ada/libgnat/s-trasym-dwarf.adb b/gcc/ada/libgnat/s-trasym-dwarf.adb deleted file mode 100644 index 9655722b923..00000000000 --- a/gcc/ada/libgnat/s-trasym-dwarf.adb +++ /dev/null @@ -1,689 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Run-time symbolic traceback support for targets using DWARF debug data - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on. - -with Ada.Unchecked_Deallocation; - -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with Ada.Containers.Generic_Array_Sort; - -with System.Address_To_Access_Conversions; -with System.Soft_Links; -with System.CRTL; -with System.Dwarf_Lines; -with System.Exception_Traces; -with System.Standard_Library; -with System.Traceback_Entries; -with System.Strings; -with System.Bounded_Strings; - -package body System.Traceback.Symbolic is - - use System.Bounded_Strings; - use System.Dwarf_Lines; - - subtype Big_String is String (Positive); - -- To deal with C strings - - package Big_String_Conv is new System.Address_To_Access_Conversions - (Big_String); - - type Module_Cache; - type Module_Cache_Acc is access all Module_Cache; - - type Module_Cache is record - Name : Strings.String_Access; - -- Name of the module - - C : Dwarf_Context (In_Exception => True); - -- Context to symbolize an address within this module - - Chain : Module_Cache_Acc; - end record; - - procedure Free is new Ada.Unchecked_Deallocation - (Module_Cache, - Module_Cache_Acc); - - Cache_Chain : Module_Cache_Acc; - -- Simply linked list of modules - - type Module_Array is array (Natural range <>) of Module_Cache_Acc; - type Module_Array_Acc is access Module_Array; - - Modules_Cache : Module_Array_Acc; - -- Sorted array of cached modules (if not null) - - Exec_Module : aliased Module_Cache; - -- Context for the executable - - type Init_State is (Uninitialized, Initialized, Failed); - Exec_Module_State : Init_State := Uninitialized; - -- How Exec_Module is initialized - - procedure Init_Exec_Module; - -- Initialize Exec_Module if not already initialized - - function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array; - Suppress_Hex : Boolean) return String; - function Symbolic_Traceback - (E : Ada.Exceptions.Exception_Occurrence; - Suppress_Hex : Boolean) return String; - -- Suppress_Hex means do not print any hexadecimal addresses, even if the - -- symbol is not available. - - function Lt (Left, Right : Module_Cache_Acc) return Boolean; - -- Sort function for Module_Cache - - procedure Init_Module - (Module : out Module_Cache; - Success : out Boolean; - Module_Name : String; - Load_Address : Address := Null_Address); - -- Initialize Module - - procedure Close_Module (Module : in out Module_Cache); - -- Finalize Module - - function Value (Item : System.Address) return String; - -- Return the String contained in Item, up until the first NUL character - - pragma Warnings (Off, "*Add_Module_To_Cache*"); - procedure Add_Module_To_Cache (Module_Name : String); - -- To be called by Build_Cache_For_All_Modules to add a new module to the - -- list. May not be referenced. - - package Module_Name is - - procedure Build_Cache_For_All_Modules; - -- Create the cache for all current modules - - function Get (Addr : access System.Address) return String; - -- Returns the module name for the given address, Addr may be updated - -- to be set relative to a shared library. This depends on the platform. - -- Returns an empty string for the main executable. - - function Is_Supported return Boolean; - pragma Inline (Is_Supported); - -- Returns True if Module_Name is supported, so if the traceback is - -- supported for shared libraries. - - end Module_Name; - - package body Module_Name is separate; - - function Executable_Name return String; - -- Returns the executable name as reported by argv[0]. If gnat_argv not - -- initialized or if argv[0] executable not found in path, function returns - -- an empty string. - - function Get_Executable_Load_Address return System.Address; - pragma Import - (C, - Get_Executable_Load_Address, - "__gnat_get_executable_load_address"); - -- Get the load address of the executable, or Null_Address if not known - - procedure Hexa_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Non-symbolic traceback (simply write addresses in hexa) - - procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Like the public Symbolic_Traceback_No_Lock except there is no provision - -- against concurrent accesses. - - procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Returns the Traceback for a given module - - procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Build string containing symbolic traceback for the given call chain - - procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Likewise but using Module - - Max_String_Length : constant := 4096; - -- Arbitrary limit on Bounded_Str length - - ----------- - -- Value -- - ----------- - - function Value (Item : System.Address) return String is - begin - if Item /= Null_Address then - for J in Big_String'Range loop - if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then - return Big_String_Conv.To_Pointer (Item) (1 .. J - 1); - end if; - end loop; - end if; - - return ""; - end Value; - - ------------------------- - -- Add_Module_To_Cache -- - ------------------------- - - procedure Add_Module_To_Cache (Module_Name : String) is - Module : Module_Cache_Acc; - Success : Boolean; - begin - Module := new Module_Cache; - Init_Module (Module.all, Success, Module_Name); - if not Success then - Free (Module); - return; - end if; - Module.Chain := Cache_Chain; - Cache_Chain := Module; - end Add_Module_To_Cache; - - ---------------------- - -- Init_Exec_Module -- - ---------------------- - - procedure Init_Exec_Module is - begin - if Exec_Module_State = Uninitialized then - declare - Exec_Path : constant String := Executable_Name; - Exec_Load : constant Address := Get_Executable_Load_Address; - Success : Boolean; - begin - Init_Module (Exec_Module, Success, Exec_Path, Exec_Load); - - if Success then - Exec_Module_State := Initialized; - else - Exec_Module_State := Failed; - end if; - end; - end if; - end Init_Exec_Module; - - -------- - -- Lt -- - -------- - - function Lt (Left, Right : Module_Cache_Acc) return Boolean is - begin - return Low (Left.C) < Low (Right.C); - end Lt; - - ----------------------------- - -- Module_Cache_Array_Sort -- - ----------------------------- - - procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort - (Natural, - Module_Cache_Acc, - Module_Array, - Lt); - - ------------------ - -- Enable_Cache -- - ------------------ - - procedure Enable_Cache (Include_Modules : Boolean := False) is - begin - -- Can be called at most once - if Cache_Chain /= null then - return; - end if; - - -- Add all modules - Init_Exec_Module; - Cache_Chain := Exec_Module'Access; - - if Include_Modules then - Module_Name.Build_Cache_For_All_Modules; - end if; - - -- Build and fill the array of modules - declare - Count : Natural; - Module : Module_Cache_Acc; - begin - for Phase in 1 .. 2 loop - Count := 0; - Module := Cache_Chain; - while Module /= null loop - Count := Count + 1; - - if Phase = 1 then - Enable_Cache (Module.C); - else - Modules_Cache (Count) := Module; - end if; - Module := Module.Chain; - end loop; - - if Phase = 1 then - Modules_Cache := new Module_Array (1 .. Count); - end if; - end loop; - end; - - -- Sort the array - Module_Cache_Array_Sort (Modules_Cache.all); - end Enable_Cache; - - --------------------- - -- Executable_Name -- - --------------------- - - function Executable_Name return String is - -- We have to import gnat_argv as an Address to match the type of - -- gnat_argv in the binder generated file. Otherwise, we get spurious - -- warnings about type mismatch when LTO is turned on. - - Gnat_Argv : System.Address; - pragma Import (C, Gnat_Argv, "gnat_argv"); - - type Argv_Array is array (0 .. 0) of System.Address; - package Conv is new System.Address_To_Access_Conversions (Argv_Array); - - function locate_exec_on_path (A : System.Address) return System.Address; - pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path"); - - begin - if Gnat_Argv = Null_Address then - return ""; - end if; - - declare - Addr : constant System.Address := - locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0)); - Result : constant String := Value (Addr); - - begin - -- The buffer returned by locate_exec_on_path was allocated using - -- malloc, so we should use free to release the memory. - - if Addr /= Null_Address then - System.CRTL.free (Addr); - end if; - - return Result; - end; - end Executable_Name; - - ------------------ - -- Close_Module -- - ------------------ - - procedure Close_Module (Module : in out Module_Cache) is - begin - Close (Module.C); - Strings.Free (Module.Name); - end Close_Module; - - ----------------- - -- Init_Module -- - ----------------- - - procedure Init_Module - (Module : out Module_Cache; - Success : out Boolean; - Module_Name : String; - Load_Address : Address := Null_Address) - is - begin - -- Early return if the module is not known - - if Module_Name = "" then - Success := False; - return; - end if; - - Open (Module_Name, Module.C, Success); - - -- If a module can't be opened just return now, we just cannot give more - -- information in this case. - - if not Success then - return; - end if; - - Set_Load_Address (Module.C, Load_Address); - - Module.Name := new String'(Module_Name); - end Init_Module; - - ------------------------------- - -- Module_Symbolic_Traceback -- - ------------------------------- - - procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - Success : Boolean := False; - begin - if Symbolic.Module_Name.Is_Supported then - Append (Res, '['); - Append (Res, Module.Name.all); - Append (Res, ']' & ASCII.LF); - end if; - - Dwarf_Lines.Symbolic_Traceback - (Module.C, - Traceback, - Suppress_Hex, - Success, - Res); - - if not Success then - Hexa_Traceback (Traceback, Suppress_Hex, Res); - end if; - - -- We must not allow an unhandled exception here, since this function - -- may be installed as a decorator for all automatic exceptions. - - exception - when others => - return; - end Module_Symbolic_Traceback; - - ------------------------------------- - -- Multi_Module_Symbolic_Traceback -- - ------------------------------------- - - procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - F : constant Natural := Traceback'First; - begin - if Traceback'Length = 0 or else Is_Full (Res) then - return; - end if; - - if Modules_Cache /= null then - -- Search in the cache - - declare - Addr : constant Address := Traceback (F); - Hi, Lo, Mid : Natural; - begin - Lo := Modules_Cache'First; - Hi := Modules_Cache'Last; - while Lo <= Hi loop - Mid := (Lo + Hi) / 2; - if Addr < Low (Modules_Cache (Mid).C) then - Hi := Mid - 1; - elsif Is_Inside (Modules_Cache (Mid).C, Addr) then - Multi_Module_Symbolic_Traceback - (Traceback, - Modules_Cache (Mid).all, - Suppress_Hex, - Res); - return; - else - Lo := Mid + 1; - end if; - end loop; - - -- Not found - Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); - Multi_Module_Symbolic_Traceback - (Traceback (F + 1 .. Traceback'Last), - Suppress_Hex, - Res); - end; - else - - -- First try the executable - if Is_Inside (Exec_Module.C, Traceback (F)) then - Multi_Module_Symbolic_Traceback - (Traceback, - Exec_Module, - Suppress_Hex, - Res); - return; - end if; - - -- Otherwise, try a shared library - declare - Addr : aliased System.Address := Traceback (F); - M_Name : constant String := Module_Name.Get (Addr'Access); - Module : Module_Cache; - Success : Boolean; - begin - Init_Module (Module, Success, M_Name, System.Null_Address); - if Success then - Multi_Module_Symbolic_Traceback - (Traceback, - Module, - Suppress_Hex, - Res); - Close_Module (Module); - else - -- Module not found - Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); - Multi_Module_Symbolic_Traceback - (Traceback (F + 1 .. Traceback'Last), - Suppress_Hex, - Res); - end if; - end; - end if; - end Multi_Module_Symbolic_Traceback; - - procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - Pos : Positive; - begin - -- Will symbolize the first address... - - Pos := Traceback'First + 1; - - -- ... and all addresses in the same module - - Same_Module : - loop - exit Same_Module when Pos > Traceback'Last; - - -- Get address to check for corresponding module name - - exit Same_Module when not Is_Inside (Module.C, Traceback (Pos)); - - Pos := Pos + 1; - end loop Same_Module; - - Module_Symbolic_Traceback - (Traceback (Traceback'First .. Pos - 1), - Module, - Suppress_Hex, - Res); - Multi_Module_Symbolic_Traceback - (Traceback (Pos .. Traceback'Last), - Suppress_Hex, - Res); - end Multi_Module_Symbolic_Traceback; - - -------------------- - -- Hexa_Traceback -- - -------------------- - - procedure Hexa_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - use System.Traceback_Entries; - begin - if Suppress_Hex then - Append (Res, "..."); - Append (Res, ASCII.LF); - else - for J in Traceback'Range loop - Append_Address (Res, PC_For (Traceback (J))); - Append (Res, ASCII.LF); - end loop; - end if; - end Hexa_Traceback; - - -------------------------------- - -- Symbolic_Traceback_No_Lock -- - -------------------------------- - - procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - begin - if Symbolic.Module_Name.Is_Supported then - Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res); - else - if Exec_Module_State = Failed then - Append (Res, "Call stack traceback locations:" & ASCII.LF); - Hexa_Traceback (Traceback, Suppress_Hex, Res); - else - Module_Symbolic_Traceback - (Traceback, - Exec_Module, - Suppress_Hex, - Res); - end if; - end if; - end Symbolic_Traceback_No_Lock; - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - function Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean) return String - is - Res : Bounded_String (Max_Length => Max_String_Length); - begin - System.Soft_Links.Lock_Task.all; - Init_Exec_Module; - Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res); - System.Soft_Links.Unlock_Task.all; - - return To_String (Res); - - exception - when others => - System.Soft_Links.Unlock_Task.all; - raise; - end Symbolic_Traceback; - - function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is - begin - return Symbolic_Traceback (Traceback, Suppress_Hex => False); - end Symbolic_Traceback; - - function Symbolic_Traceback_No_Hex - (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is - begin - return Symbolic_Traceback (Traceback, Suppress_Hex => True); - end Symbolic_Traceback_No_Hex; - - function Symbolic_Traceback - (E : Ada.Exceptions.Exception_Occurrence; - Suppress_Hex : Boolean) return String - is - begin - return Symbolic_Traceback - (Ada.Exceptions.Traceback.Tracebacks (E), - Suppress_Hex); - end Symbolic_Traceback; - - function Symbolic_Traceback - (E : Ada.Exceptions.Exception_Occurrence) return String - is - begin - return Symbolic_Traceback (E, Suppress_Hex => False); - end Symbolic_Traceback; - - function Symbolic_Traceback_No_Hex - (E : Ada.Exceptions.Exception_Occurrence) return String is - begin - return Symbolic_Traceback (E, Suppress_Hex => True); - end Symbolic_Traceback_No_Hex; - - Exception_Tracebacks_Symbolic : Integer; - pragma Import - (C, - Exception_Tracebacks_Symbolic, - "__gl_exception_tracebacks_symbolic"); - -- Boolean indicating whether symbolic tracebacks should be generated. - - use Standard_Library; -begin - -- If this version of this package is available, and the binder switch -Es - -- was given, then we want to use this as the decorator by default, and we - -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user - -- cannot have already set Exception_Trace, because the runtime library is - -- elaborated before user-defined code. - - if Exception_Tracebacks_Symbolic /= 0 then - Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access); - pragma Assert (Exception_Trace = RM_Convention); - Exception_Trace := Unhandled_Raise_In_Main; - end if; -end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-trasym__dwarf.adb b/gcc/ada/libgnat/s-trasym__dwarf.adb new file mode 100644 index 00000000000..9655722b923 --- /dev/null +++ b/gcc/ada/libgnat/s-trasym__dwarf.adb @@ -0,0 +1,689 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support for targets using DWARF debug data + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on. + +with Ada.Unchecked_Deallocation; + +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with Ada.Containers.Generic_Array_Sort; + +with System.Address_To_Access_Conversions; +with System.Soft_Links; +with System.CRTL; +with System.Dwarf_Lines; +with System.Exception_Traces; +with System.Standard_Library; +with System.Traceback_Entries; +with System.Strings; +with System.Bounded_Strings; + +package body System.Traceback.Symbolic is + + use System.Bounded_Strings; + use System.Dwarf_Lines; + + subtype Big_String is String (Positive); + -- To deal with C strings + + package Big_String_Conv is new System.Address_To_Access_Conversions + (Big_String); + + type Module_Cache; + type Module_Cache_Acc is access all Module_Cache; + + type Module_Cache is record + Name : Strings.String_Access; + -- Name of the module + + C : Dwarf_Context (In_Exception => True); + -- Context to symbolize an address within this module + + Chain : Module_Cache_Acc; + end record; + + procedure Free is new Ada.Unchecked_Deallocation + (Module_Cache, + Module_Cache_Acc); + + Cache_Chain : Module_Cache_Acc; + -- Simply linked list of modules + + type Module_Array is array (Natural range <>) of Module_Cache_Acc; + type Module_Array_Acc is access Module_Array; + + Modules_Cache : Module_Array_Acc; + -- Sorted array of cached modules (if not null) + + Exec_Module : aliased Module_Cache; + -- Context for the executable + + type Init_State is (Uninitialized, Initialized, Failed); + Exec_Module_State : Init_State := Uninitialized; + -- How Exec_Module is initialized + + procedure Init_Exec_Module; + -- Initialize Exec_Module if not already initialized + + function Symbolic_Traceback + (Traceback : System.Traceback_Entries.Tracebacks_Array; + Suppress_Hex : Boolean) return String; + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence; + Suppress_Hex : Boolean) return String; + -- Suppress_Hex means do not print any hexadecimal addresses, even if the + -- symbol is not available. + + function Lt (Left, Right : Module_Cache_Acc) return Boolean; + -- Sort function for Module_Cache + + procedure Init_Module + (Module : out Module_Cache; + Success : out Boolean; + Module_Name : String; + Load_Address : Address := Null_Address); + -- Initialize Module + + procedure Close_Module (Module : in out Module_Cache); + -- Finalize Module + + function Value (Item : System.Address) return String; + -- Return the String contained in Item, up until the first NUL character + + pragma Warnings (Off, "*Add_Module_To_Cache*"); + procedure Add_Module_To_Cache (Module_Name : String); + -- To be called by Build_Cache_For_All_Modules to add a new module to the + -- list. May not be referenced. + + package Module_Name is + + procedure Build_Cache_For_All_Modules; + -- Create the cache for all current modules + + function Get (Addr : access System.Address) return String; + -- Returns the module name for the given address, Addr may be updated + -- to be set relative to a shared library. This depends on the platform. + -- Returns an empty string for the main executable. + + function Is_Supported return Boolean; + pragma Inline (Is_Supported); + -- Returns True if Module_Name is supported, so if the traceback is + -- supported for shared libraries. + + end Module_Name; + + package body Module_Name is separate; + + function Executable_Name return String; + -- Returns the executable name as reported by argv[0]. If gnat_argv not + -- initialized or if argv[0] executable not found in path, function returns + -- an empty string. + + function Get_Executable_Load_Address return System.Address; + pragma Import + (C, + Get_Executable_Load_Address, + "__gnat_get_executable_load_address"); + -- Get the load address of the executable, or Null_Address if not known + + procedure Hexa_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Non-symbolic traceback (simply write addresses in hexa) + + procedure Symbolic_Traceback_No_Lock + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Like the public Symbolic_Traceback_No_Lock except there is no provision + -- against concurrent accesses. + + procedure Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Returns the Traceback for a given module + + procedure Multi_Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Build string containing symbolic traceback for the given call chain + + procedure Multi_Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Likewise but using Module + + Max_String_Length : constant := 4096; + -- Arbitrary limit on Bounded_Str length + + ----------- + -- Value -- + ----------- + + function Value (Item : System.Address) return String is + begin + if Item /= Null_Address then + for J in Big_String'Range loop + if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then + return Big_String_Conv.To_Pointer (Item) (1 .. J - 1); + end if; + end loop; + end if; + + return ""; + end Value; + + ------------------------- + -- Add_Module_To_Cache -- + ------------------------- + + procedure Add_Module_To_Cache (Module_Name : String) is + Module : Module_Cache_Acc; + Success : Boolean; + begin + Module := new Module_Cache; + Init_Module (Module.all, Success, Module_Name); + if not Success then + Free (Module); + return; + end if; + Module.Chain := Cache_Chain; + Cache_Chain := Module; + end Add_Module_To_Cache; + + ---------------------- + -- Init_Exec_Module -- + ---------------------- + + procedure Init_Exec_Module is + begin + if Exec_Module_State = Uninitialized then + declare + Exec_Path : constant String := Executable_Name; + Exec_Load : constant Address := Get_Executable_Load_Address; + Success : Boolean; + begin + Init_Module (Exec_Module, Success, Exec_Path, Exec_Load); + + if Success then + Exec_Module_State := Initialized; + else + Exec_Module_State := Failed; + end if; + end; + end if; + end Init_Exec_Module; + + -------- + -- Lt -- + -------- + + function Lt (Left, Right : Module_Cache_Acc) return Boolean is + begin + return Low (Left.C) < Low (Right.C); + end Lt; + + ----------------------------- + -- Module_Cache_Array_Sort -- + ----------------------------- + + procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort + (Natural, + Module_Cache_Acc, + Module_Array, + Lt); + + ------------------ + -- Enable_Cache -- + ------------------ + + procedure Enable_Cache (Include_Modules : Boolean := False) is + begin + -- Can be called at most once + if Cache_Chain /= null then + return; + end if; + + -- Add all modules + Init_Exec_Module; + Cache_Chain := Exec_Module'Access; + + if Include_Modules then + Module_Name.Build_Cache_For_All_Modules; + end if; + + -- Build and fill the array of modules + declare + Count : Natural; + Module : Module_Cache_Acc; + begin + for Phase in 1 .. 2 loop + Count := 0; + Module := Cache_Chain; + while Module /= null loop + Count := Count + 1; + + if Phase = 1 then + Enable_Cache (Module.C); + else + Modules_Cache (Count) := Module; + end if; + Module := Module.Chain; + end loop; + + if Phase = 1 then + Modules_Cache := new Module_Array (1 .. Count); + end if; + end loop; + end; + + -- Sort the array + Module_Cache_Array_Sort (Modules_Cache.all); + end Enable_Cache; + + --------------------- + -- Executable_Name -- + --------------------- + + function Executable_Name return String is + -- We have to import gnat_argv as an Address to match the type of + -- gnat_argv in the binder generated file. Otherwise, we get spurious + -- warnings about type mismatch when LTO is turned on. + + Gnat_Argv : System.Address; + pragma Import (C, Gnat_Argv, "gnat_argv"); + + type Argv_Array is array (0 .. 0) of System.Address; + package Conv is new System.Address_To_Access_Conversions (Argv_Array); + + function locate_exec_on_path (A : System.Address) return System.Address; + pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path"); + + begin + if Gnat_Argv = Null_Address then + return ""; + end if; + + declare + Addr : constant System.Address := + locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0)); + Result : constant String := Value (Addr); + + begin + -- The buffer returned by locate_exec_on_path was allocated using + -- malloc, so we should use free to release the memory. + + if Addr /= Null_Address then + System.CRTL.free (Addr); + end if; + + return Result; + end; + end Executable_Name; + + ------------------ + -- Close_Module -- + ------------------ + + procedure Close_Module (Module : in out Module_Cache) is + begin + Close (Module.C); + Strings.Free (Module.Name); + end Close_Module; + + ----------------- + -- Init_Module -- + ----------------- + + procedure Init_Module + (Module : out Module_Cache; + Success : out Boolean; + Module_Name : String; + Load_Address : Address := Null_Address) + is + begin + -- Early return if the module is not known + + if Module_Name = "" then + Success := False; + return; + end if; + + Open (Module_Name, Module.C, Success); + + -- If a module can't be opened just return now, we just cannot give more + -- information in this case. + + if not Success then + return; + end if; + + Set_Load_Address (Module.C, Load_Address); + + Module.Name := new String'(Module_Name); + end Init_Module; + + ------------------------------- + -- Module_Symbolic_Traceback -- + ------------------------------- + + procedure Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + Success : Boolean := False; + begin + if Symbolic.Module_Name.Is_Supported then + Append (Res, '['); + Append (Res, Module.Name.all); + Append (Res, ']' & ASCII.LF); + end if; + + Dwarf_Lines.Symbolic_Traceback + (Module.C, + Traceback, + Suppress_Hex, + Success, + Res); + + if not Success then + Hexa_Traceback (Traceback, Suppress_Hex, Res); + end if; + + -- We must not allow an unhandled exception here, since this function + -- may be installed as a decorator for all automatic exceptions. + + exception + when others => + return; + end Module_Symbolic_Traceback; + + ------------------------------------- + -- Multi_Module_Symbolic_Traceback -- + ------------------------------------- + + procedure Multi_Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + F : constant Natural := Traceback'First; + begin + if Traceback'Length = 0 or else Is_Full (Res) then + return; + end if; + + if Modules_Cache /= null then + -- Search in the cache + + declare + Addr : constant Address := Traceback (F); + Hi, Lo, Mid : Natural; + begin + Lo := Modules_Cache'First; + Hi := Modules_Cache'Last; + while Lo <= Hi loop + Mid := (Lo + Hi) / 2; + if Addr < Low (Modules_Cache (Mid).C) then + Hi := Mid - 1; + elsif Is_Inside (Modules_Cache (Mid).C, Addr) then + Multi_Module_Symbolic_Traceback + (Traceback, + Modules_Cache (Mid).all, + Suppress_Hex, + Res); + return; + else + Lo := Mid + 1; + end if; + end loop; + + -- Not found + Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); + Multi_Module_Symbolic_Traceback + (Traceback (F + 1 .. Traceback'Last), + Suppress_Hex, + Res); + end; + else + + -- First try the executable + if Is_Inside (Exec_Module.C, Traceback (F)) then + Multi_Module_Symbolic_Traceback + (Traceback, + Exec_Module, + Suppress_Hex, + Res); + return; + end if; + + -- Otherwise, try a shared library + declare + Addr : aliased System.Address := Traceback (F); + M_Name : constant String := Module_Name.Get (Addr'Access); + Module : Module_Cache; + Success : Boolean; + begin + Init_Module (Module, Success, M_Name, System.Null_Address); + if Success then + Multi_Module_Symbolic_Traceback + (Traceback, + Module, + Suppress_Hex, + Res); + Close_Module (Module); + else + -- Module not found + Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); + Multi_Module_Symbolic_Traceback + (Traceback (F + 1 .. Traceback'Last), + Suppress_Hex, + Res); + end if; + end; + end if; + end Multi_Module_Symbolic_Traceback; + + procedure Multi_Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + Pos : Positive; + begin + -- Will symbolize the first address... + + Pos := Traceback'First + 1; + + -- ... and all addresses in the same module + + Same_Module : + loop + exit Same_Module when Pos > Traceback'Last; + + -- Get address to check for corresponding module name + + exit Same_Module when not Is_Inside (Module.C, Traceback (Pos)); + + Pos := Pos + 1; + end loop Same_Module; + + Module_Symbolic_Traceback + (Traceback (Traceback'First .. Pos - 1), + Module, + Suppress_Hex, + Res); + Multi_Module_Symbolic_Traceback + (Traceback (Pos .. Traceback'Last), + Suppress_Hex, + Res); + end Multi_Module_Symbolic_Traceback; + + -------------------- + -- Hexa_Traceback -- + -------------------- + + procedure Hexa_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + use System.Traceback_Entries; + begin + if Suppress_Hex then + Append (Res, "..."); + Append (Res, ASCII.LF); + else + for J in Traceback'Range loop + Append_Address (Res, PC_For (Traceback (J))); + Append (Res, ASCII.LF); + end loop; + end if; + end Hexa_Traceback; + + -------------------------------- + -- Symbolic_Traceback_No_Lock -- + -------------------------------- + + procedure Symbolic_Traceback_No_Lock + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + begin + if Symbolic.Module_Name.Is_Supported then + Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res); + else + if Exec_Module_State = Failed then + Append (Res, "Call stack traceback locations:" & ASCII.LF); + Hexa_Traceback (Traceback, Suppress_Hex, Res); + else + Module_Symbolic_Traceback + (Traceback, + Exec_Module, + Suppress_Hex, + Res); + end if; + end if; + end Symbolic_Traceback_No_Lock; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean) return String + is + Res : Bounded_String (Max_Length => Max_String_Length); + begin + System.Soft_Links.Lock_Task.all; + Init_Exec_Module; + Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res); + System.Soft_Links.Unlock_Task.all; + + return To_String (Res); + + exception + when others => + System.Soft_Links.Unlock_Task.all; + raise; + end Symbolic_Traceback; + + function Symbolic_Traceback + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is + begin + return Symbolic_Traceback (Traceback, Suppress_Hex => False); + end Symbolic_Traceback; + + function Symbolic_Traceback_No_Hex + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is + begin + return Symbolic_Traceback (Traceback, Suppress_Hex => True); + end Symbolic_Traceback_No_Hex; + + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence; + Suppress_Hex : Boolean) return String + is + begin + return Symbolic_Traceback + (Ada.Exceptions.Traceback.Tracebacks (E), + Suppress_Hex); + end Symbolic_Traceback; + + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence) return String + is + begin + return Symbolic_Traceback (E, Suppress_Hex => False); + end Symbolic_Traceback; + + function Symbolic_Traceback_No_Hex + (E : Ada.Exceptions.Exception_Occurrence) return String is + begin + return Symbolic_Traceback (E, Suppress_Hex => True); + end Symbolic_Traceback_No_Hex; + + Exception_Tracebacks_Symbolic : Integer; + pragma Import + (C, + Exception_Tracebacks_Symbolic, + "__gl_exception_tracebacks_symbolic"); + -- Boolean indicating whether symbolic tracebacks should be generated. + + use Standard_Library; +begin + -- If this version of this package is available, and the binder switch -Es + -- was given, then we want to use this as the decorator by default, and we + -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user + -- cannot have already set Exception_Trace, because the runtime library is + -- elaborated before user-defined code. + + if Exception_Tracebacks_Symbolic /= 0 then + Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access); + pragma Assert (Exception_Trace = RM_Convention); + Exception_Trace := Unhandled_Raise_In_Main; + end if; +end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-tsmona-linux.adb b/gcc/ada/libgnat/s-tsmona-linux.adb deleted file mode 100644 index 8c1f8b4ada8..00000000000 --- a/gcc/ada/libgnat/s-tsmona-linux.adb +++ /dev/null @@ -1,190 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2012-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the GNU/Linux specific version of this package -with Interfaces.C; use Interfaces.C; - -with System.Address_Operations; use System.Address_Operations; - -separate (System.Traceback.Symbolic) - -package body Module_Name is - - use System; - - pragma Linker_Options ("-ldl"); - - function Is_Shared_Lib (Base : Address) return Boolean; - -- Returns True if a shared library - - -- The principle is: - - -- 1. We get information about the module containing the address. - - -- 2. We check that the full pathname is pointing to a shared library. - - -- 3. for shared libraries, we return the non relocated address (so - -- the absolute address in the shared library). - - -- 4. we also return the full pathname of the module containing this - -- address. - - ------------------- - -- Is_Shared_Lib -- - ------------------- - - function Is_Shared_Lib (Base : Address) return Boolean is - EI_NIDENT : constant := 16; - type u16 is mod 2 ** 16; - - -- Just declare the needed header information, we just need to read the - -- type encoded in the second field. - - type Elf32_Ehdr is record - e_ident : char_array (1 .. EI_NIDENT); - e_type : u16; - end record; - - ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN - - Header : Elf32_Ehdr; - pragma Import (Ada, Header); - -- Suppress initialization in Normalized_Scalars mode - for Header'Address use Base; - - begin - return Header.e_type = ET_DYN; - exception - when others => - return False; - end Is_Shared_Lib; - - --------------------------------- - -- Build_Cache_For_All_Modules -- - --------------------------------- - - procedure Build_Cache_For_All_Modules is - type link_map; - type link_map_acc is access all link_map; - pragma Convention (C, link_map_acc); - - type link_map is record - l_addr : Address; - -- Base address of the shared object - - l_name : Address; - -- Null-terminated absolute file name - - l_ld : Address; - -- Dynamic section - - l_next, l_prev : link_map_acc; - -- Chain - end record; - pragma Convention (C, link_map); - - type r_debug_type is record - r_version : Integer; - r_map : link_map_acc; - end record; - pragma Convention (C, r_debug_type); - - r_debug : r_debug_type; - pragma Import (C, r_debug, "_r_debug"); - - lm : link_map_acc; - begin - lm := r_debug.r_map; - while lm /= null loop - if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then - -- Discard non-file (like the executable itself or the gate). - Add_Module_To_Cache (Value (lm.l_name)); - end if; - lm := lm.l_next; - end loop; - end Build_Cache_For_All_Modules; - - --------- - -- Get -- - --------- - - function Get (Addr : access System.Address) return String is - - -- Dl_info record for Linux, used to get sym reloc offset - - type Dl_info is record - dli_fname : System.Address; - dli_fbase : System.Address; - dli_sname : System.Address; - dli_saddr : System.Address; - end record; - - function dladdr - (addr : System.Address; - info : not null access Dl_info) return int; - pragma Import (C, dladdr, "dladdr"); - -- This is a Linux extension and not POSIX - - info : aliased Dl_info; - - begin - if dladdr (Addr.all, info'Access) /= 0 then - - -- If we have a shared library we need to adjust the address to - -- be relative to the base address of the library. - - if Is_Shared_Lib (info.dli_fbase) then - Addr.all := SubA (Addr.all, info.dli_fbase); - end if; - - return Value (info.dli_fname); - - -- Not found, fallback to executable name - - else - return ""; - end if; - - exception - when others => - return ""; - end Get; - - ------------------ - -- Is_Supported -- - ------------------ - - function Is_Supported return Boolean is - begin - return True; - end Is_Supported; - -end Module_Name; diff --git a/gcc/ada/libgnat/s-tsmona-mingw.adb b/gcc/ada/libgnat/s-tsmona-mingw.adb deleted file mode 100644 index 46c35cd791a..00000000000 --- a/gcc/ada/libgnat/s-tsmona-mingw.adb +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2012-2017, 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- -- --- 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 -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Windows specific version of this package - -with System.Win32; use System.Win32; - -separate (System.Traceback.Symbolic) - -package body Module_Name is - - use System; - - --------------------------------- - -- Build_Cache_For_All_Modules -- - --------------------------------- - - procedure Build_Cache_For_All_Modules is - begin - null; - end Build_Cache_For_All_Modules; - - --------- - -- Get -- - --------- - - function Get (Addr : access System.Address) return String is - Res : DWORD; - hModule : aliased HANDLE; - Path : String (1 .. 1_024); - - begin - if GetModuleHandleEx - (GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, - Addr.all, - hModule'Access) = Win32.TRUE - then - Res := GetModuleFileName (hModule, Path'Address, Path'Length); - - if FreeLibrary (hModule) = Win32.FALSE then - null; - end if; - - if Res > 0 then - return Path (1 .. Positive (Res)); - end if; - end if; - - return ""; - - exception - when others => - return ""; - end Get; - - ------------------ - -- Is_Supported -- - ------------------ - - function Is_Supported return Boolean is - begin - return True; - end Is_Supported; - -end Module_Name; diff --git a/gcc/ada/libgnat/s-tsmona__linux.adb b/gcc/ada/libgnat/s-tsmona__linux.adb new file mode 100644 index 00000000000..8c1f8b4ada8 --- /dev/null +++ b/gcc/ada/libgnat/s-tsmona__linux.adb @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the GNU/Linux specific version of this package +with Interfaces.C; use Interfaces.C; + +with System.Address_Operations; use System.Address_Operations; + +separate (System.Traceback.Symbolic) + +package body Module_Name is + + use System; + + pragma Linker_Options ("-ldl"); + + function Is_Shared_Lib (Base : Address) return Boolean; + -- Returns True if a shared library + + -- The principle is: + + -- 1. We get information about the module containing the address. + + -- 2. We check that the full pathname is pointing to a shared library. + + -- 3. for shared libraries, we return the non relocated address (so + -- the absolute address in the shared library). + + -- 4. we also return the full pathname of the module containing this + -- address. + + ------------------- + -- Is_Shared_Lib -- + ------------------- + + function Is_Shared_Lib (Base : Address) return Boolean is + EI_NIDENT : constant := 16; + type u16 is mod 2 ** 16; + + -- Just declare the needed header information, we just need to read the + -- type encoded in the second field. + + type Elf32_Ehdr is record + e_ident : char_array (1 .. EI_NIDENT); + e_type : u16; + end record; + + ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN + + Header : Elf32_Ehdr; + pragma Import (Ada, Header); + -- Suppress initialization in Normalized_Scalars mode + for Header'Address use Base; + + begin + return Header.e_type = ET_DYN; + exception + when others => + return False; + end Is_Shared_Lib; + + --------------------------------- + -- Build_Cache_For_All_Modules -- + --------------------------------- + + procedure Build_Cache_For_All_Modules is + type link_map; + type link_map_acc is access all link_map; + pragma Convention (C, link_map_acc); + + type link_map is record + l_addr : Address; + -- Base address of the shared object + + l_name : Address; + -- Null-terminated absolute file name + + l_ld : Address; + -- Dynamic section + + l_next, l_prev : link_map_acc; + -- Chain + end record; + pragma Convention (C, link_map); + + type r_debug_type is record + r_version : Integer; + r_map : link_map_acc; + end record; + pragma Convention (C, r_debug_type); + + r_debug : r_debug_type; + pragma Import (C, r_debug, "_r_debug"); + + lm : link_map_acc; + begin + lm := r_debug.r_map; + while lm /= null loop + if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then + -- Discard non-file (like the executable itself or the gate). + Add_Module_To_Cache (Value (lm.l_name)); + end if; + lm := lm.l_next; + end loop; + end Build_Cache_For_All_Modules; + + --------- + -- Get -- + --------- + + function Get (Addr : access System.Address) return String is + + -- Dl_info record for Linux, used to get sym reloc offset + + type Dl_info is record + dli_fname : System.Address; + dli_fbase : System.Address; + dli_sname : System.Address; + dli_saddr : System.Address; + end record; + + function dladdr + (addr : System.Address; + info : not null access Dl_info) return int; + pragma Import (C, dladdr, "dladdr"); + -- This is a Linux extension and not POSIX + + info : aliased Dl_info; + + begin + if dladdr (Addr.all, info'Access) /= 0 then + + -- If we have a shared library we need to adjust the address to + -- be relative to the base address of the library. + + if Is_Shared_Lib (info.dli_fbase) then + Addr.all := SubA (Addr.all, info.dli_fbase); + end if; + + return Value (info.dli_fname); + + -- Not found, fallback to executable name + + else + return ""; + end if; + + exception + when others => + return ""; + end Get; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported return Boolean is + begin + return True; + end Is_Supported; + +end Module_Name; diff --git a/gcc/ada/libgnat/s-tsmona__mingw.adb b/gcc/ada/libgnat/s-tsmona__mingw.adb new file mode 100644 index 00000000000..46c35cd791a --- /dev/null +++ b/gcc/ada/libgnat/s-tsmona__mingw.adb @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K . S Y M B O L I C . M O D U L E _ N A M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, 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- -- +-- 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows specific version of this package + +with System.Win32; use System.Win32; + +separate (System.Traceback.Symbolic) + +package body Module_Name is + + use System; + + --------------------------------- + -- Build_Cache_For_All_Modules -- + --------------------------------- + + procedure Build_Cache_For_All_Modules is + begin + null; + end Build_Cache_For_All_Modules; + + --------- + -- Get -- + --------- + + function Get (Addr : access System.Address) return String is + Res : DWORD; + hModule : aliased HANDLE; + Path : String (1 .. 1_024); + + begin + if GetModuleHandleEx + (GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, + Addr.all, + hModule'Access) = Win32.TRUE + then + Res := GetModuleFileName (hModule, Path'Address, Path'Length); + + if FreeLibrary (hModule) = Win32.FALSE then + null; + end if; + + if Res > 0 then + return Path (1 .. Positive (Res)); + end if; + end if; + + return ""; + + exception + when others => + return ""; + end Get; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported return Boolean is + begin + return True; + end Is_Supported; + +end Module_Name; diff --git a/gcc/ada/libgnat/s__thread-ae653.adb b/gcc/ada/libgnat/s__thread-ae653.adb new file mode 100644 index 00000000000..ca871286fce --- /dev/null +++ b/gcc/ada/libgnat/s__thread-ae653.adb @@ -0,0 +1,247 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T H R E A D S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks 653 version of this package + +pragma Restrictions (No_Tasking); +-- The VxWorks 653 version of this package is intended only for programs +-- which do not use Ada tasking. This restriction ensures that this +-- will be checked by the binder. + +with System.OS_Versions; use System.OS_Versions; +with System.Secondary_Stack; +pragma Elaborate_All (System.Secondary_Stack); + +package body System.Threads is + + use Interfaces.C; + + package SSS renames System.Secondary_Stack; + + package SSL renames System.Soft_Links; + + Current_ATSD : aliased System.Address := System.Null_Address; + pragma Export (C, Current_ATSD, "__gnat_current_atsd"); + + Main_ATSD : aliased ATSD; + -- TSD for environment task + + Stack_Limit : Address; + + pragma Import (C, Stack_Limit, "__gnat_stack_limit"); + + type Set_Stack_Limit_Proc_Acc is access procedure; + pragma Convention (C, Set_Stack_Limit_Proc_Acc); + + Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; + pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); + -- Procedure to be called when a task is created to set stack limit if + -- limit checking is used. + + -------------------------- + -- VxWorks specific API -- + -------------------------- + + ERROR : constant STATUS := Interfaces.C.int (-1); + + function taskIdVerify (tid : t_id) return STATUS; + pragma Import (C, taskIdVerify, "taskIdVerify"); + + function taskIdSelf return t_id; + pragma Import (C, taskIdSelf, "taskIdSelf"); + + function taskVarAdd + (tid : t_id; pVar : System.Address) return int; + pragma Import (C, taskVarAdd, "taskVarAdd"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Init_RTS; + -- This procedure performs the initialization of the run-time lib. + -- It installs System.Threads versions of certain operations of the + -- run-time lib. + + procedure Install_Handler; + pragma Import (C, Install_Handler, "__gnat_install_handler"); + + function Get_Sec_Stack_Addr return Address; + + procedure Set_Sec_Stack_Addr (Addr : Address); + + ----------------------- + -- Thread_Body_Enter -- + ----------------------- + + procedure Thread_Body_Enter + (Sec_Stack_Address : System.Address; + Sec_Stack_Size : Natural; + Process_ATSD_Address : System.Address) + is + -- Current_ATSD must already be a taskVar of taskIdSelf. + -- No assertion because taskVarGet is not available on VxWorks/CERT, + -- which is used on VxWorks 653 3.x as a guest OS. + + TSD : constant ATSD_Access := From_Address (Process_ATSD_Address); + + begin + + TSD.Sec_Stack_Addr := Sec_Stack_Address; + SSS.SS_Init (TSD.Sec_Stack_Addr, Sec_Stack_Size); + Current_ATSD := Process_ATSD_Address; + + Install_Handler; + + -- Initialize stack limit if needed + + if Current_ATSD /= Main_ATSD'Address + and then Set_Stack_Limit_Hook /= null + then + Set_Stack_Limit_Hook.all; + end if; + end Thread_Body_Enter; + + ---------------------------------- + -- Thread_Body_Exceptional_Exit -- + ---------------------------------- + + procedure Thread_Body_Exceptional_Exit + (EO : Ada.Exceptions.Exception_Occurrence) + is + pragma Unreferenced (EO); + + begin + -- No action for this target + + null; + end Thread_Body_Exceptional_Exit; + + ----------------------- + -- Thread_Body_Leave -- + ----------------------- + + procedure Thread_Body_Leave is + begin + -- No action for this target + + null; + end Thread_Body_Leave; + + -------------- + -- Init_RTS -- + -------------- + + procedure Init_RTS is + -- Register environment task + Result : constant Interfaces.C.int := Register (taskIdSelf); + pragma Assert (Result /= ERROR); + + begin + Main_ATSD.Sec_Stack_Addr := SSL.Get_Sec_Stack_Addr_NT; + Current_ATSD := Main_ATSD'Address; + Install_Handler; + SSL.Get_Sec_Stack_Addr := Get_Sec_Stack_Addr'Access; + SSL.Set_Sec_Stack_Addr := Set_Sec_Stack_Addr'Access; + end Init_RTS; + + ------------------------ + -- Get_Sec_Stack_Addr -- + ------------------------ + + function Get_Sec_Stack_Addr return Address is + CTSD : constant ATSD_Access := From_Address (Current_ATSD); + begin + pragma Assert (CTSD /= null); + return CTSD.Sec_Stack_Addr; + end Get_Sec_Stack_Addr; + + -------------- + -- Register -- + -------------- + + function Register (T : Thread_Id) return STATUS is + Result : STATUS; + + begin + -- It cannot be assumed that the caller of this routine has a ATSD; + -- so neither this procedure nor the procedures that it calls should + -- raise or handle exceptions, or make use of a secondary stack. + + -- This routine is only necessary because taskVarAdd cannot be + -- executed once an VxWorks 653 partition has entered normal mode + -- (depending on configRecord.c, allocation could be disabled). + -- Otherwise, everything could have been done in Thread_Body_Enter. + + if taskIdVerify (T) = ERROR then + return ERROR; + end if; + + Result := taskVarAdd (T, Current_ATSD'Address); + pragma Assert (Result /= ERROR); + + -- The same issue applies to the task variable that contains the stack + -- limit when that overflow checking mechanism is used instead of + -- probing. If stack checking is enabled and limit checking is used, + -- allocate the limit for this task. The environment task has this + -- initialized by the binder-generated main when + -- System.Stack_Check_Limits = True. + + pragma Warnings (Off); + -- OS is a constant + if Result /= ERROR + and then OS /= VxWorks_653 + and then Set_Stack_Limit_Hook /= null + then + Result := taskVarAdd (T, Stack_Limit'Address); + pragma Assert (Result /= ERROR); + end if; + pragma Warnings (On); + + return Result; + end Register; + + ------------------------ + -- Set_Sec_Stack_Addr -- + ------------------------ + + procedure Set_Sec_Stack_Addr (Addr : Address) is + CTSD : constant ATSD_Access := From_Address (Current_ATSD); + begin + pragma Assert (CTSD /= null); + CTSD.Sec_Stack_Addr := Addr; + end Set_Sec_Stack_Addr; + +begin + -- Initialize run-time library + + Init_RTS; +end System.Threads;