diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-02-09 11:14:42 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2005-02-09 11:14:42 +0000 |
| commit | 7ce1e9473ed905b0abcbe66b2fef2c81c8e3cffa (patch) | |
| tree | fc2c56125c477bf3312555b0de2bc5a1860ba895 /gcc/ada | |
| parent | 661a91eca8edc1eb8d2516f867db70a441df2bcf (diff) | |
| download | gcc-7ce1e9473ed905b0abcbe66b2fef2c81c8e3cffa.tar.gz | |
* a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads,
a-crbtgk.adb, a-crbltr.ads, a-coprnu.ads, a-coprnu.adb,
a-coorse.ads, a-coorse.adb, a-convec.ads, a-convec.adb,
a-contai.ads, a-coinve.ads, a-coinve.adb, a-cohata.ads,
a-cohama.ads, a-cohama.adb, a-ciorse.ads, a-ciorse.adb,
a-cihama.ads, a-cihama.adb, a-cidlli.ads, a-cidlli.adb,
a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, a-cgcaso.adb,
a-cgarso.ads, a-cgarso.adb, a-cdlili.ads, a-cdlili.adb,
a-cgaaso.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb,
a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads,
a-coorma.ads, a-swunha.ads, a-stunha.ads, a-ciormu.ads,
a-coormu.ads, a-rbtgso.ads, a-swunha.adb, a-stunha.adb,
a-cgaaso.ads, a-ciorma.adb, a-coorma.adb, a-secain.adb,
a-secain.ads, a-slcain.ads, a-slcain.adb, a-shcain.ads,
a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads,
a-stwiha.adb, a-strhas.ads, a-strhas.adb, a-chzla1.ads,
a-chzla9.ads, a-lfztio.ads, a-liztio.ads, a-llfzti.ads,
a-llizti.ads, a-sfztio.ads, a-siztio.ads, a-ssizti.ads,
a-stzbou.adb, a-stzbou.ads, a-stzfix.adb, a-stzfix.ads,
a-stzhas.adb, a-stzhas.ads, a-stzmap.adb, a-stzmap.ads,
a-stzsea.adb, a-stzsea.ads, a-stzsup.adb, a-stzsup.ads,
a-stzunb.adb, a-stzunb.ads, a-swunau.adb, a-swunau.ads,
a-szmzco.ads, a-szunau.adb, a-szunau.ads, a-szunha.adb,
a-szunha.ads, a-szuzti.adb, a-szuzti.ads, a-tiunio.ads,
a-wwunio.ads, a-ztcoau.adb, a-ztcoau.ads, a-ztcoio.adb,
a-ztcoio.ads, a-ztcstr.adb, a-ztcstr.ads, a-ztdeau.adb,
a-ztdeau.ads, a-ztdeio.adb, a-ztdeio.ads, a-ztedit.adb,
a-ztedit.ads, a-ztenau.adb, a-ztenau.ads, a-ztenio.adb,
a-ztenio.ads, a-ztexio.adb, a-ztexio.ads, a-ztfiio.adb,
a-ztfiio.ads, a-ztflau.adb, a-ztflau.ads, a-ztflio.adb,
a-ztflio.ads, a-ztgeau.adb, a-ztgeau.ads, a-ztinau.adb,
a-ztinau.ads, a-ztinio.adb, a-ztinio.ads, a-ztmoau.adb,
a-ztmoau.ads, a-ztmoio.adb, a-ztmoio.ads, a-zttest.adb,
a-zttest.ads, a-zzunio.ads: New files. Part of new Ada 2005
library.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@94764 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc/ada')
135 files changed, 47004 insertions, 0 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6c9a04c2552..a4adba5fda6 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,41 @@ +2005-02-09 Arnaud Charlet <charlet@adacore.com> + + * a-rbtgso.adb, a-crbtgo.ads, a-crbtgo.adb, a-crbtgk.ads, + a-crbtgk.adb, a-crbltr.ads, a-coprnu.ads, a-coprnu.adb, + a-coorse.ads, a-coorse.adb, a-convec.ads, a-convec.adb, + a-contai.ads, a-coinve.ads, a-coinve.adb, a-cohata.ads, + a-cohama.ads, a-cohama.adb, a-ciorse.ads, a-ciorse.adb, + a-cihama.ads, a-cihama.adb, a-cidlli.ads, a-cidlli.adb, + a-chtgop.ads, a-chtgop.adb, a-cgcaso.ads, a-cgcaso.adb, + a-cgarso.ads, a-cgarso.adb, a-cdlili.ads, a-cdlili.adb, + a-cgaaso.adb, a-coormu.adb, a-ciormu.adb, a-cihase.adb, + a-cihase.ads, a-cohase.adb, a-cohase.ads, a-ciorma.ads, + a-coorma.ads, a-swunha.ads, a-stunha.ads, a-ciormu.ads, + a-coormu.ads, a-rbtgso.ads, a-swunha.adb, a-stunha.adb, + a-cgaaso.ads, a-ciorma.adb, a-coorma.adb, a-secain.adb, + a-secain.ads, a-slcain.ads, a-slcain.adb, a-shcain.ads, + a-shcain.adb, a-chtgke.ads, a-chtgke.adb, a-stwiha.ads, + a-stwiha.adb, a-strhas.ads, a-strhas.adb, a-chzla1.ads, + a-chzla9.ads, a-lfztio.ads, a-liztio.ads, a-llfzti.ads, + a-llizti.ads, a-sfztio.ads, a-siztio.ads, a-ssizti.ads, + a-stzbou.adb, a-stzbou.ads, a-stzfix.adb, a-stzfix.ads, + a-stzhas.adb, a-stzhas.ads, a-stzmap.adb, a-stzmap.ads, + a-stzsea.adb, a-stzsea.ads, a-stzsup.adb, a-stzsup.ads, + a-stzunb.adb, a-stzunb.ads, a-swunau.adb, a-swunau.ads, + a-szmzco.ads, a-szunau.adb, a-szunau.ads, a-szunha.adb, + a-szunha.ads, a-szuzti.adb, a-szuzti.ads, a-tiunio.ads, + a-wwunio.ads, a-ztcoau.adb, a-ztcoau.ads, a-ztcoio.adb, + a-ztcoio.ads, a-ztcstr.adb, a-ztcstr.ads, a-ztdeau.adb, + a-ztdeau.ads, a-ztdeio.adb, a-ztdeio.ads, a-ztedit.adb, + a-ztedit.ads, a-ztenau.adb, a-ztenau.ads, a-ztenio.adb, + a-ztenio.ads, a-ztexio.adb, a-ztexio.ads, a-ztfiio.adb, + a-ztfiio.ads, a-ztflau.adb, a-ztflau.ads, a-ztflio.adb, + a-ztflio.ads, a-ztgeau.adb, a-ztgeau.ads, a-ztinau.adb, + a-ztinau.ads, a-ztinio.adb, a-ztinio.ads, a-ztmoau.adb, + a-ztmoau.ads, a-ztmoio.adb, a-ztmoio.ads, a-zttest.adb, + a-zttest.ads, a-zzunio.ads: New files. Part of new Ada 2005 + library. + 2005-01-27 Laurent GUERBY <laurent@guerby.net> * Makefile.in: Fix a-intnam.ads from previous commit, diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb new file mode 100644 index 00000000000..435679d313d --- /dev/null +++ b/gcc/ada/a-cdlili.adb @@ -0,0 +1,1282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Doubly_Linked_Lists is + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Delete_Node + (Container : in out List; + Node : in out Node_Access); + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + L : Node_Access := Left.First; + R : Node_Access := Right.First; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + for J in 1 .. Left.Length loop + if L.Element /= R.Element then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out List) is + Src : Node_Access := Container.First; + Length : constant Count_Type := Container.Length; + + begin + if Src = null then + pragma Assert (Container.Last = null); + pragma Assert (Length = 0); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + pragma Assert (Length > 0); + + Container.First := null; + Container.Last := null; + Container.Length := 0; + + Container.First := new Node_Type'(Src.Element, null, null); + + Container.Last := Container.First; + loop + Container.Length := Container.Length + 1; + Src := Src.Next; + exit when Src = null; + Container.Last.Next := new Node_Type'(Element => Src.Element, + Prev => Container.Last, + Next => null); + Container.Last := Container.Last.Next; + end loop; + + pragma Assert (Container.Length = Length); + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + begin + Delete_Last (Container, Count => Container.Length); + end Clear; + + -------------- + -- Continue -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + for Index in 1 .. Count loop + Delete_Node (Container, Position.Node); + + if Position.Node = null then + Position.Container := null; + return; + end if; + end loop; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1) + is + Node : Node_Access := Container.First; + begin + for J in 1 .. Count_Type'Min (Count, Container.Length) loop + Delete_Node (Container, Node); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1) + is + Node : Node_Access; + begin + for J in 1 .. Count_Type'Min (Count, Container.Length) loop + Node := Container.Last; + Delete_Node (Container, Node); + end loop; + end Delete_Last; + + ----------------- + -- Delete_Node -- + ----------------- + + procedure Delete_Node + (Container : in out List; + Node : in out Node_Access) + is + X : Node_Access := Node; + + begin + Node := X.Next; + Container.Length := Container.Length - 1; + + if X = Container.First then + Container.First := X.Next; + + if X = Container.Last then + pragma Assert (Container.First = null); + pragma Assert (Container.Length = 0); + Container.Last := null; + else + pragma Assert (Container.Length > 0); + Container.First.Prev := null; + end if; + + elsif X = Container.Last then + pragma Assert (Container.Length > 0); + + Container.Last := X.Prev; + Container.Last.Next := null; + + else + pragma Assert (Container.Length > 0); + + X.Next.Prev := X.Prev; + X.Prev.Next := X.Next; + end if; + + Free (X); + end Delete_Node; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element; + end Element; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.First; + elsif Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + while Node /= null loop + if Node.Element = Item then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := Node.Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + begin + return Container.First.Element; + end First_Element; + + ------------------- + -- Generic_Merge -- + ------------------- + + procedure Generic_Merge + (Target : in out List; + Source : in out List) + is + LI : Cursor := First (Target); + RI : Cursor := First (Source); + + begin + if Target'Address = Source'Address then + return; + end if; + + while RI.Node /= null loop + if LI.Node = null then + Splice (Target, No_Element, Source); + return; + end if; + + if RI.Node.Element < LI.Node.Element then + declare + RJ : constant Cursor := RI; + begin + RI.Node := RI.Node.Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LI.Node.Next; + end if; + end loop; + end Generic_Merge; + + ------------------ + -- Generic_Sort -- + ------------------ + + procedure Generic_Sort (Container : in out List) is + + procedure Partition + (Pivot : in Node_Access; + Back : in Node_Access); + + procedure Sort (Front, Back : Node_Access); + + --------------- + -- Partition -- + --------------- + + procedure Partition + (Pivot : Node_Access; + Back : Node_Access) + is + Node : Node_Access := Pivot.Next; + + begin + while Node /= Back loop + if Node.Element < Pivot.Element then + declare + Prev : constant Node_Access := Node.Prev; + Next : constant Node_Access := Node.Next; + + begin + Prev.Next := Next; + + if Next = null then + Container.Last := Prev; + else + Next.Prev := Prev; + end if; + + Node.Next := Pivot; + Node.Prev := Pivot.Prev; + + Pivot.Prev := Node; + + if Node.Prev = null then + Container.First := Node; + else + Node.Prev.Next := Node; + end if; + + Node := Next; + end; + + else + Node := Node.Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Node_Access) is + Pivot : Node_Access; + + begin + if Front = null then + Pivot := Container.First; + else + Pivot := Front.Next; + end if; + + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Generic_Sort + + begin + Sort (Front => null, Back => null); + + pragma Assert (Container.Length = 0 + or else + (Container.First.Prev = null + and then Container.Last.Next = null)); + end Generic_Sort; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position.Container /= null and then Position.Node /= null; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Node : Node_Access; + + begin + if Before.Container /= null + and then Before.Container /= List_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + New_Node := new Node_Type'(New_Item, null, null); + Insert_Internal (Container, Before.Node, New_Node); + + Position := Cursor'(Before.Container, New_Node); + + for J in Count_Type'(2) .. Count loop + New_Node := new Node_Type'(New_Item, null, null); + Insert_Internal (Container, Before.Node, New_Node); + end loop; + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Node : Node_Access; + + begin + if Before.Container /= null + and then Before.Container /= List_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + New_Node := new Node_Type; + Insert_Internal (Container, Before.Node, New_Node); + + Position := Cursor'(Before.Container, New_Node); + + for J in Count_Type'(2) .. Count loop + New_Node := new Node_Type; + Insert_Internal (Container, Before.Node, New_Node); + end loop; + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access) + is + begin + if Container.Length = 0 then + pragma Assert (Before = null); + pragma Assert (Container.First = null); + pragma Assert (Container.Last = null); + + Container.First := New_Node; + Container.Last := New_Node; + + elsif Before = null then + pragma Assert (Container.Last.Next = null); + + Container.Last.Next := New_Node; + New_Node.Prev := Container.Last; + + Container.Last := New_Node; + + elsif Before = Container.First then + pragma Assert (Container.First.Prev = null); + + Container.First.Prev := New_Node; + New_Node.Next := Container.First; + + Container.First := New_Node; + + else + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + New_Node.Next := Before; + New_Node.Prev := Before.Prev; + + Before.Prev.Next := New_Node; + Before.Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + Node : Node_Access := Container.First; + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Next; + end loop; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + begin + return Container.Last.Element; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out List; + Source : in out List) + is + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Length > 0 then + raise Constraint_Error; + end if; + + Target.First := Source.First; + Source.First := null; + + Target.Last := Source.Last; + Source.Last := null; + + Target.Length := Source.Length; + Source.Length := 0; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + if Position.Node = null then + return; + end if; + + Position.Node := Position.Node.Next; + + if Position.Node = null then + Position.Container := null; + end if; + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + end if; + + declare + Next_Node : constant Node_Access := Position.Node.Next; + begin + if Next_Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Next_Node); + end; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + if Position.Node = null then + return; + end if; + + Position.Node := Position.Node.Prev; + + if Position.Node = null then + Position.Container := null; + end if; + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + end if; + + declare + Prev_Node : constant Node_Access := Position.Node.Prev; + begin + if Prev_Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Prev_Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : in Element_Type)) + is + begin + Process (Position.Node.Element); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out List) + is + N : Count_Type'Base; + X : Node_Access; + + begin + Clear (Item); -- ??? + Count_Type'Base'Read (Stream, N); + + if N = 0 then + return; + end if; + + X := new Node_Type; + + begin + Element_Type'Read (Stream, X.Element); + exception + when others => + Free (X); + raise; + end; + + Item.First := X; + Item.Last := X; + + loop + Item.Length := Item.Length + 1; + exit when Item.Length = N; + + X := new Node_Type; + + begin + Element_Type'Read (Stream, X.Element); + exception + when others => + Free (X); + raise; + end; + + X.Prev := Item.Last; + Item.Last.Next := X; + Item.Last := X; + end loop; + end Read; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Position : Cursor; + By : Element_Type) + is + begin + Position.Node.Element := By; + end Replace_Element; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.Last; + elsif Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + while Node /= null loop + if Node.Element = Item then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := Node.Prev; + end loop; + + return No_Element; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + Node : Node_Access := Container.Last; + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Prev; + end loop; + end Reverse_Iterate; + + ------------------ + -- Reverse_List -- + ------------------ + + procedure Reverse_List (Container : in out List) is + I : Node_Access := Container.First; + J : Node_Access := Container.Last; + + procedure Swap (L, R : Node_Access); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L, R : Node_Access) is + LN : constant Node_Access := L.Next; + LP : constant Node_Access := L.Prev; + + RN : constant Node_Access := R.Next; + RP : constant Node_Access := R.Prev; + + begin + if LP /= null then + LP.Next := R; + end if; + + if RN /= null then + RN.Prev := L; + end if; + + L.Next := RN; + R.Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + L.Prev := R; + R.Next := L; + + else + L.Prev := RP; + RP.Next := L; + + R.Next := LN; + LN.Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_List + + begin + if Container.Length <= 1 then + return; + end if; + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := J.Next; + exit when I = J; + + I := I.Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := I.Next; + exit when I = J; + + J := J.Prev; + exit when I = J; + end loop; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Reverse_List; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Before.Container /= null + and then Before.Container /= List_Access'(Target'Unchecked_Access) + then + raise Program_Error; + end if; + + if Target'Address = Source'Address + or else Source.Length = 0 + then + return; + end if; + + if Target.Length = 0 then + pragma Assert (Before = No_Element); + + Target.First := Source.First; + Target.Last := Source.Last; + + elsif Before.Node = null then + pragma Assert (Target.Last.Next = null); + + Target.Last.Next := Source.First; + Source.First.Prev := Target.Last; + + Target.Last := Source.Last; + + elsif Before.Node = Target.First then + pragma Assert (Target.First.Prev = null); + + Source.Last.Next := Target.First; + Target.First.Prev := Source.Last; + + Target.First := Source.First; + + else + Before.Node.Prev.Next := Source.First; + Source.First.Prev := Before.Node.Prev; + + Before.Node.Prev := Source.Last; + Source.Last.Next := Before.Node; + end if; + + Source.First := null; + Source.Last := null; + + Target.Length := Target.Length + Source.Length; + Source.Length := 0; + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Position : Cursor) + is + X : Node_Access := Position.Node; + + begin + if Before.Container /= null + and then Before.Container /= List_Access'(Target'Unchecked_Access) + then + raise Program_Error; + end if; + + if Position.Container /= null + and then Position.Container /= List_Access'(Target'Unchecked_Access) + then + raise Program_Error; + end if; + + if X = null + or else X = Before.Node + or else X.Next = Before.Node + then + return; + end if; + + pragma Assert (Target.Length > 0); + + if Before.Node = null then + pragma Assert (X /= Target.Last); + + if X = Target.First then + Target.First := X.Next; + Target.First.Prev := null; + else + X.Prev.Next := X.Next; + X.Next.Prev := X.Prev; + end if; + + Target.Last.Next := X; + X.Prev := Target.Last; + + Target.Last := X; + Target.Last.Next := null; + + return; + end if; + + if Before.Node = Target.First then + pragma Assert (X /= Target.First); + + if X = Target.Last then + Target.Last := X.Prev; + Target.Last.Next := null; + else + X.Prev.Next := X.Next; + X.Next.Prev := X.Prev; + end if; + + Target.First.Prev := X; + X.Next := Target.First; + + Target.First := X; + Target.First.Prev := null; + + return; + end if; + + if X = Target.First then + Target.First := X.Next; + Target.First.Prev := null; + + elsif X = Target.Last then + Target.Last := X.Prev; + Target.Last.Next := null; + + else + X.Prev.Next := X.Next; + X.Next.Prev := X.Prev; + end if; + + Before.Node.Prev.Next := X; + X.Prev := Before.Node.Prev; + + Before.Node.Prev := X; + X.Next := Before.Node; + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : Cursor) + is + X : Node_Access := Position.Node; + + begin + if Target'Address = Source'Address then + Splice (Target, Before, Position); + return; + end if; + + if Before.Container /= null + and then Before.Container /= List_Access'(Target'Unchecked_Access) + then + raise Program_Error; + end if; + + if Position.Container /= null + and then Position.Container /= List_Access'(Source'Unchecked_Access) + then + raise Program_Error; + end if; + + if X = null then + return; + end if; + + pragma Assert (Source.Length > 0); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last.Next = null); + + if X = Source.First then + Source.First := X.Next; + Source.First.Prev := null; + + if X = Source.Last then + pragma Assert (Source.First = null); + pragma Assert (Source.Length = 1); + Source.Last := null; + end if; + + elsif X = Source.Last then + Source.Last := X.Prev; + Source.Last.Next := null; + + else + X.Prev.Next := X.Next; + X.Next.Prev := X.Prev; + end if; + + if Target.Length = 0 then + pragma Assert (Before = No_Element); + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + + Target.First := X; + Target.Last := X; + + elsif Before.Node = null then + Target.Last.Next := X; + X.Next := Target.Last; + + Target.Last := X; + Target.Last.Next := null; + + elsif Before.Node = Target.First then + Target.First.Prev := X; + X.Next := Target.First; + + Target.First := X; + Target.First.Prev := null; + + else + Before.Node.Prev.Next := X; + X.Prev := Before.Node.Prev; + + Before.Node.Prev := X; + X.Next := Before.Node; + end if; + + Target.Length := Target.Length + 1; + Source.Length := Source.Length - 1; + end Splice; + + ---------- + -- Swap -- + ---------- + + -- Is this defined when I and J designate elements in different containers, + -- or should it raise an exception (Program_Error)??? + + procedure Swap (I, J : in Cursor) is + EI : constant Element_Type := I.Node.Element; + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + is + begin + if I = No_Element + or else J = No_Element + then + raise Constraint_Error; + end if; + + if I.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + if J.Container /= I.Container then + raise Program_Error; + end if; + + pragma Assert (Container.Length >= 1); + + if I.Node = J.Node then + return; + end if; + + pragma Assert (Container.Length >= 2); + + declare + I_Next : constant Cursor := Next (I); + + begin + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + declare + J_Next : constant Cursor := Next (J); + + begin + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end; + end if; + end; + end Swap_Links; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) is + begin + Process (Position.Node.Element); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : List) + is + Node : Node_Access := Item.First; + + begin + Count_Type'Base'Write (Stream, Item.Length); + + while Node /= null loop + Element_Type'Write (Stream, Node.Element); + Node := Node.Next; + end loop; + end Write; + +end Ada.Containers.Doubly_Linked_Lists; + diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads new file mode 100644 index 00000000000..f87479cabe6 --- /dev/null +++ b/gcc/ada/a-cdlili.ads @@ -0,0 +1,252 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with Ada.Streams; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Doubly_Linked_Lists is + pragma Preelaborate (Doubly_Linked_Lists); + + type List is tagged private; + + type Cursor is private; + + Empty_List : constant List; + + No_Element : constant Cursor; + + function "=" (Left, Right : List) return Boolean; + + function Length (Container : List) return Count_Type; + + function Is_Empty (Container : List) return Boolean; + + procedure Clear (Container : in out List); + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Replace_Element + (Position : Cursor; + By : Element_Type); + + procedure Move + (Target : in out List; + Source : in out List); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + + generic + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + procedure Generic_Sort (Container : in out List); + + generic + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + procedure Generic_Merge (Target : in out List; Source : in out List); + + procedure Reverse_List (Container : in out List); + + procedure Swap (I, J : in Cursor); + + procedure Swap_Links + (Container : in out List; + I, J : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List); + + procedure Splice + (Target : in out List; + Before : Cursor; + Position : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : Cursor); + + function First (Container : List) return Cursor; + + function First_Element (Container : List) return Element_Type; + + function Last (Container : List) return Cursor; + + function Last_Element (Container : List) return Element_Type; + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + +private + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is + record + Element : Element_Type; + Next : Node_Access; + Prev : Node_Access; + end record; + + function "=" (L, R : Node_Type) return Boolean is abstract; + + use Ada.Finalization; + + type List is + new Controlled with record + First : Node_Access; + Last : Node_Access; + Length : Count_Type := 0; + end record; + + procedure Adjust (Container : in out List); + + procedure Finalize (Container : in out List) renames Clear; + + use Ada.Streams; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out List); + + for List'Read use Read; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : List); + + for List'Write use Write; + + Empty_List : constant List := List'(Controlled with null, null, 0); + + type List_Access is access constant List; + for List_Access'Storage_Size use 0; + + type Cursor is + record + Container : List_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := Cursor'(null, null); + +end Ada.Containers.Doubly_Linked_Lists; + diff --git a/gcc/ada/a-cgaaso.adb b/gcc/ada/a-cgaaso.adb new file mode 100644 index 00000000000..1fc24fcf672 --- /dev/null +++ b/gcc/ada/a-cgaaso.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +procedure Ada.Containers.Generic_Anonymous_Array_Sort + (First, Last : Index_Type'Base) +is + Pivot, Lo, Mid, Hi : Index_Type; + +begin + if Last <= First then + return; + end if; + + Lo := First; + Hi := Last; + + if Last = Index_Type'Succ (First) then + if not Less (Lo, Hi) then + Swap (Lo, Hi); + end if; + + return; + end if; + + Mid := Index_Type'Val + (Index_Type'Pos (Lo) + + (Index_Type'Pos (Hi) - Index_Type'Pos (Lo)) / 2); + + -- We need to figure out which case we have: + -- x < y < z + -- x < z < y + -- z < x < y + -- y < x < z + -- y < z < x + -- z < y < x + + if Less (Lo, Mid) then + if Less (Lo, Hi) then + if Less (Mid, Hi) then + Swap (Lo, Mid); + + else + Swap (Lo, Hi); + + end if; + + else + null; -- lo is median + end if; + + elsif Less (Lo, Hi) then + null; -- lo is median + + elsif Less (Mid, Hi) then + Swap (Lo, Hi); + + else + Swap (Lo, Mid); + end if; + + Pivot := Lo; + Outer : loop + loop + exit Outer when not (Pivot < Hi); + + if Less (Hi, Pivot) then + Swap (Hi, Pivot); + Pivot := Hi; + Lo := Index_Type'Succ (Lo); + exit; + else + Hi := Index_Type'Pred (Hi); + end if; + end loop; + + loop + exit Outer when not (Lo < Pivot); + + if Less (Lo, Pivot) then + Lo := Index_Type'Succ (Lo); + else + Swap (Lo, Pivot); + Pivot := Lo; + Hi := Index_Type'Pred (Hi); + exit; + end if; + end loop; + end loop Outer; + + Generic_Anonymous_Array_Sort (First, Index_Type'Pred (Pivot)); + Generic_Anonymous_Array_Sort (Index_Type'Succ (Pivot), Last); + +end Ada.Containers.Generic_Anonymous_Array_Sort; diff --git a/gcc/ada/a-cgaaso.ads b/gcc/ada/a-cgaaso.ads new file mode 100644 index 00000000000..fddc1d4ade1 --- /dev/null +++ b/gcc/ada/a-cgaaso.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +generic + type Index_Type is (<>); + with function Less (Left, Right : Index_Type) return Boolean is <>; + with procedure Swap (Left, Right : Index_Type) is <>; + +procedure Ada.Containers.Generic_Anonymous_Array_Sort + (First, Last : in Index_Type'Base); + +pragma Pure (Ada.Containers.Generic_Anonymous_Array_Sort); diff --git a/gcc/ada/a-cgarso.adb b/gcc/ada/a-cgarso.adb new file mode 100644 index 00000000000..5594caaabe6 --- /dev/null +++ b/gcc/ada/a-cgarso.adb @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_ARRAY_SORT -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Constrained_Array_Sort; + +procedure Ada.Containers.Generic_Array_Sort + (Container : in out Array_Type) +is + subtype Index_Subtype is + Index_Type range Container'First .. Container'Last; + + subtype Array_Subtype is + Array_Type (Index_Subtype); + + procedure Sort is + new Generic_Constrained_Array_Sort + (Index_Type => Index_Subtype, + Element_Type => Element_Type, + Array_Type => Array_Subtype, + "<" => "<"); + +begin + Sort (Container); +end Ada.Containers.Generic_Array_Sort; diff --git a/gcc/ada/a-cgarso.ads b/gcc/ada/a-cgarso.ads new file mode 100644 index 00000000000..a22cde76bb2 --- /dev/null +++ b/gcc/ada/a-cgarso.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_ARRAY_SORT -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Index_Type is (<>); + type Element_Type is private; + type Array_Type is array (Index_Type range <>) of Element_Type; + + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + +procedure Ada.Containers.Generic_Array_Sort (Container : in out Array_Type); + +pragma Pure (Ada.Containers.Generic_Array_Sort); + + diff --git a/gcc/ada/a-cgcaso.adb b/gcc/ada/a-cgcaso.adb new file mode 100644 index 00000000000..7f640836775 --- /dev/null +++ b/gcc/ada/a-cgcaso.adb @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit has originally being developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +procedure Ada.Containers.Generic_Constrained_Array_Sort + (Container : in out Array_Type) +is + function Is_Less (I, J : Index_Type) return Boolean; + pragma Inline (Is_Less); + + procedure Swap (I, J : Index_Type); + pragma Inline (Swap); + + procedure Sort (First, Last : Index_Type'Base); + + ------------- + -- Is_Less -- + ------------- + + function Is_Less (I, J : Index_Type) return Boolean is + begin + return Container (I) < Container (J); + end Is_Less; + + ---------- + -- Sort -- + ---------- + + procedure Sort (First, Last : Index_Type'Base) is + Pivot, Lo, Mid, Hi : Index_Type; + + begin + if Last <= First then + return; + end if; + + Lo := First; + Hi := Last; + + if Last = Index_Type'Succ (First) then + if not Is_Less (Lo, Hi) then + Swap (Lo, Hi); + end if; + + return; + end if; + + Mid := Index_Type'Val + (Index_Type'Pos (Lo) + + (Index_Type'Pos (Hi) - Index_Type'Pos (Lo)) / 2); + + -- We need to figure out which case we have: + -- x < y < z + -- x < z < y + -- z < x < y + -- y < x < z + -- y < z < x + -- z < y < x + + if Is_Less (Lo, Mid) then + if Is_Less (Lo, Hi) then + if Is_Less (Mid, Hi) then + Swap (Lo, Mid); + else + Swap (Lo, Hi); + end if; + + else + null; -- lo is median + end if; + + elsif Is_Less (Lo, Hi) then + null; -- lo is median + + elsif Is_Less (Mid, Hi) then + Swap (Lo, Hi); + + else + Swap (Lo, Mid); + end if; + + Pivot := Lo; + + Outer : loop + loop + exit Outer when not (Pivot < Hi); + + if Is_Less (Hi, Pivot) then + Swap (Hi, Pivot); + Pivot := Hi; + Lo := Index_Type'Succ (Lo); + exit; + else + Hi := Index_Type'Pred (Hi); + end if; + end loop; + + loop + exit Outer when not (Lo < Pivot); + + if Is_Less (Lo, Pivot) then + Lo := Index_Type'Succ (Lo); + else + Swap (Lo, Pivot); + Pivot := Lo; + Hi := Index_Type'Pred (Hi); + exit; + end if; + end loop; + end loop Outer; + + Sort (First, Index_Type'Pred (Pivot)); + Sort (Index_Type'Succ (Pivot), Last); + end Sort; + + ---------- + -- Swap -- + ---------- + + procedure Swap (I, J : Index_Type) is + EI : constant Element_Type := Container (I); + begin + Container (I) := Container (J); + Container (J) := EI; + end Swap; + +-- Start of processing for Generic_Constrained_Array_Sort + +begin + Sort (Container'First, Container'Last); +end Ada.Containers.Generic_Constrained_Array_Sort; diff --git a/gcc/ada/a-cgcaso.ads b/gcc/ada/a-cgcaso.ads new file mode 100644 index 00000000000..b247e2be3b8 --- /dev/null +++ b/gcc/ada/a-cgcaso.ads @@ -0,0 +1,27 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Index_Type is (<>); + type Element_Type is private; + type Array_Type is array (Index_Type) of Element_Type; + + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + +procedure Ada.Containers.Generic_Constrained_Array_Sort + (Container : in out Array_Type); + +pragma Pure (Ada.Containers.Generic_Constrained_Array_Sort); diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb new file mode 100644 index 00000000000..9a21ad0c9eb --- /dev/null +++ b/gcc/ada/a-chtgke.adb @@ -0,0 +1,178 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Hash_Tables.Generic_Keys is + + -------------------------- + -- Delete_Key_Sans_Free -- + -------------------------- + + procedure Delete_Key_Sans_Free + (HT : in out HT_Type; + Key : Key_Type; + X : out Node_Access) + is + Indx : Hash_Type; + Prev : Node_Access; + + begin + if HT.Length = 0 then + X := Null_Node; + return; + end if; + + Indx := Index (HT, Key); + X := HT.Buckets (Indx); + + if X = Null_Node then + return; + end if; + + if Equivalent_Keys (Key, X) then + HT.Buckets (Indx) := Next (X); + HT.Length := HT.Length - 1; + return; + end if; + + loop + Prev := X; + X := Next (Prev); + + if X = Null_Node then + return; + end if; + + if Equivalent_Keys (Key, X) then + Set_Next (Node => Prev, Next => Next (X)); + HT.Length := HT.Length - 1; + return; + end if; + end loop; + end Delete_Key_Sans_Free; + + ---------- + -- Find -- + ---------- + + function Find + (HT : HT_Type; + Key : Key_Type) return Node_Access is + + Indx : Hash_Type; + Node : Node_Access; + + begin + if HT.Length = 0 then + return Null_Node; + end if; + + Indx := Index (HT, Key); + + Node := HT.Buckets (Indx); + while Node /= Null_Node loop + if Equivalent_Keys (Key, Node) then + return Node; + end if; + Node := Next (Node); + end loop; + + return Null_Node; + end Find; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (HT : in out HT_Type; + Key : Key_Type; + Node : out Node_Access; + Success : out Boolean) + is + Indx : constant Hash_Type := Index (HT, Key); + B : Node_Access renames HT.Buckets (Indx); + + subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1; + + begin + if B = Null_Node then + declare + Length : constant Length_Subtype := HT.Length; + begin + Node := New_Node (Next => Null_Node); + Success := True; + + B := Node; + HT.Length := Length + 1; + end; + + return; + end if; + + Node := B; + loop + if Equivalent_Keys (Key, Node) then + Success := False; + return; + end if; + + Node := Next (Node); + + exit when Node = Null_Node; + end loop; + + declare + Length : constant Length_Subtype := HT.Length; + begin + Node := New_Node (Next => B); + Success := True; + + B := Node; + HT.Length := Length + 1; + end; + end Generic_Conditional_Insert; + + ----------- + -- Index -- + ----------- + + function Index + (HT : HT_Type; + Key : Key_Type) return Hash_Type is + begin + return Hash (Key) mod HT.Buckets'Length; + end Index; + +end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgke.ads b/gcc/ada/a-chtgke.ads new file mode 100644 index 00000000000..704c653f730 --- /dev/null +++ b/gcc/ada/a-chtgke.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + with package HT_Types is + new Generic_Hash_Table_Types (<>); + + type HT_Type is new HT_Types.Hash_Table_Type with private; + + use HT_Types; + + Null_Node : Node_Access; + + with function Next (Node : Node_Access) return Node_Access; + + with procedure Set_Next + (Node : Node_Access; + Next : Node_Access); + + type Key_Type (<>) is limited private; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean; + +package Ada.Containers.Hash_Tables.Generic_Keys is + pragma Preelaborate; + + function Index + (HT : HT_Type; + Key : Key_Type) return Hash_Type; + pragma Inline (Index); + + procedure Delete_Key_Sans_Free + (HT : in out HT_Type; + Key : Key_Type; + X : out Node_Access); + + function Find (HT : HT_Type; Key : Key_Type) return Node_Access; + + generic + with function New_Node + (Next : Node_Access) return Node_Access; + procedure Generic_Conditional_Insert + (HT : in out HT_Type; + Key : Key_Type; + Node : out Node_Access; + Success : out Boolean); + +end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb new file mode 100644 index 00000000000..aa27f427c2e --- /dev/null +++ b/gcc/ada/a-chtgop.adb @@ -0,0 +1,701 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This body needs commenting ??? + +with Ada.Containers.Prime_Numbers; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Hash_Tables.Generic_Operations is + + procedure Free is + new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Access); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Rehash + (HT : in out Hash_Table_Type; + Size : Hash_Type); + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (HT : in out Hash_Table_Type) is + Src_Buckets : constant Buckets_Access := HT.Buckets; + N : constant Count_Type := HT.Length; + Src_Node : Node_Access; + Dst_Prev : Node_Access; + + begin + HT.Buckets := null; + HT.Length := 0; + + if N = 0 then + return; + end if; + + HT.Buckets := new Buckets_Type (Src_Buckets'Range); + + -- Probably we have to duplicate the Size (Src), too, in order + -- to guarantee that + + -- Dst := Src; + -- Dst = Src is true + + -- The only quirk is that we depend on the hash value of a dst key + -- to be the same as the src key from which it was copied. + -- If we relax the requirement that the hash value must be the + -- same, then of course we can't guarantee that following + -- assignment that Dst = Src is true ??? + + for Src_Index in Src_Buckets'Range loop + Src_Node := Src_Buckets (Src_Index); + + if Src_Node /= Null_Node then + declare + Dst_Node : constant Node_Access := Copy_Node (Src_Node); + + -- See note above + + pragma Assert (Index (HT, Dst_Node) = Src_Index); + + begin + HT.Buckets (Src_Index) := Dst_Node; + HT.Length := HT.Length + 1; + + Dst_Prev := Dst_Node; + end; + + Src_Node := Next (Src_Node); + while Src_Node /= Null_Node loop + declare + Dst_Node : constant Node_Access := Copy_Node (Src_Node); + + -- See note above + + pragma Assert (Index (HT, Dst_Node) = Src_Index); + + begin + Set_Next (Node => Dst_Prev, Next => Dst_Node); + HT.Length := HT.Length + 1; + + Dst_Prev := Dst_Node; + end; + + Src_Node := Next (Src_Node); + end loop; + end if; + end loop; + + pragma Assert (HT.Length = N); + end Adjust; + + -------------- + -- Capacity -- + -------------- + + function Capacity (HT : Hash_Table_Type) return Count_Type is + begin + if HT.Buckets = null then + return 0; + end if; + + return HT.Buckets'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (HT : in out Hash_Table_Type) is + Index : Hash_Type := 0; + Node : Node_Access; + + begin + while HT.Length > 0 loop + while HT.Buckets (Index) = Null_Node loop + Index := Index + 1; + end loop; + + declare + Bucket : Node_Access renames HT.Buckets (Index); + begin + loop + Node := Bucket; + Bucket := Next (Bucket); + HT.Length := HT.Length - 1; + Free (Node); + exit when Bucket = Null_Node; + end loop; + end; + end loop; + end Clear; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type; + X : Node_Access) + is + pragma Assert (X /= Null_Node); + + Indx : Hash_Type; + Prev : Node_Access; + Curr : Node_Access; + + begin + if HT.Length = 0 then + raise Program_Error; + end if; + + Indx := Index (HT, X); + Prev := HT.Buckets (Indx); + + if Prev = Null_Node then + raise Program_Error; + end if; + + if Prev = X then + HT.Buckets (Indx) := Next (Prev); + HT.Length := HT.Length - 1; + return; + end if; + + if HT.Length = 1 then + raise Program_Error; + end if; + + loop + Curr := Next (Prev); + + if Curr = Null_Node then + raise Program_Error; + end if; + + if Curr = X then + Set_Next (Node => Prev, Next => Next (Curr)); + HT.Length := HT.Length - 1; + return; + end if; + + Prev := Curr; + end loop; + end Delete_Node_Sans_Free; + + --------------------- + -- Ensure_Capacity -- + --------------------- + + procedure Ensure_Capacity + (HT : in out Hash_Table_Type; + N : Count_Type) + is + NN : Hash_Type; + + begin + if N = 0 then + if HT.Length = 0 then + Free (HT.Buckets); + + elsif HT.Length < HT.Buckets'Length then + NN := Prime_Numbers.To_Prime (HT.Length); + + -- ASSERT: NN >= HT.Length + + if NN < HT.Buckets'Length then + Rehash (HT, Size => NN); + end if; + end if; + + return; + end if; + + if HT.Buckets = null then + NN := Prime_Numbers.To_Prime (N); + + -- ASSERT: NN >= N + + Rehash (HT, Size => NN); + return; + end if; + + if N <= HT.Length then + if HT.Length >= HT.Buckets'Length then + return; + end if; + + NN := Prime_Numbers.To_Prime (HT.Length); + + -- ASSERT: NN >= HT.Length + + if NN < HT.Buckets'Length then + Rehash (HT, Size => NN); + end if; + + return; + end if; + + -- ASSERT: N > HT.Length + + if N = HT.Buckets'Length then + return; + end if; + + NN := Prime_Numbers.To_Prime (N); + + -- ASSERT: NN >= N + -- ASSERT: NN > HT.Length + + if NN /= HT.Buckets'Length then + Rehash (HT, Size => NN); + end if; + end Ensure_Capacity; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (HT : in out Hash_Table_Type) is + begin + Clear (HT); + Free (HT.Buckets); + end Finalize; + + ----------- + -- First -- + ----------- + + function First (HT : Hash_Table_Type) return Node_Access is + Indx : Hash_Type; + + begin + if HT.Length = 0 then + return Null_Node; + end if; + + Indx := HT.Buckets'First; + loop + if HT.Buckets (Indx) /= Null_Node then + return HT.Buckets (Indx); + end if; + + Indx := Indx + 1; + end loop; + end First; + + --------------------- + -- Free_Hash_Table -- + --------------------- + + procedure Free_Hash_Table (Buckets : in out Buckets_Access) is + Node : Node_Access; + + begin + if Buckets = null then + return; + end if; + + for J in Buckets'Range loop + while Buckets (J) /= Null_Node loop + Node := Buckets (J); + Buckets (J) := Next (Node); + Free (Node); + end loop; + end loop; + + Free (Buckets); + end Free_Hash_Table; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal + (L, R : Hash_Table_Type) return Boolean is + + L_Index : Hash_Type; + L_Node : Node_Access; + + N : Count_Type; + + begin + if L'Address = R'Address then + return True; + end if; + + if L.Length /= R.Length then + return False; + end if; + + if L.Length = 0 then + return True; + end if; + + L_Index := 0; + + loop + L_Node := L.Buckets (L_Index); + exit when L_Node /= Null_Node; + L_Index := L_Index + 1; + end loop; + + N := L.Length; + + loop + if not Find (HT => R, Key => L_Node) then + return False; + end if; + + N := N - 1; + + L_Node := Next (L_Node); + + if L_Node = Null_Node then + if N = 0 then + return True; + end if; + + loop + L_Index := L_Index + 1; + L_Node := L.Buckets (L_Index); + exit when L_Node /= Null_Node; + end loop; + end if; + end loop; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (HT : Hash_Table_Type) is + Node : Node_Access; + + begin + if HT.Buckets = null + or else HT.Length = 0 + then + return; + end if; + + for Indx in HT.Buckets'Range loop + Node := HT.Buckets (Indx); + while Node /= Null_Node loop + Process (Node); + Node := Next (Node); + end loop; + end loop; + end Generic_Iteration; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : access Root_Stream_Type'Class; + HT : out Hash_Table_Type) + is + X, Y : Node_Access; + + Last, I : Hash_Type; + N, M : Count_Type'Base; + + begin + -- As with the sorted set, it's not clear whether read is allowed to + -- have side effect if it fails. For now, we assume side effects are + -- allowed since it simplifies the algorithm ??? + -- + Clear (HT); + + declare + B : Buckets_Access := HT.Buckets; + begin + HT.Buckets := null; + HT.Length := 0; + Free (B); -- can this fail??? + end; + + Hash_Type'Read (Stream, Last); + + if Last /= 0 then + HT.Buckets := new Buckets_Type (0 .. Last); + end if; + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + while N > 0 loop + Hash_Type'Read (Stream, I); + pragma Assert (I in HT.Buckets'Range); + pragma Assert (HT.Buckets (I) = Null_Node); + + Count_Type'Base'Read (Stream, M); + pragma Assert (M >= 1); + pragma Assert (M <= N); + + HT.Buckets (I) := New_Node (Stream); + pragma Assert (HT.Buckets (I) /= Null_Node); + pragma Assert (Next (HT.Buckets (I)) = Null_Node); + + Y := HT.Buckets (I); + + HT.Length := HT.Length + 1; + + for J in Count_Type range 2 .. M loop + X := New_Node (Stream); + pragma Assert (X /= Null_Node); + pragma Assert (Next (X) = Null_Node); + + Set_Next (Node => Y, Next => X); + Y := X; + + HT.Length := HT.Length + 1; + end loop; + + N := N - M; + end loop; + end Generic_Read; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : access Root_Stream_Type'Class; + HT : Hash_Table_Type) + is + M : Count_Type'Base; + X : Node_Access; + + begin + if HT.Buckets = null then + Hash_Type'Write (Stream, 0); + else + Hash_Type'Write (Stream, HT.Buckets'Last); + end if; + + Count_Type'Base'Write (Stream, HT.Length); + + if HT.Length = 0 then + return; + end if; + + for Indx in HT.Buckets'Range loop + X := HT.Buckets (Indx); + + if X /= Null_Node then + M := 1; + loop + X := Next (X); + exit when X = Null_Node; + M := M + 1; + end loop; + + Hash_Type'Write (Stream, Indx); + Count_Type'Base'Write (Stream, M); + + X := HT.Buckets (Indx); + for J in Count_Type range 1 .. M loop + Write (Stream, X); + X := Next (X); + end loop; + + pragma Assert (X = Null_Node); + end if; + end loop; + end Generic_Write; + + ----------- + -- Index -- + ----------- + + function Index + (Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type is + begin + return Hash_Node (Node) mod Buckets'Length; + end Index; + + function Index + (Hash_Table : Hash_Table_Type; + Node : Node_Access) return Hash_Type is + begin + return Index (Hash_Table.Buckets.all, Node); + end Index; + + ---------- + -- Move -- + ---------- + + procedure Move (Target, Source : in out Hash_Table_Type) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Length > 0 then + raise Constraint_Error; + end if; + + Free (Target.Buckets); + + Target.Buckets := Source.Buckets; + Source.Buckets := null; + + Target.Length := Source.Length; + Source.Length := 0; + end Move; + + ---------- + -- Next -- + ---------- + + function Next + (HT : Hash_Table_Type; + Node : Node_Access) return Node_Access + is + Result : Node_Access := Next (Node); + + begin + if Result /= Null_Node then + return Result; + end if; + + for Indx in Index (HT, Node) + 1 .. HT.Buckets'Last loop + Result := HT.Buckets (Indx); + + if Result /= Null_Node then + return Result; + end if; + end loop; + + return Null_Node; + end Next; + + ------------ + -- Rehash -- + ------------ + + procedure Rehash + (HT : in out Hash_Table_Type; + Size : Hash_Type) + is + subtype Buckets_Range is Hash_Type range 0 .. Size - 1; + + Dst_Buckets : Buckets_Access := new Buckets_Type (Buckets_Range); + Src_Buckets : Buckets_Access := HT.Buckets; + + L : Count_Type renames HT.Length; + LL : constant Count_Type := L; + + begin + if Src_Buckets = null then + pragma Assert (L = 0); + HT.Buckets := Dst_Buckets; + return; + end if; + + if L = 0 then + HT.Buckets := Dst_Buckets; + Free (Src_Buckets); + return; + end if; + + -- We might want to change this to iter from 1 .. L instead ??? + + for Src_Index in Src_Buckets'Range loop + + declare + Src_Bucket : Node_Access renames Src_Buckets (Src_Index); + begin + while Src_Bucket /= Null_Node loop + declare + Src_Node : constant Node_Access := Src_Bucket; + Dst_Index : constant Hash_Type := + Index (Dst_Buckets.all, Src_Node); + Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index); + begin + Src_Bucket := Next (Src_Node); + Set_Next (Src_Node, Dst_Bucket); + Dst_Bucket := Src_Node; + end; + + pragma Assert (L > 0); + L := L - 1; + + end loop; + + exception + when others => + + -- Not clear that we can deallocate the nodes, + -- because they may be designated by outstanding + -- iterators. Which means they're now lost... ??? + + -- for J in NB'Range loop + -- declare + -- Dst : Node_Access renames NB (J); + -- X : Node_Access; + -- begin + -- while Dst /= Null_Node loop + -- X := Dst; + -- Dst := Succ (Dst); + -- Free (X); + -- end loop; + -- end; + -- end loop; + + + Free (Dst_Buckets); + raise; + end; + + -- exit when L = 0; + -- need to bother??? + + end loop; + + pragma Assert (L = 0); + + HT.Buckets := Dst_Buckets; + HT.Length := LL; + + Free (Src_Buckets); + end Rehash; + +end Ada.Containers.Hash_Tables.Generic_Operations; + diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads new file mode 100644 index 00000000000..232c719b04c --- /dev/null +++ b/gcc/ada/a-chtgop.ads @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; + +generic + + with package HT_Types is + new Generic_Hash_Table_Types (<>); + + type Hash_Table_Type is new HT_Types.Hash_Table_Type with private; + + use HT_Types; + + Null_Node : in Node_Access; + + with function Hash_Node (Node : Node_Access) return Hash_Type; + + with function Next (Node : Node_Access) return Node_Access; + + with procedure Set_Next + (Node : Node_Access; + Next : Node_Access); + + with function Copy_Node (Source : Node_Access) return Node_Access; + + with procedure Free (X : in out Node_Access); + +package Ada.Containers.Hash_Tables.Generic_Operations is + pragma Preelaborate; + + procedure Free_Hash_Table (Buckets : in out Buckets_Access); + + function Index + (Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type; + pragma Inline (Index); + + function Index + (Hash_Table : Hash_Table_Type; + Node : Node_Access) return Hash_Type; + pragma Inline (Index); + + procedure Adjust (HT : in out Hash_Table_Type); + + procedure Finalize (HT : in out Hash_Table_Type); + + generic + with function Find + (HT : Hash_Table_Type; + Key : Node_Access) return Boolean; + function Generic_Equal + (L, R : Hash_Table_Type) return Boolean; + + procedure Clear (HT : in out Hash_Table_Type); + + procedure Move (Target, Source : in out Hash_Table_Type); + + function Capacity (HT : Hash_Table_Type) return Count_Type; + + procedure Ensure_Capacity + (HT : in out Hash_Table_Type; + N : Count_Type); + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type; + X : Node_Access); + + function First (HT : Hash_Table_Type) return Node_Access; + + function Next + (HT : Hash_Table_Type; + Node : Node_Access) return Node_Access; + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Iteration (HT : Hash_Table_Type); + + generic + use Ada.Streams; + with procedure Write + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + procedure Generic_Write + (Stream : access Root_Stream_Type'Class; + HT : Hash_Table_Type); + + generic + use Ada.Streams; + with function New_Node (Stream : access Root_Stream_Type'Class) + return Node_Access; + procedure Generic_Read + (Stream : access Root_Stream_Type'Class; + HT : out Hash_Table_Type); + +end Ada.Containers.Hash_Tables.Generic_Operations; + diff --git a/gcc/ada/a-chzla1.ads b/gcc/ada/a-chzla1.ads new file mode 100644 index 00000000000..230a8156d03 --- /dev/null +++ b/gcc/ada/a-chzla1.ads @@ -0,0 +1,378 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . W I D E _ W I D E _ L A T I N _ 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides definitions analogous to those in the RM defined +-- package Ada.Characters.Latin_1 except that the type of the constants +-- is Wide_Wide_Character instead of Character. The provision of this package +-- is in accordance with the implementation permission in RM (A.3.3(27)). + +package Ada.Characters.Wide_Wide_Latin_1 is +pragma Pure (Wide_Wide_Latin_1); + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Wide_Wide_Character := Wide_Wide_Character'Val (0); + SOH : constant Wide_Wide_Character := Wide_Wide_Character'Val (1); + STX : constant Wide_Wide_Character := Wide_Wide_Character'Val (2); + ETX : constant Wide_Wide_Character := Wide_Wide_Character'Val (3); + EOT : constant Wide_Wide_Character := Wide_Wide_Character'Val (4); + ENQ : constant Wide_Wide_Character := Wide_Wide_Character'Val (5); + ACK : constant Wide_Wide_Character := Wide_Wide_Character'Val (6); + BEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (7); + BS : constant Wide_Wide_Character := Wide_Wide_Character'Val (8); + HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (9); + LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (10); + VT : constant Wide_Wide_Character := Wide_Wide_Character'Val (11); + FF : constant Wide_Wide_Character := Wide_Wide_Character'Val (12); + CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (13); + SO : constant Wide_Wide_Character := Wide_Wide_Character'Val (14); + SI : constant Wide_Wide_Character := Wide_Wide_Character'Val (15); + + DLE : constant Wide_Wide_Character := Wide_Wide_Character'Val (16); + DC1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (17); + DC2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (18); + DC3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (19); + DC4 : constant Wide_Wide_Character := Wide_Wide_Character'Val (20); + NAK : constant Wide_Wide_Character := Wide_Wide_Character'Val (21); + SYN : constant Wide_Wide_Character := Wide_Wide_Character'Val (22); + ETB : constant Wide_Wide_Character := Wide_Wide_Character'Val (23); + CAN : constant Wide_Wide_Character := Wide_Wide_Character'Val (24); + EM : constant Wide_Wide_Character := Wide_Wide_Character'Val (25); + SUB : constant Wide_Wide_Character := Wide_Wide_Character'Val (26); + ESC : constant Wide_Wide_Character := Wide_Wide_Character'Val (27); + FS : constant Wide_Wide_Character := Wide_Wide_Character'Val (28); + GS : constant Wide_Wide_Character := Wide_Wide_Character'Val (29); + RS : constant Wide_Wide_Character := Wide_Wide_Character'Val (30); + US : constant Wide_Wide_Character := Wide_Wide_Character'Val (31); + + ------------------------------------- + -- ISO 646 Graphic Wide_Wide_Characters -- + ------------------------------------- + + Space : constant Wide_Wide_Character := ' '; -- WC'Val(32) + Exclamation : constant Wide_Wide_Character := '!'; -- WC'Val(33) + Quotation : constant Wide_Wide_Character := '"'; -- WC'Val(34) + Number_Sign : constant Wide_Wide_Character := '#'; -- WC'Val(35) + Dollar_Sign : constant Wide_Wide_Character := '$'; -- WC'Val(36) + Percent_Sign : constant Wide_Wide_Character := '%'; -- WC'Val(37) + Ampersand : constant Wide_Wide_Character := '&'; -- WC'Val(38) + Apostrophe : constant Wide_Wide_Character := '''; -- WC'Val(39) + Left_Parenthesis : constant Wide_Wide_Character := '('; -- WC'Val(40) + Right_Parenthesis : constant Wide_Wide_Character := ')'; -- WC'Val(41) + Asterisk : constant Wide_Wide_Character := '*'; -- WC'Val(42) + Plus_Sign : constant Wide_Wide_Character := '+'; -- WC'Val(43) + Comma : constant Wide_Wide_Character := ','; -- WC'Val(44) + Hyphen : constant Wide_Wide_Character := '-'; -- WC'Val(45) + Minus_Sign : Wide_Wide_Character renames Hyphen; + Full_Stop : constant Wide_Wide_Character := '.'; -- WC'Val(46) + Solidus : constant Wide_Wide_Character := '/'; -- WC'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Wide_Wide_Character := ':'; -- WC'Val(58) + Semicolon : constant Wide_Wide_Character := ';'; -- WC'Val(59) + Less_Than_Sign : constant Wide_Wide_Character := '<'; -- WC'Val(60) + Equals_Sign : constant Wide_Wide_Character := '='; -- WC'Val(61) + Greater_Than_Sign : constant Wide_Wide_Character := '>'; -- WC'Val(62) + Question : constant Wide_Wide_Character := '?'; -- WC'Val(63) + + Commercial_At : constant Wide_Wide_Character := '@'; -- WC'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Wide_Wide_Character := '['; -- WC'Val (91) + Reverse_Solidus : constant Wide_Wide_Character := '\'; -- WC'Val (92) + Right_Square_Bracket : constant Wide_Wide_Character := ']'; -- WC'Val (93) + Circumflex : constant Wide_Wide_Character := '^'; -- WC'Val (94) + Low_Line : constant Wide_Wide_Character := '_'; -- WC'Val (95) + + Grave : constant Wide_Wide_Character := '`'; -- WC'Val (96) + LC_A : constant Wide_Wide_Character := 'a'; -- WC'Val (97) + LC_B : constant Wide_Wide_Character := 'b'; -- WC'Val (98) + LC_C : constant Wide_Wide_Character := 'c'; -- WC'Val (99) + LC_D : constant Wide_Wide_Character := 'd'; -- WC'Val (100) + LC_E : constant Wide_Wide_Character := 'e'; -- WC'Val (101) + LC_F : constant Wide_Wide_Character := 'f'; -- WC'Val (102) + LC_G : constant Wide_Wide_Character := 'g'; -- WC'Val (103) + LC_H : constant Wide_Wide_Character := 'h'; -- WC'Val (104) + LC_I : constant Wide_Wide_Character := 'i'; -- WC'Val (105) + LC_J : constant Wide_Wide_Character := 'j'; -- WC'Val (106) + LC_K : constant Wide_Wide_Character := 'k'; -- WC'Val (107) + LC_L : constant Wide_Wide_Character := 'l'; -- WC'Val (108) + LC_M : constant Wide_Wide_Character := 'm'; -- WC'Val (109) + LC_N : constant Wide_Wide_Character := 'n'; -- WC'Val (110) + LC_O : constant Wide_Wide_Character := 'o'; -- WC'Val (111) + LC_P : constant Wide_Wide_Character := 'p'; -- WC'Val (112) + LC_Q : constant Wide_Wide_Character := 'q'; -- WC'Val (113) + LC_R : constant Wide_Wide_Character := 'r'; -- WC'Val (114) + LC_S : constant Wide_Wide_Character := 's'; -- WC'Val (115) + LC_T : constant Wide_Wide_Character := 't'; -- WC'Val (116) + LC_U : constant Wide_Wide_Character := 'u'; -- WC'Val (117) + LC_V : constant Wide_Wide_Character := 'v'; -- WC'Val (118) + LC_W : constant Wide_Wide_Character := 'w'; -- WC'Val (119) + LC_X : constant Wide_Wide_Character := 'x'; -- WC'Val (120) + LC_Y : constant Wide_Wide_Character := 'y'; -- WC'Val (121) + LC_Z : constant Wide_Wide_Character := 'z'; -- WC'Val (122) + Left_Curly_Bracket : constant Wide_Wide_Character := '{'; -- WC'Val (123) + Vertical_Line : constant Wide_Wide_Character := '|'; -- WC'Val (124) + Right_Curly_Bracket : constant Wide_Wide_Character := '}'; -- WC'Val (125) + Tilde : constant Wide_Wide_Character := '~'; -- WC'Val (126) + DEL : constant Wide_Wide_Character := + Wide_Wide_Character'Val (127); + + -------------------------------------- + -- ISO 6429 Control Wide_Wide_Characters -- + -------------------------------------- + + IS4 : Wide_Wide_Character renames FS; + IS3 : Wide_Wide_Character renames GS; + IS2 : Wide_Wide_Character renames RS; + IS1 : Wide_Wide_Character renames US; + + Reserved_128 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (128); + Reserved_129 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (129); + BPH : constant Wide_Wide_Character := Wide_Wide_Character'Val (130); + NBH : constant Wide_Wide_Character := Wide_Wide_Character'Val (131); + Reserved_132 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (132); + NEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (133); + SSA : constant Wide_Wide_Character := Wide_Wide_Character'Val (134); + ESA : constant Wide_Wide_Character := Wide_Wide_Character'Val (135); + HTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (136); + HTJ : constant Wide_Wide_Character := Wide_Wide_Character'Val (137); + VTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (138); + PLD : constant Wide_Wide_Character := Wide_Wide_Character'Val (139); + PLU : constant Wide_Wide_Character := Wide_Wide_Character'Val (140); + RI : constant Wide_Wide_Character := Wide_Wide_Character'Val (141); + SS2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (142); + SS3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (143); + + DCS : constant Wide_Wide_Character := Wide_Wide_Character'Val (144); + PU1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (145); + PU2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (146); + STS : constant Wide_Wide_Character := Wide_Wide_Character'Val (147); + CCH : constant Wide_Wide_Character := Wide_Wide_Character'Val (148); + MW : constant Wide_Wide_Character := Wide_Wide_Character'Val (149); + SPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (150); + EPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (151); + + SOS : constant Wide_Wide_Character := Wide_Wide_Character'Val (152); + Reserved_153 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (153); + SCI : constant Wide_Wide_Character := Wide_Wide_Character'Val (154); + CSI : constant Wide_Wide_Character := Wide_Wide_Character'Val (155); + ST : constant Wide_Wide_Character := Wide_Wide_Character'Val (156); + OSC : constant Wide_Wide_Character := Wide_Wide_Character'Val (157); + PM : constant Wide_Wide_Character := Wide_Wide_Character'Val (158); + APC : constant Wide_Wide_Character := Wide_Wide_Character'Val (159); + + ----------------------------------- + -- Other Graphic Wide_Wide_Characters -- + ----------------------------------- + + -- Wide_Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space + : constant Wide_Wide_Character := Wide_Wide_Character'Val (160); + NBSP : Wide_Wide_Character renames No_Break_Space; + Inverted_Exclamation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (161); + Cent_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (162); + Pound_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (163); + Currency_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (164); + Yen_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (165); + Broken_Bar : constant Wide_Wide_Character := Wide_Wide_Character'Val (166); + Section_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (167); + Diaeresis : constant Wide_Wide_Character := Wide_Wide_Character'Val (168); + Copyright_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (169); + Feminine_Ordinal_Indicator + : constant Wide_Wide_Character := Wide_Wide_Character'Val (170); + Left_Angle_Quotation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (171); + Not_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (172); + Soft_Hyphen : constant Wide_Wide_Character := Wide_Wide_Character'Val (173); + Registered_Trade_Mark_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (174); + Macron : constant Wide_Wide_Character := Wide_Wide_Character'Val (175); + + -- Wide_Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (176); + Ring_Above : Wide_Wide_Character renames Degree_Sign; + Plus_Minus_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (177); + Superscript_Two + : constant Wide_Wide_Character := Wide_Wide_Character'Val (178); + Superscript_Three + : constant Wide_Wide_Character := Wide_Wide_Character'Val (179); + Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (180); + Micro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (181); + Pilcrow_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (182); + Paragraph_Sign + : Wide_Wide_Character renames Pilcrow_Sign; + Middle_Dot : constant Wide_Wide_Character := Wide_Wide_Character'Val (183); + Cedilla : constant Wide_Wide_Character := Wide_Wide_Character'Val (184); + Superscript_One + : constant Wide_Wide_Character := Wide_Wide_Character'Val (185); + Masculine_Ordinal_Indicator + : constant Wide_Wide_Character := Wide_Wide_Character'Val (186); + Right_Angle_Quotation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (187); + Fraction_One_Quarter + : constant Wide_Wide_Character := Wide_Wide_Character'Val (188); + Fraction_One_Half + : constant Wide_Wide_Character := Wide_Wide_Character'Val (189); + Fraction_Three_Quarters + : constant Wide_Wide_Character := Wide_Wide_Character'Val (190); + Inverted_Question + : constant Wide_Wide_Character := Wide_Wide_Character'Val (191); + + -- Wide_Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (192); + UC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (193); + UC_A_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (194); + UC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (195); + UC_A_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (196); + UC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (197); + UC_AE_Diphthong + : constant Wide_Wide_Character := Wide_Wide_Character'Val (198); + UC_C_Cedilla + : constant Wide_Wide_Character := Wide_Wide_Character'Val (199); + UC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (200); + UC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (201); + UC_E_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (202); + UC_E_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (203); + UC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (204); + UC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (205); + UC_I_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (206); + UC_I_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (207); + + -- Wide_Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth + : constant Wide_Wide_Character := Wide_Wide_Character'Val (208); + UC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (209); + UC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (210); + UC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (211); + UC_O_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (212); + UC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (213); + UC_O_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (214); + Multiplication_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (215); + UC_O_Oblique_Stroke + : constant Wide_Wide_Character := Wide_Wide_Character'Val (216); + UC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (217); + UC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (218); + UC_U_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (219); + UC_U_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (220); + UC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (221); + UC_Icelandic_Thorn + : constant Wide_Wide_Character := Wide_Wide_Character'Val (222); + LC_German_Sharp_S + : constant Wide_Wide_Character := Wide_Wide_Character'Val (223); + + -- Wide_Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (224); + LC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (225); + LC_A_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (226); + LC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (227); + LC_A_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (228); + LC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (229); + LC_AE_Diphthong + : constant Wide_Wide_Character := Wide_Wide_Character'Val (230); + LC_C_Cedilla + : constant Wide_Wide_Character := Wide_Wide_Character'Val (231); + LC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (232); + LC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (233); + LC_E_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (234); + LC_E_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (235); + LC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (236); + LC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (237); + LC_I_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (238); + LC_I_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (239); + + -- Wide_Wide_Character positions 240 (16#F0#) .. 255 (16#FF) + + LC_Icelandic_Eth + : constant Wide_Wide_Character := Wide_Wide_Character'Val (240); + LC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (241); + LC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (242); + LC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (243); + LC_O_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (244); + LC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (245); + LC_O_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (246); + Division_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (247); + LC_O_Oblique_Stroke + : constant Wide_Wide_Character := Wide_Wide_Character'Val (248); + LC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (249); + LC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (250); + LC_U_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (251); + LC_U_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (252); + LC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (253); + LC_Icelandic_Thorn + : constant Wide_Wide_Character := Wide_Wide_Character'Val (254); + LC_Y_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (255); + +end Ada.Characters.Wide_Wide_Latin_1; diff --git a/gcc/ada/a-chzla9.ads b/gcc/ada/a-chzla9.ads new file mode 100644 index 00000000000..40691f2e6fd --- /dev/null +++ b/gcc/ada/a-chzla9.ads @@ -0,0 +1,390 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . W I D E _ W I D E _ L A T I N _ 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides definitions analogous to those in the GNAT package +-- Ada.Characters.Latin_9 except that the type of the various constants is +-- Wide_Wide_Character instead of Character. The provision of this package +-- is in accordance with the implementation permission in RM (A.3.3(27)). + +package Ada.Characters.Wide_Wide_Latin_9 is +pragma Pure (Wide_Wide_Latin_9); + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Wide_Wide_Character := Wide_Wide_Character'Val (0); + SOH : constant Wide_Wide_Character := Wide_Wide_Character'Val (1); + STX : constant Wide_Wide_Character := Wide_Wide_Character'Val (2); + ETX : constant Wide_Wide_Character := Wide_Wide_Character'Val (3); + EOT : constant Wide_Wide_Character := Wide_Wide_Character'Val (4); + ENQ : constant Wide_Wide_Character := Wide_Wide_Character'Val (5); + ACK : constant Wide_Wide_Character := Wide_Wide_Character'Val (6); + BEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (7); + BS : constant Wide_Wide_Character := Wide_Wide_Character'Val (8); + HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (9); + LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (10); + VT : constant Wide_Wide_Character := Wide_Wide_Character'Val (11); + FF : constant Wide_Wide_Character := Wide_Wide_Character'Val (12); + CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (13); + SO : constant Wide_Wide_Character := Wide_Wide_Character'Val (14); + SI : constant Wide_Wide_Character := Wide_Wide_Character'Val (15); + + DLE : constant Wide_Wide_Character := Wide_Wide_Character'Val (16); + DC1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (17); + DC2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (18); + DC3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (19); + DC4 : constant Wide_Wide_Character := Wide_Wide_Character'Val (20); + NAK : constant Wide_Wide_Character := Wide_Wide_Character'Val (21); + SYN : constant Wide_Wide_Character := Wide_Wide_Character'Val (22); + ETB : constant Wide_Wide_Character := Wide_Wide_Character'Val (23); + CAN : constant Wide_Wide_Character := Wide_Wide_Character'Val (24); + EM : constant Wide_Wide_Character := Wide_Wide_Character'Val (25); + SUB : constant Wide_Wide_Character := Wide_Wide_Character'Val (26); + ESC : constant Wide_Wide_Character := Wide_Wide_Character'Val (27); + FS : constant Wide_Wide_Character := Wide_Wide_Character'Val (28); + GS : constant Wide_Wide_Character := Wide_Wide_Character'Val (29); + RS : constant Wide_Wide_Character := Wide_Wide_Character'Val (30); + US : constant Wide_Wide_Character := Wide_Wide_Character'Val (31); + + ------------------------------------- + -- ISO 646 Graphic Wide_Wide_Characters -- + ------------------------------------- + + Space : constant Wide_Wide_Character := ' '; -- WC'Val(32) + Exclamation : constant Wide_Wide_Character := '!'; -- WC'Val(33) + Quotation : constant Wide_Wide_Character := '"'; -- WC'Val(34) + Number_Sign : constant Wide_Wide_Character := '#'; -- WC'Val(35) + Dollar_Sign : constant Wide_Wide_Character := '$'; -- WC'Val(36) + Percent_Sign : constant Wide_Wide_Character := '%'; -- WC'Val(37) + Ampersand : constant Wide_Wide_Character := '&'; -- WC'Val(38) + Apostrophe : constant Wide_Wide_Character := '''; -- WC'Val(39) + Left_Parenthesis : constant Wide_Wide_Character := '('; -- WC'Val(40) + Right_Parenthesis : constant Wide_Wide_Character := ')'; -- WC'Val(41) + Asterisk : constant Wide_Wide_Character := '*'; -- WC'Val(42) + Plus_Sign : constant Wide_Wide_Character := '+'; -- WC'Val(43) + Comma : constant Wide_Wide_Character := ','; -- WC'Val(44) + Hyphen : constant Wide_Wide_Character := '-'; -- WC'Val(45) + Minus_Sign : Wide_Wide_Character renames Hyphen; + Full_Stop : constant Wide_Wide_Character := '.'; -- WC'Val(46) + Solidus : constant Wide_Wide_Character := '/'; -- WC'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Wide_Wide_Character := ':'; -- WC'Val(58) + Semicolon : constant Wide_Wide_Character := ';'; -- WC'Val(59) + Less_Than_Sign : constant Wide_Wide_Character := '<'; -- WC'Val(60) + Equals_Sign : constant Wide_Wide_Character := '='; -- WC'Val(61) + Greater_Than_Sign : constant Wide_Wide_Character := '>'; -- WC'Val(62) + Question : constant Wide_Wide_Character := '?'; -- WC'Val(63) + + Commercial_At : constant Wide_Wide_Character := '@'; -- WC'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Wide_Wide_Character := '['; -- WC'Val (91) + Reverse_Solidus : constant Wide_Wide_Character := '\'; -- WC'Val (92) + Right_Square_Bracket : constant Wide_Wide_Character := ']'; -- WC'Val (93) + Circumflex : constant Wide_Wide_Character := '^'; -- WC'Val (94) + Low_Line : constant Wide_Wide_Character := '_'; -- WC'Val (95) + + Grave : constant Wide_Wide_Character := '`'; -- WC'Val (96) + LC_A : constant Wide_Wide_Character := 'a'; -- WC'Val (97) + LC_B : constant Wide_Wide_Character := 'b'; -- WC'Val (98) + LC_C : constant Wide_Wide_Character := 'c'; -- WC'Val (99) + LC_D : constant Wide_Wide_Character := 'd'; -- WC'Val (100) + LC_E : constant Wide_Wide_Character := 'e'; -- WC'Val (101) + LC_F : constant Wide_Wide_Character := 'f'; -- WC'Val (102) + LC_G : constant Wide_Wide_Character := 'g'; -- WC'Val (103) + LC_H : constant Wide_Wide_Character := 'h'; -- WC'Val (104) + LC_I : constant Wide_Wide_Character := 'i'; -- WC'Val (105) + LC_J : constant Wide_Wide_Character := 'j'; -- WC'Val (106) + LC_K : constant Wide_Wide_Character := 'k'; -- WC'Val (107) + LC_L : constant Wide_Wide_Character := 'l'; -- WC'Val (108) + LC_M : constant Wide_Wide_Character := 'm'; -- WC'Val (109) + LC_N : constant Wide_Wide_Character := 'n'; -- WC'Val (110) + LC_O : constant Wide_Wide_Character := 'o'; -- WC'Val (111) + LC_P : constant Wide_Wide_Character := 'p'; -- WC'Val (112) + LC_Q : constant Wide_Wide_Character := 'q'; -- WC'Val (113) + LC_R : constant Wide_Wide_Character := 'r'; -- WC'Val (114) + LC_S : constant Wide_Wide_Character := 's'; -- WC'Val (115) + LC_T : constant Wide_Wide_Character := 't'; -- WC'Val (116) + LC_U : constant Wide_Wide_Character := 'u'; -- WC'Val (117) + LC_V : constant Wide_Wide_Character := 'v'; -- WC'Val (118) + LC_W : constant Wide_Wide_Character := 'w'; -- WC'Val (119) + LC_X : constant Wide_Wide_Character := 'x'; -- WC'Val (120) + LC_Y : constant Wide_Wide_Character := 'y'; -- WC'Val (121) + LC_Z : constant Wide_Wide_Character := 'z'; -- WC'Val (122) + Left_Curly_Bracket : constant Wide_Wide_Character := '{'; -- WC'Val (123) + Vertical_Line : constant Wide_Wide_Character := '|'; -- WC'Val (124) + Right_Curly_Bracket : constant Wide_Wide_Character := '}'; -- WC'Val (125) + Tilde : constant Wide_Wide_Character := '~'; -- WC'Val (126) + DEL : constant Wide_Wide_Character := + Wide_Wide_Character'Val (127); + + -------------------------------------- + -- ISO 6429 Control Wide_Wide_Characters -- + -------------------------------------- + + IS4 : Wide_Wide_Character renames FS; + IS3 : Wide_Wide_Character renames GS; + IS2 : Wide_Wide_Character renames RS; + IS1 : Wide_Wide_Character renames US; + + Reserved_128 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (128); + Reserved_129 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (129); + BPH : constant Wide_Wide_Character := Wide_Wide_Character'Val (130); + NBH : constant Wide_Wide_Character := Wide_Wide_Character'Val (131); + Reserved_132 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (132); + NEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (133); + SSA : constant Wide_Wide_Character := Wide_Wide_Character'Val (134); + ESA : constant Wide_Wide_Character := Wide_Wide_Character'Val (135); + HTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (136); + HTJ : constant Wide_Wide_Character := Wide_Wide_Character'Val (137); + VTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (138); + PLD : constant Wide_Wide_Character := Wide_Wide_Character'Val (139); + PLU : constant Wide_Wide_Character := Wide_Wide_Character'Val (140); + RI : constant Wide_Wide_Character := Wide_Wide_Character'Val (141); + SS2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (142); + SS3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (143); + + DCS : constant Wide_Wide_Character := Wide_Wide_Character'Val (144); + PU1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (145); + PU2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (146); + STS : constant Wide_Wide_Character := Wide_Wide_Character'Val (147); + CCH : constant Wide_Wide_Character := Wide_Wide_Character'Val (148); + MW : constant Wide_Wide_Character := Wide_Wide_Character'Val (149); + SPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (150); + EPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (151); + + SOS : constant Wide_Wide_Character := Wide_Wide_Character'Val (152); + Reserved_153 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (153); + SCI : constant Wide_Wide_Character := Wide_Wide_Character'Val (154); + CSI : constant Wide_Wide_Character := Wide_Wide_Character'Val (155); + ST : constant Wide_Wide_Character := Wide_Wide_Character'Val (156); + OSC : constant Wide_Wide_Character := Wide_Wide_Character'Val (157); + PM : constant Wide_Wide_Character := Wide_Wide_Character'Val (158); + APC : constant Wide_Wide_Character := Wide_Wide_Character'Val (159); + + ----------------------------------- + -- Other Graphic Wide_Wide_Characters -- + ----------------------------------- + + -- Wide_Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space + : constant Wide_Wide_Character := Wide_Wide_Character'Val (160); + NBSP : Wide_Wide_Character renames No_Break_Space; + Inverted_Exclamation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (161); + Cent_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (162); + Pound_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (163); + Euro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (164); + Yen_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (165); + UC_S_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (166); + Section_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (167); + LC_S_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (168); + Copyright_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (169); + Feminine_Ordinal_Indicator + : constant Wide_Wide_Character := Wide_Wide_Character'Val (170); + Left_Angle_Quotation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (171); + Not_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (172); + Soft_Hyphen : constant Wide_Wide_Character := Wide_Wide_Character'Val (173); + Registered_Trade_Mark_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (174); + Macron : constant Wide_Wide_Character := Wide_Wide_Character'Val (175); + + -- Wide_Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (176); + Ring_Above : Wide_Wide_Character renames Degree_Sign; + Plus_Minus_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (177); + Superscript_Two + : constant Wide_Wide_Character := Wide_Wide_Character'Val (178); + Superscript_Three + : constant Wide_Wide_Character := Wide_Wide_Character'Val (179); + UC_Z_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (180); + Micro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (181); + Pilcrow_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (182); + Paragraph_Sign + : Wide_Wide_Character renames Pilcrow_Sign; + Middle_Dot : constant Wide_Wide_Character := Wide_Wide_Character'Val (183); + LC_Z_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (184); + Superscript_One + : constant Wide_Wide_Character := Wide_Wide_Character'Val (185); + Masculine_Ordinal_Indicator + : constant Wide_Wide_Character := Wide_Wide_Character'Val (186); + Right_Angle_Quotation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (187); + UC_Ligature_OE + : constant Wide_Wide_Character := Wide_Wide_Character'Val (188); + LC_Ligature_OE + : constant Wide_Wide_Character := Wide_Wide_Character'Val (189); + UC_Y_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (190); + Inverted_Question + : constant Wide_Wide_Character := Wide_Wide_Character'Val (191); + + -- Wide_Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (192); + UC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (193); + UC_A_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (194); + UC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (195); + UC_A_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (196); + UC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (197); + UC_AE_Diphthong + : constant Wide_Wide_Character := Wide_Wide_Character'Val (198); + UC_C_Cedilla + : constant Wide_Wide_Character := Wide_Wide_Character'Val (199); + UC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (200); + UC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (201); + UC_E_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (202); + UC_E_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (203); + UC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (204); + UC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (205); + UC_I_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (206); + UC_I_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (207); + + -- Wide_Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth + : constant Wide_Wide_Character := Wide_Wide_Character'Val (208); + UC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (209); + UC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (210); + UC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (211); + UC_O_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (212); + UC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (213); + UC_O_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (214); + Multiplication_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (215); + UC_O_Oblique_Stroke + : constant Wide_Wide_Character := Wide_Wide_Character'Val (216); + UC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (217); + UC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (218); + UC_U_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (219); + UC_U_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (220); + UC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (221); + UC_Icelandic_Thorn + : constant Wide_Wide_Character := Wide_Wide_Character'Val (222); + LC_German_Sharp_S + : constant Wide_Wide_Character := Wide_Wide_Character'Val (223); + + -- Wide_Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (224); + LC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (225); + LC_A_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (226); + LC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (227); + LC_A_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (228); + LC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (229); + LC_AE_Diphthong + : constant Wide_Wide_Character := Wide_Wide_Character'Val (230); + LC_C_Cedilla + : constant Wide_Wide_Character := Wide_Wide_Character'Val (231); + LC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (232); + LC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (233); + LC_E_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (234); + LC_E_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (235); + LC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (236); + LC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (237); + LC_I_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (238); + LC_I_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (239); + + -- Wide_Wide_Character positions 240 (16#F0#) .. 255 (16#FF) + + LC_Icelandic_Eth + : constant Wide_Wide_Character := Wide_Wide_Character'Val (240); + LC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (241); + LC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (242); + LC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (243); + LC_O_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (244); + LC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (245); + LC_O_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (246); + Division_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (247); + LC_O_Oblique_Stroke + : constant Wide_Wide_Character := Wide_Wide_Character'Val (248); + LC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (249); + LC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (250); + LC_U_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (251); + LC_U_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (252); + LC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (253); + LC_Icelandic_Thorn + : constant Wide_Wide_Character := Wide_Wide_Character'Val (254); + LC_Y_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (255); + + ------------------------------------------------ + -- Summary of Changes from Latin-1 => Latin-9 -- + ------------------------------------------------ + + -- 164 Currency => Euro_Sign + -- 166 Broken_Bar => UC_S_Caron + -- 168 Diaeresis => LC_S_Caron + -- 180 Acute => UC_Z_Caron + -- 184 Cedilla => LC_Z_Caron + -- 188 Fraction_One_Quarter => UC_Ligature_OE + -- 189 Fraction_One_Half => LC_Ligature_OE + -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis + +end Ada.Characters.Wide_Wide_Latin_9; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb new file mode 100644 index 00000000000..252b64f2a34 --- /dev/null +++ b/gcc/ada/a-cidlli.adb @@ -0,0 +1,1314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Indefinite_Doubly_Linked_Lists is + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Delete_Node + (Container : in out List; + Node : in out Node_Access); + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + L : Node_Access; + R : Node_Access; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + L := Left.First; + R := Right.First; + for J in 1 .. Left.Length loop + if L.Element = null then + if R.Element /= null then + return False; + end if; + + elsif R.Element = null then + return False; + + elsif L.Element.all /= R.Element.all then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out List) is + Src : Node_Access := Container.First; + Dst : Node_Access; + + begin + if Src = null then + pragma Assert (Container.Last = null); + pragma Assert (Container.Length = 0); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + pragma Assert (Container.Length > 0); + + Container.First := null; + Container.Last := null; + Container.Length := 0; + + Dst := new Node_Type'(null, null, null); + + if Src.Element /= null then + begin + Dst.Element := new Element_Type'(Src.Element.all); + exception + when others => + Free (Dst); + raise; + end; + end if; + + Container.First := Dst; + + Container.Last := Dst; + loop + Container.Length := Container.Length + 1; + Src := Src.Next; + exit when Src = null; + + Dst := new Node_Type'(null, Prev => Container.Last, Next => null); + + if Src.Element /= null then + begin + Dst.Element := new Element_Type'(Src.Element.all); + exception + when others => + Free (Dst); + raise; + end; + end if; + + Container.Last.Next := Dst; + Container.Last := Dst; + end loop; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + begin + Delete_Last (Container, Count => Container.Length); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + for Index in 1 .. Count loop + Delete_Node (Container, Position.Node); + + if Position.Node = null then + Position.Container := null; + return; + end if; + end loop; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1) + is + Node : Node_Access := Container.First; + begin + for J in 1 .. Count_Type'Min (Count, Container.Length) loop + Delete_Node (Container, Node); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1) + is + Node : Node_Access; + begin + for J in 1 .. Count_Type'Min (Count, Container.Length) loop + Node := Container.Last; + Delete_Node (Container, Node); + end loop; + end Delete_Last; + + ----------------- + -- Delete_Node -- + ----------------- + + procedure Delete_Node + (Container : in out List; + Node : in out Node_Access) + is + X : Node_Access := Node; + + begin + Node := X.Next; + Container.Length := Container.Length - 1; + + if X = Container.First then + Container.First := X.Next; + + if X = Container.Last then + pragma Assert (Container.First = null); + pragma Assert (Container.Length = 0); + Container.Last := null; + else + pragma Assert (Container.Length > 0); + Container.First.Prev := null; + end if; + + elsif X = Container.Last then + pragma Assert (Container.Length > 0); + + Container.Last := X.Prev; + Container.Last.Next := null; + + else + pragma Assert (Container.Length > 0); + + X.Next.Prev := X.Prev; + X.Prev.Next := X.Next; + + end if; + + Free (X.Element); + Free (X); + end Delete_Node; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element.all; + end Element; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.First; + elsif Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + while Node /= null loop + if Node.Element /= null + and then Node.Element.all = Item + then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := Node.Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + begin + return Container.First.Element.all; + end First_Element; + + ------------------- + -- Generic_Merge -- + ------------------- + + procedure Generic_Merge + (Target : in out List; + Source : in out List) + is + LI : Cursor; + RI : Cursor; + + begin + if Target'Address = Source'Address then + return; + end if; + + LI := First (Target); + RI := First (Source); + while RI.Node /= null loop + if LI.Node = null then + Splice (Target, No_Element, Source); + return; + end if; + + if LI.Node.Element = null then + LI.Node := LI.Node.Next; + + elsif RI.Node.Element = null + or else RI.Node.Element.all < LI.Node.Element.all + then + declare + RJ : constant Cursor := RI; + begin + RI.Node := RI.Node.Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LI.Node.Next; + end if; + end loop; + end Generic_Merge; + + ------------------ + -- Generic_Sort -- + ------------------ + + procedure Generic_Sort (Container : in out List) is + procedure Partition (Pivot : Node_Access; Back : Node_Access); + + procedure Sort (Front, Back : Node_Access); + + --------------- + -- Partition -- + --------------- + + procedure Partition (Pivot : Node_Access; Back : Node_Access) is + Node : Node_Access := Pivot.Next; + + begin + while Node /= Back loop + if Pivot.Element = null then + Node := Node.Next; + + elsif Node.Element = null + or else Node.Element.all < Pivot.Element.all + then + declare + Prev : constant Node_Access := Node.Prev; + Next : constant Node_Access := Node.Next; + begin + Prev.Next := Next; + + if Next = null then + Container.Last := Prev; + else + Next.Prev := Prev; + end if; + + Node.Next := Pivot; + Node.Prev := Pivot.Prev; + + Pivot.Prev := Node; + + if Node.Prev = null then + Container.First := Node; + else + Node.Prev.Next := Node; + end if; + + Node := Next; + end; + + else + Node := Node.Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Node_Access) is + Pivot : Node_Access; + + begin + if Front = null then + Pivot := Container.First; + else + Pivot := Front.Next; + end if; + + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Generic_Sort + + begin + Sort (Front => null, Back => null); + + pragma Assert (Container.Length = 0 + or else (Container.First.Prev = null + and Container.Last.Next = null)); + end Generic_Sort; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position.Container /= null and then Position.Node /= null; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Node : Node_Access; + + begin + if Before.Container /= null + and then Before.Container /= List_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + declare + Element : Element_Access := new Element_Type'(New_Item); + begin + New_Node := new Node_Type'(Element, null, null); + exception + when others => + Free (Element); + raise; + end; + + Insert_Internal (Container, Before.Node, New_Node); + Position := Cursor'(Before.Container, New_Node); + + for J in Count_Type'(2) .. Count loop + + declare + Element : Element_Access := new Element_Type'(New_Item); + begin + New_Node := new Node_Type'(Element, null, null); + exception + when others => + Free (Element); + raise; + end; + + Insert_Internal (Container, Before.Node, New_Node); + end loop; + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access) + is + begin + if Container.Length = 0 then + pragma Assert (Before = null); + pragma Assert (Container.First = null); + pragma Assert (Container.Last = null); + + Container.First := New_Node; + Container.Last := New_Node; + + elsif Before = null then + pragma Assert (Container.Last.Next = null); + + Container.Last.Next := New_Node; + New_Node.Prev := Container.Last; + + Container.Last := New_Node; + + elsif Before = Container.First then + pragma Assert (Container.First.Prev = null); + + Container.First.Prev := New_Node; + New_Node.Next := Container.First; + + Container.First := New_Node; + + else + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + New_Node.Next := Before; + New_Node.Prev := Before.Prev; + + Before.Prev.Next := New_Node; + Before.Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : in Cursor)) + is + Node : Node_Access := Container.First; + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Next; + end loop; + end Iterate; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out List; Source : in out List) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Length > 0 then + raise Constraint_Error; + end if; + + Target.First := Source.First; + Source.First := null; + + Target.Last := Source.Last; + Source.Last := null; + + Target.Length := Source.Length; + Source.Length := 0; + end Move; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + begin + return Container.Last.Element.all; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + if Position.Node = null then + return; + end if; + + Position.Node := Position.Node.Next; + + if Position.Node = null then + Position.Container := null; + end if; + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + end if; + + declare + Next_Node : constant Node_Access := Position.Node.Next; + begin + if Next_Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Next_Node); + end; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + if Position.Node = null then + return; + end if; + + Position.Node := Position.Node.Prev; + + if Position.Node = null then + Position.Container := null; + end if; + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + end if; + + declare + Prev_Node : constant Node_Access := Position.Node.Prev; + begin + if Prev_Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Prev_Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : in Element_Type)) + is + begin + Process (Position.Node.Element.all); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out List) + is + N : Count_Type'Base; + X : Node_Access; + + begin + Clear (Item); -- ??? + + Count_Type'Base'Read (Stream, N); + + if N = 0 then + return; + end if; + + X := new Node_Type; + + begin + X.Element := new Element_Type'(Element_Type'Input (Stream)); + exception + when others => + Free (X); + raise; + end; + + Item.First := X; + + Item.Last := X; + loop + Item.Length := Item.Length + 1; + exit when Item.Length = N; + + X := new Node_Type; + + begin + X.Element := new Element_Type'(Element_Type'Input (Stream)); + exception + when others => + Free (X); + raise; + end; + + X.Prev := Item.Last; + Item.Last.Next := X; + Item.Last := X; + end loop; + end Read; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Position : Cursor; + By : Element_Type) + is + X : Element_Access := Position.Node.Element; + begin + Position.Node.Element := new Element_Type'(By); + Free (X); + end Replace_Element; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.Last; + elsif Position.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + while Node /= null loop + if Node.Element /= null + and then Node.Element.all = Item + then + return Cursor'(Container'Unchecked_Access, Node); + end if; + + Node := Node.Prev; + end loop; + + return No_Element; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : in Cursor)) + is + Node : Node_Access := Container.Last; + + begin + while Node /= null loop + Process (Cursor'(Container'Unchecked_Access, Node)); + Node := Node.Prev; + end loop; + end Reverse_Iterate; + + ------------------ + -- Reverse_List -- + ------------------ + + procedure Reverse_List (Container : in out List) is + I : Node_Access := Container.First; + J : Node_Access := Container.Last; + + procedure Swap (L, R : Node_Access); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L, R : Node_Access) is + LN : constant Node_Access := L.Next; + LP : constant Node_Access := L.Prev; + + RN : constant Node_Access := R.Next; + RP : constant Node_Access := R.Prev; + + begin + if LP /= null then + LP.Next := R; + end if; + + if RN /= null then + RN.Prev := L; + end if; + + L.Next := RN; + R.Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + L.Prev := R; + R.Next := L; + + else + L.Prev := RP; + RP.Next := L; + + R.Next := LN; + LN.Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_List + + begin + if Container.Length <= 1 then + return; + end if; + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := J.Next; + exit when I = J; + + I := I.Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := I.Next; + exit when I = J; + + J := J.Prev; + exit when I = J; + end loop; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Reverse_List; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Before.Container /= null + and then Before.Container /= List_Access'(Target'Unchecked_Access) + then + raise Program_Error; + end if; + + if Target'Address = Source'Address + or else Source.Length = 0 + then + return; + end if; + + if Target.Length = 0 then + pragma Assert (Before = No_Element); + + Target.First := Source.First; + Target.Last := Source.Last; + + elsif Before.Node = null then + pragma Assert (Target.Last.Next = null); + + Target.Last.Next := Source.First; + Source.First.Prev := Target.Last; + + Target.Last := Source.Last; + + elsif Before.Node = Target.First then + pragma Assert (Target.First.Prev = null); + + Source.Last.Next := Target.First; + Target.First.Prev := Source.Last; + + Target.First := Source.First; + + else + Before.Node.Prev.Next := Source.First; + Source.First.Prev := Before.Node.Prev; + + Before.Node.Prev := Source.Last; + Source.Last.Next := Before.Node; + end if; + + Source.First := null; + Source.Last := null; + + Target.Length := Target.Length + Source.Length; + Source.Length := 0; + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Position : Cursor) + is + X : Node_Access := Position.Node; + + begin + if Before.Container /= null + and then Before.Container /= List_Access'(Target'Unchecked_Access) + then + raise Program_Error; + end if; + + if Position.Container /= null + and then Position.Container /= List_Access'(Target'Unchecked_Access) + then + raise Program_Error; + end if; + + if X = null + or else X = Before.Node + or else X.Next = Before.Node + then + return; + end if; + + pragma Assert (Target.Length > 0); + + if Before.Node = null then + pragma Assert (X /= Target.Last); + + if X = Target.First then + Target.First := X.Next; + Target.First.Prev := null; + else + X.Prev.Next := X.Next; + X.Next.Prev := X.Prev; + end if; + + Target.Last.Next := X; + X.Prev := Target.Last; + + Target.Last := X; + Target.Last.Next := null; + + return; + end if; + + if Before.Node = Target.First then + pragma Assert (X /= Target.First); + + if X = Target.Last then + Target.Last := X.Prev; + Target.Last.Next := null; + else + X.Prev.Next := X.Next; + X.Next.Prev := X.Prev; + end if; + + Target.First.Prev := X; + X.Next := Target.First; + + Target.First := X; + Target.First.Prev := null; + + return; + end if; + + if X = Target.First then + Target.First := X.Next; + Target.First.Prev := null; + + elsif X = Target.Last then + Target.Last := X.Prev; + Target.Last.Next := null; + + else + X.Prev.Next := X.Next; + X.Next.Prev := X.Prev; + end if; + + Before.Node.Prev.Next := X; + X.Prev := Before.Node.Prev; + + Before.Node.Prev := X; + X.Next := Before.Node; + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : Cursor) + is + X : Node_Access := Position.Node; + + begin + if Target'Address = Source'Address then + Splice (Target, Before, Position); + return; + end if; + + if Before.Container /= null + and then Before.Container /= List_Access'(Target'Unchecked_Access) + then + raise Program_Error; + end if; + + if Position.Container /= null + and then Position.Container /= List_Access'(Source'Unchecked_Access) + then + raise Program_Error; + end if; + + if X = null then + return; + end if; + + pragma Assert (Source.Length > 0); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last.Next = null); + + if X = Source.First then + Source.First := X.Next; + Source.First.Prev := null; + + if X = Source.Last then + pragma Assert (Source.First = null); + pragma Assert (Source.Length = 1); + Source.Last := null; + end if; + + elsif X = Source.Last then + Source.Last := X.Prev; + Source.Last.Next := null; + + else + X.Prev.Next := X.Next; + X.Next.Prev := X.Prev; + end if; + + if Target.Length = 0 then + pragma Assert (Before = No_Element); + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + + Target.First := X; + Target.Last := X; + + elsif Before.Node = null then + Target.Last.Next := X; + X.Next := Target.Last; + + Target.Last := X; + Target.Last.Next := null; + + elsif Before.Node = Target.First then + Target.First.Prev := X; + X.Next := Target.First; + + Target.First := X; + Target.First.Prev := null; + + else + Before.Node.Prev.Next := X; + X.Prev := Before.Node.Prev; + + Before.Node.Prev := X; + X.Next := Before.Node; + end if; + + Target.Length := Target.Length + 1; + Source.Length := Source.Length - 1; + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap (I, J : Cursor) is + + -- Is this op legal when I and J designate elements in different + -- containers, or should it raise an exception (e.g. Program_Error). + + EI : constant Element_Access := I.Node.Element; + + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + is + begin + if I = No_Element + or else J = No_Element + then + raise Constraint_Error; + end if; + + if I.Container /= List_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + if J.Container /= I.Container then + raise Program_Error; + end if; + + pragma Assert (Container.Length >= 1); + + if I.Node = J.Node then + return; + end if; + + pragma Assert (Container.Length >= 2); + + declare + I_Next : constant Cursor := Next (I); + + begin + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + declare + J_Next : constant Cursor := Next (J); + begin + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end; + end if; + end; + end Swap_Links; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + Process (Position.Node.Element.all); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : List) + is + Node : Node_Access := Item.First; + begin + Count_Type'Base'Write (Stream, Item.Length); + while Node /= null loop + Element_Type'Output (Stream, Node.Element.all); -- X.all + Node := Node.Next; + end loop; + end Write; + +end Ada.Containers.Indefinite_Doubly_Linked_Lists; + + diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads new file mode 100644 index 00000000000..2f4ebcb69f0 --- /dev/null +++ b/gcc/ada/a-cidlli.ads @@ -0,0 +1,251 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with Ada.Streams; + +generic + + type Element_Type (<>) is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Indefinite_Doubly_Linked_Lists is + pragma Preelaborate (Indefinite_Doubly_Linked_Lists); + + type List is tagged private; + + type Cursor is private; + + Empty_List : constant List; + + No_Element : constant Cursor; + + function "=" (Left, Right : List) return Boolean; + + function Length (Container : List) return Count_Type; + + function Is_Empty (Container : List) return Boolean; + + procedure Clear (Container : in out List); + + function Element (Position : Cursor) + return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Replace_Element + (Position : Cursor; + By : Element_Type); + + procedure Move + (Target : in out List; + Source : in out List); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + + generic + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + procedure Generic_Sort (Container : in out List); + + generic + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + procedure Generic_Merge + (Target : in out List; + Source : in out List); + + procedure Reverse_List (Container : in out List); + + procedure Swap (I, J : Cursor); + + procedure Swap_Links (Container : in out List; I, J : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List); + + procedure Splice + (Target : in out List; + Before : Cursor; + Position : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : Cursor); + + function First (Container : List) return Cursor; + + function First_Element (Container : List) return Element_Type; + + function Last (Container : List) return Cursor; + + function Last_Element (Container : List) return Element_Type; + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + +private + type Node_Type; + type Node_Access is access Node_Type; + + type Element_Access is access Element_Type; + + type Node_Type is + record + Element : Element_Access; + Next : Node_Access; + Prev : Node_Access; + end record; + + function "=" (L, R : Node_Type) return Boolean is abstract; + + use Ada.Finalization; + + type List is + new Controlled with record + First : Node_Access; + Last : Node_Access; + Length : Count_Type := 0; + end record; + + procedure Adjust (Container : in out List); + + procedure Finalize (Container : in out List) renames Clear; + + use Ada.Streams; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Item : out List); + + for List'Read use Read; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Item : List); + + for List'Write use Write; + + Empty_List : constant List := List'(Controlled with null, null, 0); + + type List_Access is access constant List; + for List_Access'Storage_Size use 0; + + type Cursor is + record + Container : List_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := Cursor'(null, null); + +end Ada.Containers.Indefinite_Doubly_Linked_Lists; + + diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb new file mode 100644 index 00000000000..c0bfaed874a --- /dev/null +++ b/gcc/ada/a-cihama.adb @@ -0,0 +1,689 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit has originally being developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); + +with Ada.Containers.Hash_Tables.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); + +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Indefinite_Hashed_Maps is + + type Key_Access is access Key_Type; + type Element_Access is access Element_Type; + + type Node_Type is limited record + Key : Key_Access; + Element : Element_Access; + Next : Node_Access; + end record; + + procedure Free_Key is + new Ada.Unchecked_Deallocation (Key_Type, Key_Access); + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Node : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); + + function Find_Equal_Key + (R_Map : Map; + L_Node : Node_Access) return Boolean; + + procedure Free (X : in out Node_Access); + pragma Inline (Free); + + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is + new Ada.Containers.Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Table_Type => Map, + Null_Node => null, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Key_Ops is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + HT_Type => Map, + Null_Node => null, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + --------- + -- "=" -- + --------- + + function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); + + function "=" (Left, Right : Map) return Boolean renames Is_Equal; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Map) renames HT_Ops.Adjust; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) + return Count_Type renames HT_Ops.Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) renames HT_Ops.Clear; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Node : Node_Access) return Node_Access is + K : Key_Access := new Key_Type'(Node.Key.all); + E : Element_Access; + + begin + E := new Element_Type'(Node.Element.all); + return new Node_Type'(K, E, null); + + exception + when others => + Free_Key (K); + Free_Element (E); + raise; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access; + + begin + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + + if X = null then + raise Constraint_Error; + end if; + + Free (X); + end Delete; + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= Map_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + C : constant Cursor := Find (Container, Key); + begin + return C.Node.Element.all; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element.all; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean + is + begin + return Equivalent_Keys (Key, Node.Key.all); + end Equivalent_Keys; + + function Equivalent_Keys (Left, Right : Cursor) return Boolean is + begin + return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all); + end Equivalent_Keys; + + function Equivalent_Keys + (Left : Cursor; + Right : Key_Type) return Boolean + is + begin + return Equivalent_Keys (Left.Node.Key.all, Right); + end Equivalent_Keys; + + function Equivalent_Keys + (Left : Key_Type; + Right : Cursor) return Boolean + is + begin + return Equivalent_Keys (Left, Right.Node.Key.all); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access; + begin + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Map) renames HT_Ops.Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + -------------------- + -- Find_Equal_Key -- + -------------------- + + function Find_Equal_Key + (R_Map : Map; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key.all); + R_Node : Node_Access := R_Map.Buckets (R_Index); + + begin + while R_Node /= null loop + if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then + return L_Node.Element.all = R_Node.Element.all; + end if; + + R_Node := R_Node.Next; + end loop; + + return False; + end Find_Equal_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end First; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + Free_Key (X.Key); + Free_Element (X.Element); + Deallocate (X); + end if; + end Free; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Key.all); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + K : Key_Access; + E : Element_Access; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + K := Position.Node.Key; + E := Position.Node.Element; + + Position.Node.Key := new Key_Type'(Key); + Position.Node.Element := new Element_Type'(New_Item); + + Free_Key (K); + Free_Element (E); + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + + procedure Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + K : Key_Access := new Key_Type'(Key); + E : Element_Access; + begin + E := new Element_Type'(New_Item); + return new Node_Type'(K, E, Next); + exception + when others => + Free_Key (K); + Free_Element (E); + raise; + end New_Node; + + -- Start of processing for Insert + + begin + HT_Ops.Ensure_Capacity (Container, Container.Length + 1); + Insert (Container, Key, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing Iterate + + begin + Iterate (Container); + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + return Position.Node.Key.all; + end Key; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Map; + Source : in out Map) renames HT_Ops.Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + M : Map renames Position.Container.all; + Node : constant Node_Access := HT_Ops.Next (M, Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + Process (Position.Node.Key.all, Position.Node.Element.all); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Map) renames Read_Nodes; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + + begin + begin + Node.Key := new Key_Type'(Key_Type'Input (Stream)); + exception + when others => + Free (Node); + raise; + end; + + begin + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + exception + when others => + Free_Key (Node.Key); + Free (Node); + raise; + end; + + return Node; + end Read_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container, Key); + + K : Key_Access; + E : Element_Access; + + begin + if Node = null then + raise Constraint_Error; + end if; + + K := Node.Key; + E := Node.Element; + + Node.Key := new Key_Type'(Key); + Node.Element := new Element_Type'(New_Item); + + Free_Key (K); + Free_Element (E); + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element (Position : Cursor; By : Element_Type) is + X : Element_Access := Position.Node.Element; + begin + Position.Node.Element := new Element_Type'(By); + Free_Element (X); + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) renames HT_Ops.Ensure_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + Process (Position.Node.Key.all, Position.Node.Element.all); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Map) renames Write_Nodes; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Key_Type'Output (Stream, Node.Key.all); + Element_Type'Output (Stream, Node.Element.all); + end Write_Node; + +end Ada.Containers.Indefinite_Hashed_Maps; + diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads new file mode 100644 index 00000000000..7769cbb1a83 --- /dev/null +++ b/gcc/ada/a-cihama.ads @@ -0,0 +1,206 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables; +with Ada.Streams; + +generic + type Key_Type (<>) is private; + type Element_Type (<>) is private; + + with function Hash (Key : Key_Type) return Hash_Type; + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Hashed_Maps is + pragma Preelaborate (Indefinite_Hashed_Maps); + + type Map is tagged private; + type Cursor is private; + + Empty_Map : constant Map; + No_Element : constant Cursor; + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)); + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)); + + procedure Replace_Element + (Position : Cursor; + By : Element_Type); + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Delete + (Container : in out Map; + Key : Key_Type); + + procedure Exclude + (Container : in out Map; + Key : Key_Type); + + procedure Delete + (Container : in out Map; + Position : in out Cursor); + + function Contains + (Container : Map; + Key : Key_Type) return Boolean; + + function Find + (Container : Map; + Key : Key_Type) return Cursor; + + function Element + (Container : Map; + Key : Key_Type) return Element_Type; + + function Capacity (Container : Map) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type); + + function First (Container : Map) return Cursor; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function Key (Position : Cursor) return Key_Type; + + function Equivalent_Keys (Left, Right : Cursor) + return Boolean; + + function Equivalent_Keys + (Left : Cursor; + Right : Key_Type) return Boolean; + + function Equivalent_Keys + (Left : Key_Type; + Right : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + +private + type Node_Type; + type Node_Access is access Node_Type; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Access); + + use HT_Types; + + type Map is new Hash_Table_Type with null record; + + procedure Adjust (Container : in out Map); + + procedure Finalize (Container : in out Map); + + type Map_Access is access constant Map; + for Map_Access'Storage_Size use 0; + + type Cursor is + record + Container : Map_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := + (Container => null, + Node => null); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + Empty_Map : constant Map := (Hash_Table_Type with null record); + +end Ada.Containers.Indefinite_Hashed_Maps; + + + diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb new file mode 100644 index 00000000000..cc5589f0c1c --- /dev/null +++ b/gcc/ada/a-cihase.adb @@ -0,0 +1,1531 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit has originally being developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Hash_Tables.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); + +with Ada.Containers.Hash_Tables.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); + +with System; use type System.Address; + +with Ada.Containers.Prime_Numbers; + +with Ada.Finalization; use Ada.Finalization; + +package body Ada.Containers.Indefinite_Hashed_Sets is + + type Element_Access is access Element_Type; + + type Node_Type is + limited record + Element : Element_Access; + Next : Node_Access; + end record; + + function Hash_Node + (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + function Hash_Node + (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Element.all); + end Hash_Node; + + function Next + (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Next + (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + procedure Set_Next + (Node : Node_Access; + Next : Node_Access); + pragma Inline (Set_Next); + + procedure Set_Next + (Node : Node_Access; + Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean is + begin + return Equivalent_Keys (Key, Node.Element.all); + end Equivalent_Keys; + + function Copy_Node + (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Copy_Node + (Source : Node_Access) return Node_Access is + + Target : constant Node_Access := + new Node_Type'(Element => Source.Element, + Next => null); + begin + return Target; + end Copy_Node; + + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + procedure Free (X : in out Node_Access); + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + Free_Element (X.Element); + Deallocate (X); + end if; + end Free; + + package HT_Ops is + new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Table_Type => Set, + Null_Node => null, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Element_Keys is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + HT_Type => Set, + Null_Node => null, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + + procedure Adjust (Container : in out Set) renames HT_Ops.Adjust; + + procedure Finalize (Container : in out Set) renames HT_Ops.Finalize; + + + function Find_Equal_Key + (R_Set : Set; + L_Node : Node_Access) return Boolean; + + function Find_Equal_Key + (R_Set : Set; + L_Node : Node_Access) return Boolean is + + R_Index : constant Hash_Type := + Element_Keys.Index (R_Set, L_Node.Element.all); + + R_Node : Node_Access := R_Set.Buckets (R_Index); + + begin + + loop + + if R_Node = null then + return False; + end if; + + if L_Node.Element.all = R_Node.Element.all then + return True; + end if; + + R_Node := Next (R_Node); + + end loop; + + end Find_Equal_Key; + + function Is_Equal is + new HT_Ops.Generic_Equal (Find_Equal_Key); + + function "=" (Left, Right : Set) return Boolean renames Is_Equal; + + + function Length (Container : Set) return Count_Type is + begin + return Container.Length; + end Length; + + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + + procedure Clear (Container : in out Set) renames HT_Ops.Clear; + + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element.all; + end Element; + + + procedure Query_Element + (Position : in Cursor; + Process : not null access procedure (Element : in Element_Type)) is + begin + Process (Position.Node.Element.all); + end Query_Element; + + +-- TODO: +-- procedure Replace_Element (Container : in out Set; +-- Position : in Node_Access; +-- By : in Element_Type); + +-- procedure Replace_Element (Container : in out Set; +-- Position : in Node_Access; +-- By : in Element_Type) is + +-- Node : Node_Access := Position; + +-- begin + +-- if Equivalent_Keys (Node.Element.all, By) then + +-- declare +-- X : Element_Access := Node.Element; +-- begin +-- Node.Element := new Element_Type'(By); +-- -- +-- -- NOTE: If there's an exception here, then just +-- -- let it propagate. We haven't modified the +-- -- state of the container, so there's nothing else +-- -- we need to do. + +-- Free_Element (X); +-- end; + +-- return; + +-- end if; + +-- HT_Ops.Delete_Node_Sans_Free (Container, Node); + +-- begin +-- Free_Element (Node.Element); +-- exception +-- when others => +-- Node.Element := null; -- don't attempt to dealloc X.E again +-- Free (Node); +-- raise; +-- end; + +-- begin +-- Node.Element := new Element_Type'(By); +-- exception +-- when others => +-- Free (Node); +-- raise; +-- end; + +-- declare +-- function New_Node (Next : Node_Access) return Node_Access; +-- pragma Inline (New_Node); + +-- function New_Node (Next : Node_Access) return Node_Access is +-- begin +-- Node.Next := Next; +-- return Node; +-- end New_Node; + +-- procedure Insert is +-- new Element_Keys.Generic_Conditional_Insert (New_Node); + +-- Result : Node_Access; +-- Success : Boolean; +-- begin +-- Insert +-- (HT => Container, +-- Key => Node.Element.all, +-- Node => Result, +-- Success => Success); + +-- if not Success then +-- Free (Node); +-- raise Program_Error; +-- end if; + +-- pragma Assert (Result = Node); +-- end; + +-- end Replace_Element; + + +-- procedure Replace_Element (Container : in out Set; +-- Position : in Cursor; +-- By : in Element_Type) is +-- begin + +-- if Position.Container = null then +-- raise Constraint_Error; +-- end if; + +-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then +-- raise Program_Error; +-- end if; + +-- Replace_Element (Container, Position.Node, By); + +-- end Replace_Element; + + + procedure Move (Target : in out Set; + Source : in out Set) renames HT_Ops.Move; + + + procedure Insert (Container : in out Set; + New_Item : in Element_Type; + Position : out Cursor; + Inserted : out Boolean) is + + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + function New_Node (Next : Node_Access) return Node_Access is + Element : Element_Access := new Element_Type'(New_Item); + begin + return new Node_Type'(Element, Next); + exception + when others => + Free_Element (Element); + raise; + end New_Node; + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + begin + + HT_Ops.Ensure_Capacity (Container, Container.Length + 1); + Insert (Container, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + + end Insert; + + + procedure Insert (Container : in out Set; + New_Item : in Element_Type) is + + Position : Cursor; + Inserted : Boolean; + + begin + + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + + end Insert; + + + procedure Replace (Container : in out Set; + New_Item : in Element_Type) is + + Node : constant Node_Access := + Element_Keys.Find (Container, New_Item); + + X : Element_Access; + + begin + + if Node = null then + raise Constraint_Error; + end if; + + X := Node.Element; + + Node.Element := new Element_Type'(New_Item); + + Free_Element (X); + + end Replace; + + + procedure Include (Container : in out Set; + New_Item : in Element_Type) is + + Position : Cursor; + Inserted : Boolean; + + X : Element_Access; + + begin + + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + + X := Position.Node.Element; + + Position.Node.Element := new Element_Type'(New_Item); + + Free_Element (X); + + end if; + + end Include; + + + procedure Delete (Container : in out Set; + Item : in Element_Type) is + + X : Node_Access; + + begin + + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + + if X = null then + raise Constraint_Error; + end if; + + Free (X); + + end Delete; + + + procedure Exclude (Container : in out Set; + Item : in Element_Type) is + + X : Node_Access; + + begin + + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + Free (X); + + end Exclude; + + + procedure Delete (Container : in out Set; + Position : in out Cursor) is + begin + + if Position = No_Element then + return; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + Free (Position.Node); + + Position.Container := null; + + end Delete; + + + + procedure Union (Target : in out Set; + Source : in Set) is + + procedure Process (Src_Node : in Node_Access); + + procedure Process (Src_Node : in Node_Access) is + + Src : Element_Type renames Src_Node.Element.all; + + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + function New_Node (Next : Node_Access) return Node_Access is + Tgt : Element_Access := new Element_Type'(Src); + begin + return new Node_Type'(Tgt, Next); + exception + when others => + Free_Element (Tgt); + raise; + end New_Node; + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + Tgt_Node : Node_Access; + Success : Boolean; + + begin + + Insert (Target, Src, Tgt_Node, Success); + + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + begin + + if Target'Address = Source'Address then + return; + end if; + + HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length); + + Iterate (Source); + + end Union; + + + + function Union (Left, Right : Set) return Set is + + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + + if Left'Address = Right'Address then + return Left; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; + + declare + procedure Process (L_Node : Node_Access); + + procedure Process (L_Node : Node_Access) is + I : constant Hash_Type := + Hash (L_Node.Element.all) mod Buckets'Length; + begin + Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Left); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + Length := Left.Length; + + declare + procedure Process (Src_Node : Node_Access); + + procedure Process (Src_Node : Node_Access) is + + Src : Element_Type renames Src_Node.Element.all; + + I : constant Hash_Type := + Hash (Src) mod Buckets'Length; + + Tgt_Node : Node_Access := Buckets (I); + + begin + + while Tgt_Node /= null loop + + if Equivalent_Keys (Src, Tgt_Node.Element.all) then + return; + end if; + + Tgt_Node := Next (Tgt_Node); + + end loop; + + declare + Tgt : Element_Access := new Element_Type'(Src); + begin + Buckets (I) := new Node_Type'(Tgt, Buckets (I)); + exception + when others => + Free_Element (Tgt); + raise; + end; + + Length := Length + 1; + + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Right); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + return (Controlled with Buckets, Length); + + end Union; + + + function Is_In + (HT : Set; + Key : Node_Access) return Boolean; + pragma Inline (Is_In); + + function Is_In + (HT : Set; + Key : Node_Access) return Boolean is + begin + return Element_Keys.Find (HT, Key.Element.all) /= null; + end Is_In; + + + procedure Intersection (Target : in out Set; + Source : in Set) is + + Tgt_Node : Node_Access; + + begin + + if Target'Address = Source'Address then + return; + end if; + + if Source.Length = 0 then + Clear (Target); + return; + end if; + + -- TODO: optimize this to use an explicit + -- loop instead of an active iterator + -- (similar to how a passive iterator is + -- implemented). + -- + -- Another possibility is to test which + -- set is smaller, and iterate over the + -- smaller set. + + Tgt_Node := HT_Ops.First (Target); + + while Tgt_Node /= null loop + + if Is_In (Source, Tgt_Node) then + + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + + else + + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + end if; + + end loop; + + end Intersection; + + + function Intersection (Left, Right : Set) return Set is + + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + + if Left'Address = Right'Address then + return Left; + end if; + + Length := Count_Type'Min (Left.Length, Right.Length); + + if Length = 0 then + return Empty_Set; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; + + Length := 0; + + declare + procedure Process (L_Node : Node_Access); + + procedure Process (L_Node : Node_Access) is + begin + if Is_In (Right, L_Node) then + + declare + I : constant Hash_Type := + Hash (L_Node.Element.all) mod Buckets'Length; + begin + Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); + end; + + Length := Length + 1; + + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Left); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + return (Controlled with Buckets, Length); + + end Intersection; + + + procedure Difference (Target : in out Set; + Source : in Set) is + + + Tgt_Node : Node_Access; + + begin + + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + -- TODO: As I noted above, this can be + -- written in terms of a loop instead as + -- active-iterator style, sort of like a + -- passive iterator. + + Tgt_Node := HT_Ops.First (Target); + + while Tgt_Node /= null loop + + if Is_In (Source, Tgt_Node) then + + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + else + + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + + end if; + + end loop; + + end Difference; + + + + function Difference (Left, Right : Set) return Set is + + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Left.Length = 0 then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; + + Length := 0; + + declare + procedure Process (L_Node : Node_Access); + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right, L_Node) then + + declare + I : constant Hash_Type := + Hash (L_Node.Element.all) mod Buckets'Length; + begin + Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); + end; + + Length := Length + 1; + + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Left); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + return (Controlled with Buckets, Length); + + end Difference; + + + + procedure Symmetric_Difference (Target : in out Set; + Source : in Set) is + begin + + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length); + + if Target.Length = 0 then + + declare + procedure Process (Src_Node : Node_Access); + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element.all; + B : Buckets_Type renames Target.Buckets.all; + I : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.Length; + begin + declare + X : Element_Access := new Element_Type'(E); + begin + B (I) := new Node_Type'(X, B (I)); + exception + when others => + Free_Element (X); + raise; + end; + + N := N + 1; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Source); + end; + + else + + declare + procedure Process (Src_Node : Node_Access); + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element.all; + B : Buckets_Type renames Target.Buckets.all; + I : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.Length; + begin + if B (I) = null then + + declare + X : Element_Access := new Element_Type'(E); + begin + B (I) := new Node_Type'(X, null); + exception + when others => + Free_Element (X); + raise; + end; + + N := N + 1; + + elsif Equivalent_Keys (E, B (I).Element.all) then + + declare + X : Node_Access := B (I); + begin + B (I) := B (I).Next; + N := N - 1; + Free (X); + end; + + else + + declare + Prev : Node_Access := B (I); + Curr : Node_Access := Prev.Next; + begin + while Curr /= null loop + if Equivalent_Keys (E, Curr.Element.all) then + Prev.Next := Curr.Next; + N := N - 1; + Free (Curr); + return; + end if; + + Prev := Curr; + Curr := Prev.Next; + end loop; + + declare + X : Element_Access := new Element_Type'(E); + begin + B (I) := new Node_Type'(X, B (I)); + exception + when others => + Free_Element (X); + raise; + end; + + N := N + 1; + end; + + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Source); + end; + + end if; + + end Symmetric_Difference; + + + function Symmetric_Difference (Left, Right : Set) return Set is + + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; + + Length := 0; + + declare + procedure Process (L_Node : Node_Access); + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right, L_Node) then + declare + E : Element_Type renames L_Node.Element.all; + I : constant Hash_Type := Hash (E) mod Buckets'Length; + begin + + declare + X : Element_Access := new Element_Type'(E); + begin + Buckets (I) := new Node_Type'(X, Buckets (I)); + exception + when others => + Free_Element (X); + raise; + end; + + Length := Length + 1; + end; + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Left); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + declare + procedure Process (R_Node : Node_Access); + + procedure Process (R_Node : Node_Access) is + begin + if not Is_In (Left, R_Node) then + declare + E : Element_Type renames R_Node.Element.all; + I : constant Hash_Type := Hash (E) mod Buckets'Length; + begin + + declare + X : Element_Access := new Element_Type'(E); + begin + Buckets (I) := new Node_Type'(X, Buckets (I)); + exception + when others => + Free_Element (X); + raise; + end; + + Length := Length + 1; + + end; + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Right); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + return (Controlled with Buckets, Length); + + end Symmetric_Difference; + + + function Is_Subset (Subset : Set; + Of_Set : Set) return Boolean is + + Subset_Node : Node_Access; + + begin + + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + -- TODO: rewrite this to loop in the + -- style of a passive iterator. + + Subset_Node := HT_Ops.First (Subset); + + while Subset_Node /= null loop + if not Is_In (Of_Set, Subset_Node) then + return False; + end if; + + Subset_Node := HT_Ops.Next (Subset, Subset_Node); + end loop; + + return True; + + end Is_Subset; + + + function Overlap (Left, Right : Set) return Boolean is + + Left_Node : Node_Access; + + begin + + if Right.Length = 0 then + return False; + end if; + + if Left'Address = Right'Address then + return True; + end if; + + Left_Node := HT_Ops.First (Left); + + while Left_Node /= null loop + if Is_In (Right, Left_Node) then + return True; + end if; + + Left_Node := HT_Ops.Next (Left, Left_Node); + end loop; + + return False; + + end Overlap; + + + function Find (Container : Set; + Item : Element_Type) return Cursor is + + Node : constant Node_Access := Element_Keys.Find (Container, Item); + + begin + + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + + end Find; + + + function Contains (Container : Set; + Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + + + function First (Container : Set) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end First; + + +-- function First_Element (Container : Set) return Element_Type is +-- Node : constant Node_Access := HT_Ops.First (Container); +-- begin +-- return Node.Element; +-- end First_Element; + + + function Next (Position : Cursor) return Cursor is + begin + if Position.Container = null + or else Position.Node = null + then + return No_Element; + end if; + + declare + S : Set renames Position.Container.all; + Node : constant Node_Access := HT_Ops.Next (S, Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; + + if Position.Node = null then + return False; + end if; + + return True; + end Has_Element; + + + function Equivalent_Keys (Left, Right : Cursor) + return Boolean is + begin + return Equivalent_Keys (Left.Node.Element.all, Right.Node.Element.all); + end Equivalent_Keys; + + + function Equivalent_Keys (Left : Cursor; + Right : Element_Type) + return Boolean is + begin + return Equivalent_Keys (Left.Node.Element.all, Right); + end Equivalent_Keys; + + + function Equivalent_Keys (Left : Element_Type; + Right : Cursor) + return Boolean is + begin + return Equivalent_Keys (Left, Right.Node.Element.all); + end Equivalent_Keys; + + + procedure Iterate + (Container : in Set; + Process : not null access procedure (Position : in Cursor)) is + + procedure Process_Node (Node : in Node_Access); + pragma Inline (Process_Node); + + procedure Process_Node (Node : in Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process_Node); + begin + Iterate (Container); + end Iterate; + + + function Capacity (Container : Set) return Count_Type + renames HT_Ops.Capacity; + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : in Count_Type) + renames HT_Ops.Ensure_Capacity; + + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : in Node_Access); + pragma Inline (Write_Node); + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : in Node_Access) is + begin + Element_Type'Output (Stream, Node.Element.all); + end Write_Node; + + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : in Set) renames Write_Nodes; + + + function Read_Node (Stream : access Root_Stream_Type'Class) + return Node_Access; + pragma Inline (Read_Node); + + function Read_Node (Stream : access Root_Stream_Type'Class) + return Node_Access is + + X : Element_Access := new Element_Type'(Element_Type'Input (Stream)); + begin + return new Node_Type'(X, null); + exception + when others => + Free_Element (X); + raise; + end Read_Node; + + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set) renames Read_Nodes; + + + package body Generic_Keys is + + function Equivalent_Keys (Left : Cursor; + Right : Key_Type) + return Boolean is + begin + return Equivalent_Keys (Right, Left.Node.Element.all); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Key_Type; + Right : Cursor) + return Boolean is + begin + return Equivalent_Keys (Left, Right.Node.Element.all); + end Equivalent_Keys; + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean is + begin + return Equivalent_Keys (Key, Node.Element.all); + end Equivalent_Keys; + + package Key_Keys is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + HT_Type => Set, + Null_Node => null, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + + function Find (Container : Set; + Key : Key_Type) + return Cursor is + + Node : constant Node_Access := + Key_Keys.Find (Container, Key); + + begin + + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + + end Find; + + + function Contains (Container : Set; + Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + + function Element (Container : Set; + Key : Key_Type) + return Element_Type is + + Node : constant Node_Access := Key_Keys.Find (Container, Key); + begin + return Node.Element.all; + end Element; + + + function Key (Position : Cursor) return Key_Type is + begin + return Key (Position.Node.Element.all); + end Key; + + +-- TODO: +-- procedure Replace (Container : in out Set; +-- Key : in Key_Type; +-- New_Item : in Element_Type) is + +-- Node : constant Node_Access := +-- Key_Keys.Find (Container, Key); + +-- begin + +-- if Node = null then +-- raise Constraint_Error; +-- end if; + +-- Replace_Element (Container, Node, New_Item); + +-- end Replace; + + + procedure Delete (Container : in out Set; + Key : in Key_Type) is + + X : Node_Access; + + begin + + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + + if X = null then + raise Constraint_Error; + end if; + + Free (X); + + end Delete; + + + procedure Exclude (Container : in out Set; + Key : in Key_Type) is + + X : Node_Access; + + begin + + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + Free (X); + + end Exclude; + + + procedure Checked_Update_Element + (Container : in out Set; + Position : in Cursor; + Process : not null access + procedure (Element : in out Element_Type)) is + + begin + + if Position.Container = null then + raise Constraint_Error; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + declare + Old_Key : Key_Type renames Key (Position.Node.Element.all); + begin + Process (Position.Node.Element.all); + + if Equivalent_Keys (Old_Key, Position.Node.Element.all) then + return; + end if; + end; + + declare + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + function New_Node (Next : Node_Access) return Node_Access is + begin + Position.Node.Next := Next; + return Position.Node; + end New_Node; + + procedure Insert is + new Key_Keys.Generic_Conditional_Insert (New_Node); + + Result : Node_Access; + Success : Boolean; + begin + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + + Insert + (HT => Container, + Key => Key (Position.Node.Element.all), + Node => Result, + Success => Success); + + if not Success then + declare + X : Node_Access := Position.Node; + begin + Free (X); + end; + + raise Program_Error; + end if; + + pragma Assert (Result = Position.Node); + end; + + end Checked_Update_Element; + + end Generic_Keys; + +end Ada.Containers.Indefinite_Hashed_Sets; + diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads new file mode 100644 index 00000000000..53ec645be09 --- /dev/null +++ b/gcc/ada/a-cihase.ads @@ -0,0 +1,255 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables; +with Ada.Streams; + +generic + type Element_Type (<>) is private; + + with function Hash (Element : Element_Type) return Hash_Type; + + -- TODO: get a ruling from ARG in Atlanta re the name and + -- order of these declarations ??? + + with function Equivalent_Keys (Left, Right : Element_Type) return Boolean; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Hashed_Sets is + + pragma Preelaborate (Indefinite_Hashed_Sets); + + type Set is tagged private; + + type Cursor is private; + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + +-- TODO: resolve in atlanta ??? +-- procedure Replace_Element (Container : in out Set; +-- Position : Cursor; +-- By : Element_Type); + + procedure Move + (Target : in out Set; + Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert (Container : in out Set; New_Item : Element_Type); + + procedure Include (Container : in out Set; New_Item : Element_Type); + + procedure Replace (Container : in out Set; New_Item : Element_Type); + + procedure Delete (Container : in out Set; Item : Element_Type); + + procedure Exclude (Container : in out Set; Item : Element_Type); + + procedure Delete (Container : in out Set; Position : in out Cursor); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set + renames Symmetric_Difference; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function Overlap (Left, Right : Set) return Boolean; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Capacity (Container : Set) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type); + + function First (Container : Set) return Cursor; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function Equivalent_Keys (Left, Right : Cursor) return Boolean; + + function Equivalent_Keys + (Left : Cursor; + Right : Element_Type) return Boolean; + + function Equivalent_Keys + (Left : Element_Type; + Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + generic + type Key_Type (<>) is limited private; + + with function Key (Element : Element_Type) return Key_Type; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys + (Key : Key_Type; + Element : Element_Type) return Boolean; + + package Generic_Keys is + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + +-- TODO: resolve in atlanta??? +-- procedure Replace (Container : in out Set; +-- Key : Key_Type; +-- New_Item : Element_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + function Equivalent_Keys + (Left : Cursor; + Right : Key_Type) return Boolean; + + function Equivalent_Keys + (Left : Key_Type; + Right : Cursor) return Boolean; + end Generic_Keys; + +private + type Node_Type; + type Node_Access is access Node_Type; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Access); + + use HT_Types; + + type Set is new Hash_Table_Type with null record; + + procedure Adjust (Container : in out Set); + + procedure Finalize (Container : in out Set); + + type Set_Access is access constant Set; + for Set_Access'Storage_Size use 0; + + type Cursor is + record + Container : Set_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := + (Container => null, + Node => null); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := (Hash_Table_Type with null record); + +end Ada.Containers.Indefinite_Hashed_Sets; + diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb new file mode 100644 index 00000000000..1886d3d7dec --- /dev/null +++ b/gcc/ada/a-ciorma.adb @@ -0,0 +1,1031 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Ordered_Maps is + + use Red_Black_Trees; + + type Key_Access is access Key_Type; + type Element_Access is access Element_Type; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red; + Key : Key_Access; + Element : Element_Access; + end record; + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Copy_Tree (Source_Root : Node_Access) return Node_Access; + + procedure Delete_Tree (X : in out Node_Access); + + procedure Free (X : in out Node_Access); + + function Is_Equal_Node_Node + (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations + (Tree_Types => Tree_Types, + Null_Node => Node_Access'(null)); + + use Tree_Operations; + + package Key_Ops is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + procedure Free_Key is + new Ada.Unchecked_Deallocation (Key_Type, Key_Access); + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + return Left.Node.Key.all < Right.Node.Key.all; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Left.Node.Key.all < Right; + end "<"; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Key.all; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + return Right.Node.Key.all < Left.Node.Key.all; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right < Left.Node.Key.all; + end ">"; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Right.Node.Key.all < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Map) is + Tree : Tree_Type renames Container.Tree; + + N : constant Count_Type := Tree.Length; + X : constant Node_Access := Tree.Root; + + begin + if N = 0 then + pragma Assert (X = null); + return; + end if; + + Tree := (Length => 0, others => null); + + Tree.Root := Copy_Tree (X); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Adjust; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key); + begin + if Node = null then + return No_Element; + else + return Cursor'(Container'Unchecked_Access, Node); + end if; + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + Tree : Tree_Type renames Container.Tree; + Root : Node_Access := Tree.Root; + begin + Tree := (Length => 0, others => null); + Delete_Tree (Root); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Target : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Key => Source.Key, + Element => Source.Element); + begin + return Target; + end Copy_Node; + + --------------- + -- Copy_Tree -- + --------------- + + function Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + + P, X : Node_Access; + + begin + if Source_Root.Right /= null then + Target_Root.Right := Copy_Tree (Source_Root.Right); + Target_Root.Right.Parent := Target_Root; + end if; + + P := Target_Root; + X := Source_Root.Left; + while X /= null loop + declare + Y : Node_Access := Copy_Node (X); + + begin + P.Left := Y; + Y.Parent := P; + + if X.Right /= null then + Y.Right := Copy_Tree (X.Right); + Y.Right.Parent := Y; + end if; + + P := Y; + X := X.Left; + end; + end loop; + + return Target_Root; + + exception + when others => + Delete_Tree (Target_Root); + raise; + end Copy_Tree; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Map; + Position : in out Cursor) + is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= Map_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + if X = null then + raise Constraint_Error; + else + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Map) is + Position : Cursor := First (Container); + begin + Delete (Container, Position); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Map) is + Position : Cursor := Last (Container); + begin + Delete (Container, Position); + end Delete_Last; + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + begin + while X /= null loop + Y := X.Right; + Delete_Tree (Y); + Y := X.Left; + Free (X); + X := Y; + end loop; + end Delete_Tree; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element.all; + end Element; + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + return Node.Element.all; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if X /= null then + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + if Node = null then + return No_Element; + else + return Cursor'(Container'Unchecked_Access, Node); + end if; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + begin + if Container.Tree.First = null then + return No_Element; + else + return Cursor'(Container'Unchecked_Access, Container.Tree.First); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + begin + return Container.Tree.First.Element.all; + end First_Element; + + --------------- + -- First_Key -- + --------------- + + function First_Key (Container : Map) return Key_Type is + begin + return Container.Tree.First.Key.all; + end First_Key; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key); + begin + if Node = null then + return No_Element; + else + return Cursor'(Container'Unchecked_Access, Node); + end if; + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + Free_Key (X.Key); + Free_Element (X.Element); + Deallocate (X); + end if; + end Free; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + K : Key_Access; + E : Element_Access; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + K := Position.Node.Key; + E := Position.Node.Element; + + Position.Node.Key := new Key_Type'(Key); + Position.Node.Element := new Element_Type'(New_Item); + + Free_Key (K); + Free_Element (E); + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + begin + Node.Key := new Key_Type'(Key); + Node.Element := new Element_Type'(New_Item); + return Node; + + exception + when others => + + -- On exception, deallocate key and elem + + Free (Node); + raise; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node + (L, R : Node_Access) return Boolean is + begin + return L.Element.all = R.Element.all; + end Is_Equal_Node_Node; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + -- k > node same as node < k + + return Right.Key.all < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left < Right.Key.all; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree); + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + return Position.Node.Key.all; + end Key; + + ---------- + -- Last -- + ---------- + + function Last (Container : Map) return Cursor is + begin + if Container.Tree.Last = null then + return No_Element; + else + return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + begin + return Container.Tree.Last.Element.all; + end Last_Element; + + -------------- + -- Last_Key -- + -------------- + + function Last_Key (Container : Map) return Key_Type is + begin + return Container.Tree.Last.Key.all; + end Last_Key; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Map; Source : in out Map) is + begin + if Target'Address = Source'Address then + return; + end if; + + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := Tree_Operations.Next (Position.Node); + begin + if Node = null then + return No_Element; + else + return Cursor'(Position.Container, Node); + end if; + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + Process (Position.Node.Key.all, Position.Node.Element.all); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Map) + is + N : Count_Type'Base; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + begin + Node.Key := new Key_Type'(Key_Type'Input (Stream)); + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + return Node; + + exception + when others => + + -- Deallocate key and elem too on exception + + Free (Node); + raise; + end New_Node; + + -- Start of processing for Read + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + Local_Read (Container.Tree, N); + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := + Key_Ops.Find (Container.Tree, Key); + + K : Key_Access; + E : Element_Access; + + begin + if Node = null then + raise Constraint_Error; + end if; + + K := Node.Key; + E := Node.Element; + + Node.Key := new Key_Type'(Key); + Node.Element := new Element_Type'(New_Item); + + Free_Key (K); + Free_Element (E); + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element (Position : Cursor; By : Element_Type) is + X : Element_Access := Position.Node.Element; + begin + Position.Node.Element := new Element_Type'(By); + Free_Element (X); + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + Process (Position.Node.Key.all, Position.Node.Element.all); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Map) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Key_Type'Output (Stream, Node.Key.all); + Element_Type'Output (Stream, Node.Element.all); + end Process; + + -- Start of processing for Write + + begin + Count_Type'Base'Write (Stream, Container.Tree.Length); + Iterate (Container.Tree); + end Write; + +end Ada.Containers.Indefinite_Ordered_Maps; + diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads new file mode 100644 index 00000000000..8bfe3270e21 --- /dev/null +++ b/gcc/ada/a-ciorma.ads @@ -0,0 +1,234 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees; +with Ada.Finalization; +with Ada.Streams; + +generic + + type Key_Type (<>) is private; + + type Element_Type (<>) is private; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Ordered_Maps is +pragma Preelaborate (Indefinite_Ordered_Maps); + + type Map is tagged private; + + type Cursor is private; + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + function Key (Position : Cursor) return Key_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)); + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)); + + procedure Replace_Element (Position : Cursor; By : Element_Type); + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Delete + (Container : in out Map; + Key : Key_Type); + + procedure Exclude + (Container : in out Map; + Key : Key_Type); + + procedure Delete + (Container : in out Map; + Position : in out Cursor); + + procedure Delete_First (Container : in out Map); + + procedure Delete_Last (Container : in out Map); + + function Contains + (Container : Map; + Key : Key_Type) return Boolean; + + function Find + (Container : Map; + Key : Key_Type) return Cursor; + + function Element + (Container : Map; + Key : Key_Type) return Element_Type; + + function Floor + (Container : Map; + Key : Key_Type) return Cursor; + + function Ceiling + (Container : Map; + Key : Key_Type) return Cursor; + + function First (Container : Map) return Cursor; + + function First_Key (Container : Map) return Key_Type; + + function First_Element (Container : Map) return Element_Type; + + function Last (Container : Map) return Cursor; + + function Last_Key (Container : Map) return Key_Type; + + function Last_Element (Container : Map) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + +private + + type Node_Type; + type Node_Access is access Node_Type; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Access); + + use Tree_Types; + use Ada.Finalization; + + type Map is new Controlled with record + Tree : Tree_Type := (Length => 0, others => null); + end record; + + procedure Adjust (Container : in out Map); + + procedure Finalize (Container : in out Map) renames Clear; + + type Map_Access is access constant Map; + for Map_Access'Storage_Size use 0; + + type Cursor is record + Container : Map_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := Cursor'(null, null); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + Empty_Map : constant Map := + (Controlled with Tree => (Length => 0, others => null)); + +end Ada.Containers.Indefinite_Ordered_Maps; + diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb new file mode 100644 index 00000000000..1d608b03672 --- /dev/null +++ b/gcc/ada/a-ciormu.adb @@ -0,0 +1,1659 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Ordered_Multisets is + + use Red_Black_Trees; + + type Element_Access is access Element_Type; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red; + Element : Element_Access; + end record; + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Copy_Tree (Source_Root : Node_Access) return Node_Access; + + procedure Delete_Tree (X : in out Node_Access); + + procedure Free (X : in out Node_Access); + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Less_Node_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations + (Tree_Types => Tree_Types, + Null_Node => Node_Access'(null)); + + use Tree_Operations; + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + package Set_Ops is + new Generic_Set_Operations + (Tree_Operations => Tree_Operations, + Insert_With_Hint => Insert_With_Hint, + Copy_Tree => Copy_Tree, + Delete_Tree => Delete_Tree, + Is_Less => Is_Less_Node_Node, + Free => Free); + + package Element_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + return Left.Node.Element.all < Right.Node.Element.all; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean is + begin + return Left.Node.Element.all < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Element.all; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is begin + if Left'Address = Right'Address then + return True; + end if; + + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + return Right < Left.Node.Element.all; + end ">"; + + function ">" (Left, Right : Cursor) return Boolean is + begin + -- L > R same as R < L + + return Right.Node.Element.all < Left.Node.Element.all; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean is + begin + return Right.Node.Element.all < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + + N : constant Count_Type := Tree.Length; + X : constant Node_Access := Tree.Root; + + begin + if N = 0 then + pragma Assert (X = null); + return; + end if; + + Tree := (Length => 0, others => null); + + Tree.Root := Copy_Tree (X); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Adjust; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Ceiling (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + Root : Node_Access := Tree.Root; + begin + Tree := (Length => 0, others => null); + Delete_Tree (Root); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + X : Element_Access := new Element_Type'(Source.Element.all); + + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Element => X); + + exception + when others => + Free_Element (X); + raise; + end Copy_Node; + + --------------- + -- Copy_Tree -- + --------------- + + function Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + + P, X : Node_Access; + + begin + if Source_Root.Right /= null then + Target_Root.Right := Copy_Tree (Source_Root.Right); + Target_Root.Right.Parent := Target_Root; + end if; + + P := Target_Root; + X := Source_Root.Left; + while X /= null loop + declare + Y : Node_Access := Copy_Node (X); + + begin + P.Left := Y; + Y.Parent := P; + + if X.Right /= null then + Y.Right := Copy_Tree (X.Right); + Y.Right.Parent := Y; + end if; + + P := Y; + X := X.Left; + end; + end loop; + + return Target_Root; + + exception + when others => + Delete_Tree (Target_Root); + raise; + end Copy_Tree; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Item : Element_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Element_Keys.Ceiling (Tree, Item); + Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); + X : Node_Access; + + begin + if Node = Done then + raise Constraint_Error; + end if; + + loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + + exit when Node = Done; + end loop; + end Delete; + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + + begin + if X = null then + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; + + begin + if X = null then + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end Delete_Last; + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + begin + while X /= null loop + Y := X.Right; + Delete_Tree (Y); + Y := X.Left; + Free (X); + X := Y; + end loop; + end Delete_Tree; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Set_Ops.Difference (Target.Tree, Source.Tree); + end Difference; + + function Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element.all; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Element_Keys.Ceiling (Tree, Item); + Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); + X : Node_Access; + begin + while Node /= Done loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end loop; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Container.Tree.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + return Container.Tree.First.Element.all; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Floor (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + Free_Element (X.Element); + Deallocate (X); + end if; + end Free; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Element.all; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right > Left.Node.Element.all; + end "<"; + + --------- + -- ">" -- + --------- + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left > Right.Node.Element.all; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right < Left.Node.Element.all; + end ">"; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Ceiling (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ---------------------------- + -- Checked_Update_Element -- + ---------------------------- + + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Position.Container = null then + raise Constraint_Error; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + declare + Old_Key : Key_Type renames Key (Position.Node.Element.all); + + begin + Process (Position.Node.Element.all); + + if Old_Key < Position.Node.Element.all + or else Old_Key > Position.Node.Element.all + then + null; + else + return; + end if; + end; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + + Do_Insert : declare + Result : Node_Access; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Keys.Generic_Insert_Post (New_Node); + + procedure Insert is + new Key_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return Position.Node; + end New_Node; + + -- Start of processing for Do_Insert + + begin + Insert + (Tree => Container.Tree, + Key => Key (Position.Node.Element.all), + Node => Result); + + pragma Assert (Result = Position.Node); + end Do_Insert; + end Checked_Update_Element; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Key_Keys.Ceiling (Tree, Key); + Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); + X : Node_Access; + + begin + if Node = Done then + raise Constraint_Error; + end if; + + loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + + exit when Node = Done; + end loop; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + return Node.Element.all; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Key_Keys.Ceiling (Tree, Key); + Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); + X : Node_Access; + + begin + while Node /= Done loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end loop; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left > Right.Element.all; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left < Right.Element.all; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Key_Keys.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree, Key); + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + return Key (Position.Node.Element.all); + end Key; + + ------------- + -- Replace -- + ------------- + + -- In post-madision api: ??? + +-- procedure Replace +-- (Container : in out Set; +-- Key : Key_Type; +-- New_Item : Element_Type) +-- is +-- Node : Node_Access := Key_Keys.Find (Container.Tree, Key); + +-- begin +-- if Node = null then +-- raise Constraint_Error; +-- end if; + +-- Replace_Node (Container, Node, New_Item); +-- end Replace; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + ------------- + -- Iterate -- + ------------- + + procedure Local_Reverse_Iterate is + new Key_Keys.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree, Key); + end Reverse_Iterate; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + begin + Insert (Container, New_Item, Position); + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + X : Element_Access := new Element_Type'(New_Item); + + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => X); + + exception + when others => + Free_Element (X); + raise; + end New_Node; + + -- Start of processing for Insert + + begin + Unconditional_Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node); + + Position.Container := Container'Unchecked_Access; + end Insert; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + X : Element_Access := new Element_Type'(Src_Node.Element.all); + + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => X); + + exception + when others => + Free_Element (X); + raise; + end New_Node; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Tree, + Dst_Hint, + Src_Node.Element.all, + Dst_Node); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Set_Ops.Intersection (Target.Tree, Source.Tree); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element.all = R.Element.all; + end Is_Equal_Node_Node; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + -- e > node same as node < e + + return Right.Element.all < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Element.all; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element.all < R.Element.all; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Element_Keys.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree, Item); + end Iterate; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree); + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + if Container.Tree.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + return Container.Tree.Last.Element.all; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + if Left'Address = Right'Address then + return Left.Tree.Length /= 0; + end if; + + return Set_Ops.Overlap (Left.Tree, Right.Tree); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + Process (Position.Node.Element.all); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set) + is + N : Count_Type'Base; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + begin + begin + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + exception + when others => + Free (Node); + raise; + end; + + return Node; + end New_Node; + + -- Start of processing for Read + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + Local_Read (Container.Tree, N); + end Read; + + ------------- + -- Replace -- + ------------- + + -- NOTE: from post-madison api??? + +-- procedure Replace +-- (Container : in out Set; +-- Position : Cursor; +-- By : Element_Type) +-- is +-- begin +-- if Position.Container = null then +-- raise Constraint_Error; +-- end if; + +-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then +-- raise Program_Error; +-- end if; + +-- Replace_Node (Container, Position.Node, By); +-- end Replace; + + ------------------ + -- Replace_Node -- + ------------------ + + -- NOTE: from post-madison api??? + +-- procedure Replace_Node +-- (Container : in out Set; +-- Position : Node_Access; +-- By : Element_Type); +-- is +-- Tree : Tree_Type renames Container.Tree; +-- Node : Node_Access := Position; + +-- begin +-- if By < Node.Element +-- or else Node.Element < By +-- then +-- null; + +-- else +-- begin +-- Node.Element := By; + +-- exception +-- when others => +-- Tree_Operations.Delete_Node_Sans_Free (Tree, Node); +-- Free (Node); +-- raise; +-- end; + +-- return; +-- end if; + +-- Tree_Operations.Delete_Node_Sans_Free (Tree, Node); + +-- begin +-- Node.Element := By; + +-- exception +-- when others => +-- Free (Node); +-- raise; +-- end; + +-- declare +-- Result : Node_Access; +-- Success : Boolean; + +-- function New_Node return Node_Access; +-- pragma Inline (New_Node); + +-- procedure Insert_Post is +-- new Element_Keys.Generic_Insert_Post (New_Node); + +-- procedure Insert is +-- new Element_Keys.Generic_Conditional_Insert (Insert_Post); + +-- -------------- +-- -- New_Node -- +-- -------------- +-- +-- function New_Node return Node_Access is +-- begin +-- return Node; +-- end New_Node; + +-- -- Start of processing for Replace_Node + +-- begin +-- Insert +-- (Tree => Tree, +-- Key => Node.Element, +-- Node => Result, +-- Success => Success); + +-- if not Success then +-- Free (Node); +-- raise Program_Error; +-- end if; + +-- pragma Assert (Result = Node); +-- end; +-- end Replace_Node; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Element_Keys.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree, Item); + end Reverse_Iterate; + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Set_Ops.Union (Target.Tree, Source.Tree); + end Union; + + function Union (Left, Right : Set) return Set is begin + if Left'Address = Right'Address then + return Left; + end if; + + declare + Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Element_Type'Output (Stream, Node.Element.all); + end Process; + + -- Start of processing for Write + + begin + Count_Type'Base'Write (Stream, Container.Tree.Length); + Iterate (Container.Tree); + end Write; + +end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads new file mode 100644 index 00000000000..328d0dded9f --- /dev/null +++ b/gcc/ada/a-ciormu.ads @@ -0,0 +1,290 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees; +with Ada.Finalization; +with Ada.Streams; + +generic + type Element_Type (<>) is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Ordered_Multisets is +pragma Preelaborate (Indefinite_Ordered_Multisets); + + type Set is tagged private; + + type Cursor is private; + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor); + + procedure Insert (Container : in out Set; New_Item : Element_Type); + + procedure Delete (Container : in out Set; Item : Element_Type); + + procedure Exclude (Container : in out Set; Item : Element_Type); + + procedure Delete (Container : in out Set; Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + + -- NOTE: The following operation is named Replace in the Madison API. + -- However, it should be named Replace_Element ??? + -- + -- procedure Replace + -- (Container : in out Set; + -- Position : Cursor; + -- By : Element_Type); + + procedure Union (Target : in out Set; + Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)); + + generic + + type Key_Type (<>) is limited private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left : Key_Type; Right : Element_Type) + return Boolean is <>; + + with function ">" (Left : Key_Type; Right : Element_Type) + return Boolean is <>; + + package Generic_Keys is + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Floor (Container : Set; Key : Key_Type) return Cursor; + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + -- NOTE: in post-madison api ??? + -- procedure Replace + -- (Container : in out Set; + -- Key : Key_Type; + -- New_Item : Element_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + procedure Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)); + + end Generic_Keys; + +private + + type Node_Type; + type Node_Access is access Node_Type; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Access); + + use Tree_Types; + use Ada.Finalization; + + type Set is new Controlled with record + Tree : Tree_Type := (Length => 0, others => null); + end record; + + procedure Adjust (Container : in out Set); + + procedure Finalize (Container : in out Set) renames Clear; + + type Set_Access is access constant Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := Cursor'(null, null); + + use Ada.Streams; + + procedure Write (Stream : access Root_Stream_Type'Class; Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := + (Controlled with Tree => (Length => 0, others => null)); + +end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb new file mode 100644 index 00000000000..9cd5e14db36 --- /dev/null +++ b/gcc/ada/a-ciorse.adb @@ -0,0 +1,1557 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); + +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Ordered_Sets is + + type Element_Access is access Element_Type; + + use Red_Black_Trees; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red; + Element : Element_Access; + end record; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Copy_Tree (Source_Root : Node_Access) return Node_Access; + + procedure Delete_Tree (X : in out Node_Access); + + procedure Free (X : in out Node_Access); + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Less_Node_Node); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations + (Tree_Types => Tree_Types, + Null_Node => Node_Access'(null)); + + use Tree_Operations; + + package Element_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Generic_Set_Operations + (Tree_Operations => Tree_Operations, + Insert_With_Hint => Insert_With_Hint, + Copy_Tree => Copy_Tree, + Delete_Tree => Delete_Tree, + Is_Less => Is_Less_Node_Node, + Free => Free); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + return Left.Node.Element.all < Right.Node.Element.all; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean is + begin + return Left.Node.Element.all < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Element.all; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element.all = R.Element.all; + end Is_Equal_Node_Node; + + -- Start of processing for "=" + + begin + if Left'Address = Right'Address then + return True; + end if; + + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + -- L > R same as R < L + + return Right.Node.Element.all < Left.Node.Element.all; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + return Right < Left.Node.Element.all; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean is + begin + return Right.Node.Element.all < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + + begin + if Tree.Length = 0 then + pragma Assert (Tree.Root = null); + return; + end if; + + begin + Tree.Root := Copy_Tree (Tree.Root); + exception + when others => + Tree := (Length => 0, others => null); + raise; + end; + + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + end Adjust; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Ceiling (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + Root : Node_Access := Tree.Root; + begin + Tree := (Length => 0, others => null); + Delete_Tree (Root); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Element : Element_Access := new Element_Type'(Source.Element.all); + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Element => Element); + exception + when others => + Free_Element (Element); + raise; + end Copy_Node; + + --------------- + -- Copy_Tree -- + --------------- + + function Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + P, X : Node_Access; + + begin + if Source_Root.Right /= null then + Target_Root.Right := Copy_Tree (Source_Root.Right); + Target_Root.Right.Parent := Target_Root; + end if; + + P := Target_Root; + X := Source_Root.Left; + + while X /= null loop + declare + Y : Node_Access := Copy_Node (X); + + begin + P.Left := Y; + Y.Parent := P; + + if X.Right /= null then + Y.Right := Copy_Tree (X.Right); + Y.Right.Parent := Y; + end if; + + P := Y; + X := X.Left; + end; + end loop; + + return Target_Root; + + exception + when others => + Delete_Tree (Target_Root); + raise; + end Copy_Tree; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : Node_Access := + Element_Keys.Find (Container.Tree, Item); + + begin + if X = null then + raise Constraint_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + C : Cursor := First (Container); + begin + Delete (Container, C); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + C : Cursor := Last (Container); + begin + Delete (Container, C); + end Delete_Last; + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + begin + while X /= null loop + Y := X.Right; + Delete_Tree (Y); + Y := X.Left; + Free (X); + X := Y; + end loop; + end Delete_Tree; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Set_Ops.Difference (Target.Tree, Source.Tree); + end Difference; + + function Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element.all; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : Node_Access := + Element_Keys.Find (Container.Tree, Item); + begin + if X /= null then + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Container.Tree.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + return Container.Tree.First.Element.all; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Floor (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + Free_Element (X.Element); + Deallocate (X); + end if; + end Free; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Element.all; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right > Left.Node.Element.all; + end "<"; + + --------- + -- ">" -- + --------- + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left > Right.Node.Element.all; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right < Left.Node.Element.all; + end ">"; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Ceiling (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ---------------------------- + -- Checked_Update_Element -- + ---------------------------- + + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)) + is + begin + if Position.Container = null then + raise Constraint_Error; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + declare + Old_Key : Key_Type renames Key (Position.Node.Element.all); + + begin + Process (Position.Node.Element.all); + + if Old_Key < Position.Node.Element.all + or else Old_Key > Position.Node.Element.all + then + null; + else + return; + end if; + end; + + declare + Result : Node_Access; + Success : Boolean; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Keys.Generic_Insert_Post (New_Node); + + procedure Insert is + new Key_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return Position.Node; + end New_Node; + + -- Start of processing for Checked_Update_Element + + begin + Delete_Node_Sans_Free (Container.Tree, Position.Node); + + Insert + (Tree => Container.Tree, + Key => Key (Position.Node.Element.all), + Node => Result, + Success => Success); + + if not Success then + declare + X : Node_Access := Position.Node; + begin + Free (X); + end; + + raise Program_Error; + end if; + + pragma Assert (Result = Position.Node); + end; + end Checked_Update_Element; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if X = null then + raise Constraint_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + C : constant Cursor := Find (Container, Key); + begin + return C.Node.Element.all; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if X /= null then + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Floor (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left > Right.Element.all; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left < Right.Element.all; + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + return Key (Position.Node.Element.all); + end Key; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + + X : Element_Access; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + X := Position.Node.Element; + Position.Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Element : Element_Access := new Element_Type'(New_Item); + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => Element); + exception + when others => + Free_Element (Element); + raise; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node, + Inserted); + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access) + is + Success : Boolean; + + function New_Node return Node_Access; + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Element : Element_Access := + new Element_Type'(Src_Node.Element.all); + Node : Node_Access; + + begin + begin + Node := new Node_Type; + exception + when others => + Free_Element (Element); + raise; + end; + + Node.Element := Element; + return Node; + end New_Node; + + -- Start of processing for Insert_With_Hint + + begin + Insert_With_Hint + (Dst_Tree, + Dst_Hint, + Src_Node.Element.all, + Dst_Node, + Success); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Set_Ops.Intersection (Target.Tree, Source.Tree); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean is + begin + -- e > node same as node < e + + return Right.Element.all < Left; + end Is_Greater_Element_Node; + + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean is + begin + return Left < Right.Element.all; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element.all < R.Element.all; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree); + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + if Container.Tree.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + return Container.Tree.Last.Element.all; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + if Left'Address = Right'Address then + return Left.Tree.Length /= 0; + end if; + + return Set_Ops.Overlap (Left.Tree, Right.Tree); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + Process (Position.Node.Element.all); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Ada.Streams.Root_Stream_Type'Class; + Container : out Set) + is + N : Count_Type'Base; + + function New_Node return Node_Access; + + procedure Read is + new Tree_Operations.Generic_Read (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + begin + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + return Node; + + exception + when others => + Free (Node); + raise; + end New_Node; + + -- Start of processing for Read + + begin + Clear (Container); + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + Read (Container.Tree, N); + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, New_Item); + + X : Element_Access; + + begin + if Node = null then + raise Constraint_Error; + end if; + + X := Node.Element; + Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end Replace; + +-- TODO ??? +-- procedure Replace +-- (Container : in out Set; +-- Key : Key_Type; +-- New_Item : Element_Type) +-- is +-- Node : Node_Access := Key_Keys.Find (Container.Tree, Key); + +-- begin +-- if Node = null then +-- raise Constraint_Error; +-- end if; + +-- Replace_Element (Container, Node, New_Item); +-- end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + +-- TODO: ??? +-- procedure Replace_Element +-- (Container : in out Set; +-- Position : Node_Access; +-- By : Element_Type) +-- is + +-- Node : Node_Access := Position; + +-- begin +-- if By < Node.Element.all +-- or else Node.Element.all < By +-- then +-- null; + +-- else +-- declare +-- X : Element_Access := Node.Element; + +-- begin +-- Node.Element := new Element_Type'(By); + +-- -- NOTE: If there's an exception here, then just +-- -- let it propagate. We haven't modified the +-- -- state of the container, so there's nothing else +-- -- we need to do. + +-- Free_Element (X); +-- end; + +-- return; +-- end if; + +-- Delete_Node_Sans_Free (Container.Tree, Node); + +-- begin +-- Free_Element (Node.Element); +-- exception +-- when others => +-- Node.Element := null; -- don't attempt to dealloc X.E again +-- Free (Node); +-- raise; +-- end; + +-- begin +-- Node.Element := new Element_Type'(By); +-- exception +-- when others => +-- Free (Node); +-- raise; +-- end; + +-- declare +-- function New_Node return Node_Access; +-- pragma Inline (New_Node); + +-- function New_Node return Node_Access is +-- begin +-- return Node; +-- end New_Node; + +-- procedure Insert_Post is +-- new Element_Keys.Generic_Insert_Post (New_Node); + +-- procedure Insert is +-- new Element_Keys.Generic_Conditional_Insert (Insert_Post); + +-- Result : Node_Access; +-- Success : Boolean; + +-- begin +-- Insert +-- (Tree => Container.Tree, +-- Key => Node.Element.all, +-- Node => Result, +-- Success => Success); + +-- if not Success then +-- Free (Node); +-- raise Program_Error; +-- end if; + +-- pragma Assert (Result = Node); +-- end; +-- end Replace_Element; + + +-- procedure Replace_Element +-- (Container : in out Set; +-- Position : Cursor; +-- By : Element_Type) +-- is +-- begin +-- if Position.Container = null then +-- raise Constraint_Error; +-- end if; + +-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then +-- raise Program_Error; +-- end if; + +-- Replace_Element (Container, Position.Node, By); +-- end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Set_Ops.Union (Target.Tree, Source.Tree); + end Union; + + function Union (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Union (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Ada.Streams.Root_Stream_Type'Class; + Container : Set) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Element_Type'Output (Stream, Node.Element.all); + end Process; + + -- Start of processing for Write + + begin + Count_Type'Base'Write (Stream, Container.Tree.Length); + Iterate (Container.Tree); + end Write; + +end Ada.Containers.Indefinite_Ordered_Sets; + + diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads new file mode 100644 index 00000000000..e05dc1a6638 --- /dev/null +++ b/gcc/ada/a-ciorse.ads @@ -0,0 +1,296 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees; +with Ada.Finalization; +with Ada.Streams; + +generic + type Element_Type (<>) is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Ordered_Sets is +pragma Preelaborate (Indefinite_Ordered_Sets); + + type Set is tagged private; + + type Cursor is private; + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + -- TODO: resolve in Atlanta??? + -- procedure Replace_Element + -- (Container : in out Set; + -- Position : Cursor; + -- By : Element_Type); + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + + procedure Include + (Container : in out Set; + New_Item : Element_Type); + + procedure Replace + (Container : in out Set; + New_Item : Element_Type); + + procedure Delete + (Container : in out Set; + Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; + Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + generic + type Key_Type (<>) is limited private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left : Key_Type; Right : Element_Type) + return Boolean is <>; + + with function ">" (Left : Key_Type; Right : Element_Type) + return Boolean is <>; + + package Generic_Keys is + + function Contains + (Container : Set; + Key : Key_Type) return Boolean; + + function Find + (Container : Set; + Key : Key_Type) return Cursor; + + function Floor + (Container : Set; + Key : Key_Type) return Cursor; + + function Ceiling + (Container : Set; + Key : Key_Type) return Cursor; + + function Key (Position : Cursor) return Key_Type; + + function Element + (Container : Set; + Key : Key_Type) return Element_Type; + + -- TODO: resolve in Atlanta??? + -- procedure Replace + -- (Container : in out Set; + -- Key : Key_Type; + -- New_Item : Element_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + -- TODO: resolve name in Atlanta??? + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + end Generic_Keys; + +private + + type Node_Type; + type Node_Access is access Node_Type; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Access); + + use Tree_Types; + use Ada.Finalization; + + type Set is new Controlled with record + Tree : Tree_Type := (Length => 0, others => null); + end record; + + procedure Adjust (Container : in out Set); + + procedure Finalize (Container : in out Set) renames Clear; + + type Set_Access is access constant Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := Cursor'(null, null); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := + (Controlled with Tree => (Length => 0, others => null)); + +end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb new file mode 100644 index 00000000000..e1120c1b357 --- /dev/null +++ b/gcc/ada/a-cohama.adb @@ -0,0 +1,663 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASHED_MAPS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Hash_Tables.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); + +with Ada.Containers.Hash_Tables.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); + +package body Ada.Containers.Hashed_Maps is + + type Node_Type is limited record + Key : Key_Type; + Element : Element_Type; + Next : Node_Access; + end record; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node + (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); + + function Find_Equal_Key + (R_Map : Map; + L_Node : Node_Access) return Boolean; + + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + package HT_Ops is + new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Table_Type => Map, + Null_Node => null, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Key_Ops is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + HT_Type => Map, + Null_Node => null, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); + + procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean renames Is_Equal; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Map) renames HT_Ops.Adjust; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) return Count_Type + renames HT_Ops.Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) renames HT_Ops.Clear; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node + (Source : Node_Access) return Node_Access + is + Target : constant Node_Access := + new Node_Type'(Key => Source.Key, + Element => Source.Element, + Next => null); + begin + return Target; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access; + + begin + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + + if X = null then + raise Constraint_Error; + end if; + + Free (X); + end Delete; + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= Map_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + C : constant Cursor := Find (Container, Key); + begin + return C.Node.Element; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean is + begin + return Equivalent_Keys (Key, Node.Key); + end Equivalent_Keys; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Cursor) + return Boolean is + begin + return Equivalent_Keys (Left.Node.Key, Right.Node.Key); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Equivalent_Keys (Left.Node.Key, Right); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Equivalent_Keys (Left, Right.Node.Key); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access; + begin + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Map) renames HT_Ops.Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + -------------------- + -- Find_Equal_Key -- + -------------------- + + function Find_Equal_Key + (R_Map : Map; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := Key_Ops.Index (R_Map, L_Node.Key); + R_Node : Node_Access := R_Map.Buckets (R_Index); + + begin + while R_Node /= null loop + if Equivalent_Keys (L_Node.Key, R_Node.Key) then + return L_Node.Element = R_Node.Element; + end if; + + R_Node := R_Node.Next; + end loop; + + return False; + end Find_Equal_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end First; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Key); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + Position.Node.Key := Key; + Position.Node.Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + Node : Node_Access := new Node_Type; -- Ada 2005 aggregate possible? + + begin + Node.Key := Key; + Node.Next := Next; + + return Node; + + exception + when others => + Free (Node); + raise; + end New_Node; + + -- Start of processing for Insert + + begin + HT_Ops.Ensure_Capacity (Container, Container.Length + 1); + Local_Insert (Container, Key, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + Node : constant Node_Access := new Node_Type'(Key, New_Item, Next); + begin + return Node; + end New_Node; + + -- Start of processing for Insert + + begin + HT_Ops.Ensure_Capacity (Container, Container.Length + 1); + Local_Insert (Container, Key, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container); + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + return Position.Node.Key; + end Key; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Map; + Source : in out Map) renames HT_Ops.Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + M : Map renames Position.Container.all; + Node : constant Node_Access := HT_Ops.Next (M, Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + Process (Position.Node.Key, Position.Node.Element); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Map) renames Read_Nodes; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + return Node; + + exception + when others => + Free (Node); + raise; + end Read_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container, Key); + + begin + if Node = null then + raise Constraint_Error; + end if; + + Node.Key := Key; + Node.Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element (Position : Cursor; By : Element_Type) is + begin + Position.Node.Element := By; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) renames HT_Ops.Ensure_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + Process (Position.Node.Key, Position.Node.Element); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Map) renames Write_Nodes; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + +end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads new file mode 100644 index 00000000000..72dd1c2b107 --- /dev/null +++ b/gcc/ada/a-cohama.ads @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASHED_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables; +with Ada.Streams; + +generic + type Key_Type is private; + + type Element_Type is private; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Hashed_Maps is +pragma Preelaborate (Hashed_Maps); + + type Map is tagged private; + + type Cursor is private; + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + function Element (Position : Cursor) + return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + + procedure Update_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + + procedure Replace_Element (Position : Cursor; By : Element_Type); + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Exclude (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Capacity (Container : Map) return Count_Type; + + procedure Reserve_Capacity (Container : in out Map; + Capacity : Count_Type); + + function First (Container : Map) return Cursor; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function Key (Position : Cursor) return Key_Type; + + function Equivalent_Keys (Left, Right : Cursor) return Boolean; + + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; + + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + +private + + type Node_Type; + type Node_Access is access Node_Type; + + package HT_Types is new Hash_Tables.Generic_Hash_Table_Types (Node_Access); + + use HT_Types; + + type Map is new Hash_Table_Type with null record; + + procedure Adjust (Container : in out Map); + + procedure Finalize (Container : in out Map); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + Empty_Map : constant Map := (Hash_Table_Type with null record); + + type Map_Access is access constant Map; + for Map_Access'Storage_Size use 0; + + type Cursor is + record + Container : Map_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := (Container => null, Node => null); + +end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb new file mode 100644 index 00000000000..58d04febfd1 --- /dev/null +++ b/gcc/ada/a-cohase.adb @@ -0,0 +1,1418 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASHED_SETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit has originally being developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Hash_Tables.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); + +with Ada.Containers.Hash_Tables.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); + +with System; use type System.Address; + +with Ada.Containers.Prime_Numbers; + +with Ada.Finalization; use Ada.Finalization; + +package body Ada.Containers.Hashed_Sets is + + type Node_Type is + limited record + Element : Element_Type; + Next : Node_Access; + end record; + + function Hash_Node + (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + function Hash_Node + (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Element); + end Hash_Node; + + function Next + (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Next + (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + procedure Set_Next + (Node : Node_Access; + Next : Node_Access); + pragma Inline (Set_Next); + + procedure Set_Next + (Node : Node_Access; + Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean is + begin + return Equivalent_Keys (Key, Node.Element); + end Equivalent_Keys; + + function Copy_Node + (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Copy_Node + (Source : Node_Access) return Node_Access is + + Target : constant Node_Access := + new Node_Type'(Element => Source.Element, + Next => null); + begin + return Target; + end Copy_Node; + + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + package HT_Ops is + new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Table_Type => Set, + Null_Node => null, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Element_Keys is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + HT_Type => Set, + Null_Node => null, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + + procedure Adjust (Container : in out Set) renames HT_Ops.Adjust; + + procedure Finalize (Container : in out Set) renames HT_Ops.Finalize; + + + function Find_Equal_Key + (R_Set : Set; + L_Node : Node_Access) return Boolean; + + function Find_Equal_Key + (R_Set : Set; + L_Node : Node_Access) return Boolean is + + R_Index : constant Hash_Type := + Element_Keys.Index (R_Set, L_Node.Element); + + R_Node : Node_Access := R_Set.Buckets (R_Index); + + begin + + loop + + if R_Node = null then + return False; + end if; + + if L_Node.Element = R_Node.Element then + -- pragma Assert (Is_Equal_Key (L_Node.Element, R_Node.Element)); + return True; + end if; + + R_Node := Next (R_Node); + + end loop; + + end Find_Equal_Key; + + function Is_Equal is + new HT_Ops.Generic_Equal (Find_Equal_Key); + + function "=" (Left, Right : Set) return Boolean renames Is_Equal; + + + function Length (Container : Set) return Count_Type is + begin + return Container.Length; + end Length; + + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + + procedure Clear (Container : in out Set) renames HT_Ops.Clear; + + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element; + end Element; + + + procedure Query_Element + (Position : in Cursor; + Process : not null access procedure (Element : in Element_Type)) is + begin + Process (Position.Node.Element); + end Query_Element; + + +-- TODO: +-- procedure Replace_Element (Container : in out Set; +-- Position : in Node_Access; +-- By : in Element_Type) is + +-- Node : Node_Access := Position; + +-- begin + +-- if Equivalent_Keys (Node.Element, By) then + +-- begin +-- Node.Element := By; +-- exception +-- when others => +-- HT_Ops.Delete_Node_Sans_Free (Container, Node); +-- Free (Node); +-- raise; +-- end; + +-- return; + +-- end if; + +-- HT_Ops.Delete_Node_Sans_Free (Container, Node); + +-- begin +-- Node.Element := By; +-- exception +-- when others => +-- Free (Node); +-- raise; +-- end; + +-- declare +-- function New_Node (Next : Node_Access) return Node_Access; +-- pragma Inline (New_Node); + +-- function New_Node (Next : Node_Access) return Node_Access is +-- begin +-- Node.Next := Next; +-- return Node; +-- end New_Node; + +-- procedure Insert is +-- new Element_Keys.Generic_Conditional_Insert (New_Node); + +-- Result : Node_Access; +-- Success : Boolean; +-- begin +-- Insert +-- (HT => Container, +-- Key => Node.Element, +-- Node => Result, +-- Success => Success); + +-- if not Success then +-- Free (Node); +-- raise Program_Error; +-- end if; + +-- pragma Assert (Result = Node); +-- end; + +-- end Replace_Element; + + +-- procedure Replace_Element (Container : in out Set; +-- Position : in Cursor; +-- By : in Element_Type) is +-- begin + +-- if Position.Container = null then +-- raise Constraint_Error; +-- end if; + +-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then +-- raise Program_Error; +-- end if; + +-- Replace_Element (Container, Position.Node, By); + +-- end Replace_Element; + + + procedure Move (Target : in out Set; + Source : in out Set) renames HT_Ops.Move; + + + procedure Insert (Container : in out Set; + New_Item : in Element_Type; + Position : out Cursor; + Inserted : out Boolean) is + + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + function New_Node (Next : Node_Access) return Node_Access is + Node : constant Node_Access := new Node_Type'(New_Item, Next); + begin + return Node; + end New_Node; + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + begin + + HT_Ops.Ensure_Capacity (Container, Container.Length + 1); + Insert (Container, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + + end Insert; + + + procedure Insert (Container : in out Set; + New_Item : in Element_Type) is + + Position : Cursor; + Inserted : Boolean; + + begin + + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + + end Insert; + + + procedure Replace (Container : in out Set; + New_Item : in Element_Type) is + + X : Node_Access := Element_Keys.Find (Container, New_Item); + + begin + + if X = null then + raise Constraint_Error; + end if; + + X.Element := New_Item; + + end Replace; + + + procedure Include (Container : in out Set; + New_Item : in Element_Type) is + + Position : Cursor; + Inserted : Boolean; + + begin + + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + Position.Node.Element := New_Item; + end if; + + end Include; + + + procedure Delete (Container : in out Set; + Item : in Element_Type) is + + X : Node_Access; + + begin + + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + + if X = null then + raise Constraint_Error; + end if; + + Free (X); + + end Delete; + + + procedure Exclude (Container : in out Set; + Item : in Element_Type) is + + X : Node_Access; + + begin + + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + Free (X); + + end Exclude; + + + procedure Delete (Container : in out Set; + Position : in out Cursor) is + begin + + if Position = No_Element then + return; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + Free (Position.Node); + + Position.Container := null; + + end Delete; + + + + procedure Union (Target : in out Set; + Source : in Set) is + + procedure Process (Src_Node : in Node_Access); + + procedure Process (Src_Node : in Node_Access) is + + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + function New_Node (Next : Node_Access) return Node_Access is + Node : constant Node_Access := + new Node_Type'(Src_Node.Element, Next); + begin + return Node; + end New_Node; + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + Tgt_Node : Node_Access; + Success : Boolean; + + begin + + Insert (Target, Src_Node.Element, Tgt_Node, Success); + + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + begin + + if Target'Address = Source'Address then + return; + end if; + + HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length); + + Iterate (Source); + + end Union; + + + + function Union (Left, Right : Set) return Set is + + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + + if Left'Address = Right'Address then + return Left; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; + + declare + procedure Process (L_Node : Node_Access); + + procedure Process (L_Node : Node_Access) is + I : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; + begin + Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Left); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + Length := Left.Length; + + declare + procedure Process (Src_Node : Node_Access); + + procedure Process (Src_Node : Node_Access) is + + I : constant Hash_Type := + Hash (Src_Node.Element) mod Buckets'Length; + + Tgt_Node : Node_Access := Buckets (I); + + begin + + while Tgt_Node /= null loop + + if Equivalent_Keys (Src_Node.Element, Tgt_Node.Element) then + return; + end if; + + Tgt_Node := Next (Tgt_Node); + + end loop; + + Buckets (I) := new Node_Type'(Src_Node.Element, Buckets (I)); + Length := Length + 1; + + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Right); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + return (Controlled with Buckets, Length); + + end Union; + + + function Is_In + (HT : Set; + Key : Node_Access) return Boolean; + pragma Inline (Is_In); + + function Is_In + (HT : Set; + Key : Node_Access) return Boolean is + begin + return Element_Keys.Find (HT, Key.Element) /= null; + end Is_In; + + + procedure Intersection (Target : in out Set; + Source : in Set) is + + Tgt_Node : Node_Access; + + begin + + if Target'Address = Source'Address then + return; + end if; + + if Source.Length = 0 then + Clear (Target); + return; + end if; + + -- TODO: optimize this to use an explicit + -- loop instead of an active iterator + -- (similar to how a passive iterator is + -- implemented). + -- + -- Another possibility is to test which + -- set is smaller, and iterate over the + -- smaller set. + + Tgt_Node := HT_Ops.First (Target); + + while Tgt_Node /= null loop + + if Is_In (Source, Tgt_Node) then + + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + + else + + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + end if; + + end loop; + + end Intersection; + + + function Intersection (Left, Right : Set) return Set is + + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + + if Left'Address = Right'Address then + return Left; + end if; + + Length := Count_Type'Min (Left.Length, Right.Length); + + if Length = 0 then + return Empty_Set; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; + + Length := 0; + + declare + procedure Process (L_Node : Node_Access); + + procedure Process (L_Node : Node_Access) is + begin + if Is_In (Right, L_Node) then + + declare + I : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; + begin + Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); + end; + + Length := Length + 1; + + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Left); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + return (Controlled with Buckets, Length); + + end Intersection; + + + procedure Difference (Target : in out Set; + Source : in Set) is + + + Tgt_Node : Node_Access; + + begin + + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + -- TODO: As I noted above, this can be + -- written in terms of a loop instead as + -- active-iterator style, sort of like a + -- passive iterator. + + Tgt_Node := HT_Ops.First (Target); + + while Tgt_Node /= null loop + + if Is_In (Source, Tgt_Node) then + + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + else + + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + + end if; + + end loop; + + end Difference; + + + + function Difference (Left, Right : Set) return Set is + + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Left.Length = 0 then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; + + Length := 0; + + declare + procedure Process (L_Node : Node_Access); + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right, L_Node) then + + declare + I : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; + begin + Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I)); + end; + + Length := Length + 1; + + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Left); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + return (Controlled with Buckets, Length); + + end Difference; + + + + procedure Symmetric_Difference (Target : in out Set; + Source : in Set) is + begin + + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length); + + if Target.Length = 0 then + + declare + procedure Process (Src_Node : Node_Access); + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element; + B : Buckets_Type renames Target.Buckets.all; + I : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.Length; + begin + B (I) := new Node_Type'(E, B (I)); + N := N + 1; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Source); + end; + + else + + declare + procedure Process (Src_Node : Node_Access); + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element; + B : Buckets_Type renames Target.Buckets.all; + I : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Target.Length; + begin + if B (I) = null then + + B (I) := new Node_Type'(E, null); + N := N + 1; + + elsif Equivalent_Keys (E, B (I).Element) then + + declare + X : Node_Access := B (I); + begin + B (I) := B (I).Next; + N := N - 1; + Free (X); + end; + + else + + declare + Prev : Node_Access := B (I); + Curr : Node_Access := Prev.Next; + begin + while Curr /= null loop + if Equivalent_Keys (E, Curr.Element) then + Prev.Next := Curr.Next; + N := N - 1; + Free (Curr); + return; + end if; + + Prev := Curr; + Curr := Prev.Next; + end loop; + + B (I) := new Node_Type'(E, B (I)); + N := N + 1; + end; + + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Source); + end; + + end if; + + end Symmetric_Difference; + + + function Symmetric_Difference (Left, Right : Set) return Set is + + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := new Buckets_Type (0 .. Size - 1); + end; + + Length := 0; + + declare + procedure Process (L_Node : Node_Access); + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right, L_Node) then + declare + E : Element_Type renames L_Node.Element; + I : constant Hash_Type := Hash (E) mod Buckets'Length; + begin + Buckets (I) := new Node_Type'(E, Buckets (I)); + Length := Length + 1; + end; + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Left); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + declare + procedure Process (R_Node : Node_Access); + + procedure Process (R_Node : Node_Access) is + begin + if not Is_In (Left, R_Node) then + declare + E : Element_Type renames R_Node.Element; + I : constant Hash_Type := Hash (E) mod Buckets'Length; + begin + Buckets (I) := new Node_Type'(E, Buckets (I)); + Length := Length + 1; + end; + end if; + end Process; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + begin + Iterate (Right); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end; + + return (Controlled with Buckets, Length); + + end Symmetric_Difference; + + + function Is_Subset (Subset : Set; + Of_Set : Set) return Boolean is + + Subset_Node : Node_Access; + + begin + + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + -- TODO: rewrite this to loop in the + -- style of a passive iterator. + + Subset_Node := HT_Ops.First (Subset); + + while Subset_Node /= null loop + if not Is_In (Of_Set, Subset_Node) then + return False; + end if; + + Subset_Node := HT_Ops.Next (Subset, Subset_Node); + end loop; + + return True; + + end Is_Subset; + + + function Overlap (Left, Right : Set) return Boolean is + + Left_Node : Node_Access; + + begin + + if Right.Length = 0 then + return False; + end if; + + if Left'Address = Right'Address then + return True; + end if; + + Left_Node := HT_Ops.First (Left); + + while Left_Node /= null loop + if Is_In (Right, Left_Node) then + return True; + end if; + + Left_Node := HT_Ops.Next (Left, Left_Node); + end loop; + + return False; + + end Overlap; + + + function Find (Container : Set; + Item : Element_Type) return Cursor is + + Node : constant Node_Access := Element_Keys.Find (Container, Item); + + begin + + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + + end Find; + + + function Contains (Container : Set; + Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + + + function First (Container : Set) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end First; + + +-- function First_Element (Container : Set) return Element_Type is +-- Node : constant Node_Access := HT_Ops.First (Container); +-- begin +-- return Node.Element; +-- end First_Element; + + + function Next (Position : Cursor) return Cursor is + begin + if Position.Container = null + or else Position.Node = null + then + return No_Element; + end if; + + declare + S : Set renames Position.Container.all; + Node : constant Node_Access := HT_Ops.Next (S, Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; + + if Position.Node = null then + return False; + end if; + + return True; + end Has_Element; + + + function Equivalent_Keys (Left, Right : Cursor) + return Boolean is + begin + return Equivalent_Keys (Left.Node.Element, Right.Node.Element); + end Equivalent_Keys; + + + function Equivalent_Keys (Left : Cursor; + Right : Element_Type) + return Boolean is + begin + return Equivalent_Keys (Left.Node.Element, Right); + end Equivalent_Keys; + + + function Equivalent_Keys (Left : Element_Type; + Right : Cursor) + return Boolean is + begin + return Equivalent_Keys (Left, Right.Node.Element); + end Equivalent_Keys; + + + procedure Iterate + (Container : in Set; + Process : not null access procedure (Position : in Cursor)) is + + procedure Process_Node (Node : in Node_Access); + pragma Inline (Process_Node); + + procedure Process_Node (Node : in Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process_Node); + begin + Iterate (Container); + end Iterate; + + + function Capacity (Container : Set) return Count_Type + renames HT_Ops.Capacity; + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : in Count_Type) + renames HT_Ops.Ensure_Capacity; + + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : in Node_Access); + pragma Inline (Write_Node); + + procedure Write_Node + (Stream : access Root_Stream_Type'Class; + Node : in Node_Access) is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : in Set) renames Write_Nodes; + + + function Read_Node (Stream : access Root_Stream_Type'Class) + return Node_Access; + pragma Inline (Read_Node); + + function Read_Node (Stream : access Root_Stream_Type'Class) + return Node_Access is + + Node : Node_Access := new Node_Type; + begin + Element_Type'Read (Stream, Node.Element); + return Node; + exception + when others => + Free (Node); + raise; + end Read_Node; + + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set) renames Read_Nodes; + + + package body Generic_Keys is + + function Equivalent_Keys (Left : Cursor; + Right : Key_Type) + return Boolean is + begin + return Equivalent_Keys (Right, Left.Node.Element); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Key_Type; + Right : Cursor) + return Boolean is + begin + return Equivalent_Keys (Left, Right.Node.Element); + end Equivalent_Keys; + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean is + begin + return Equivalent_Keys (Key, Node.Element); + end Equivalent_Keys; + + package Key_Keys is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + HT_Type => Set, + Null_Node => null, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + + function Find (Container : Set; + Key : Key_Type) + return Cursor is + + Node : constant Node_Access := + Key_Keys.Find (Container, Key); + + begin + + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + + end Find; + + + function Contains (Container : Set; + Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + + function Element (Container : Set; + Key : Key_Type) + return Element_Type is + + Node : constant Node_Access := Key_Keys.Find (Container, Key); + begin + return Node.Element; + end Element; + + + function Key (Position : Cursor) return Key_Type is + begin + return Key (Position.Node.Element); + end Key; + + +-- TODO: +-- procedure Replace (Container : in out Set; +-- Key : in Key_Type; +-- New_Item : in Element_Type) is + +-- Node : constant Node_Access := +-- Key_Keys.Find (Container, Key); + +-- begin + +-- if Node = null then +-- raise Constraint_Error; +-- end if; + +-- Replace_Element (Container, Node, New_Item); + +-- end Replace; + + + procedure Delete (Container : in out Set; + Key : in Key_Type) is + + X : Node_Access; + + begin + + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + + if X = null then + raise Constraint_Error; + end if; + + Free (X); + + end Delete; + + + procedure Exclude (Container : in out Set; + Key : in Key_Type) is + + X : Node_Access; + + begin + + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + Free (X); + + end Exclude; + + + procedure Checked_Update_Element + (Container : in out Set; + Position : in Cursor; + Process : not null access + procedure (Element : in out Element_Type)) is + + begin + + if Position.Container = null then + raise Constraint_Error; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + declare + Old_Key : Key_Type renames Key (Position.Node.Element); + begin + Process (Position.Node.Element); + + if Equivalent_Keys (Old_Key, Position.Node.Element) then + return; + end if; + end; + + declare + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + function New_Node (Next : Node_Access) return Node_Access is + begin + Position.Node.Next := Next; + return Position.Node; + end New_Node; + + procedure Insert is + new Key_Keys.Generic_Conditional_Insert (New_Node); + + Result : Node_Access; + Success : Boolean; + begin + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + + Insert + (HT => Container, + Key => Key (Position.Node.Element), + Node => Result, + Success => Success); + + if not Success then + declare + X : Node_Access := Position.Node; + begin + Free (X); + end; + + raise Program_Error; + end if; + + pragma Assert (Result = Position.Node); + end; + + end Checked_Update_Element; + + end Generic_Keys; + +end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads new file mode 100644 index 00000000000..9f0cdc38747 --- /dev/null +++ b/gcc/ada/a-cohase.ads @@ -0,0 +1,255 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASHED_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables; +with Ada.Streams; + +generic + type Element_Type is private; + + with function Hash (Element : Element_Type) return Hash_Type; + + -- TODO: get a ruling from ARG in Atlanta re the name and + -- order of these declarations. ??? + -- + with function Equivalent_Keys (Left, Right : Element_Type) return Boolean; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Hashed_Sets is +pragma Preelaborate (Hashed_Sets); + + type Set is tagged private; + + type Cursor is private; + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + -- TODO: resolve in atlanta + -- procedure Replace_Element + -- (Container : in out Set; + -- Position : Cursor; + -- By : Element_Type); + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert (Container : in out Set; New_Item : Element_Type); + + procedure Include (Container : in out Set; New_Item : Element_Type); + + procedure Replace (Container : in out Set; New_Item : Element_Type); + + procedure Delete (Container : in out Set; Item : Element_Type); + + procedure Exclude (Container : in out Set; Item : Element_Type); + + procedure Delete (Container : in out Set; Position : in out Cursor); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set + renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Find + (Container : Set; + Item : Element_Type) return Cursor; + + function Capacity (Container : Set) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type); + + function First (Container : Set) return Cursor; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function Equivalent_Keys (Left, Right : Cursor) return Boolean; + + function Equivalent_Keys + (Left : Cursor; + Right : Element_Type) return Boolean; + + function Equivalent_Keys + (Left : Element_Type; + Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + generic + type Key_Type (<>) is limited private; + + with function Key (Element : Element_Type) return Key_Type; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys + (Key : Key_Type; + Element : Element_Type) return Boolean; + + package Generic_Keys is + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + -- TODO: resolve in atlanta + -- procedure Replace + -- (Container : in out Set; + -- Key : Key_Type; + -- New_Item : Element_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + -- TODO: resolve name in atlanta: ??? + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + function Equivalent_Keys + (Left : Cursor; + Right : Key_Type) return Boolean; + + function Equivalent_Keys + (Left : Key_Type; + Right : Cursor) return Boolean; + + end Generic_Keys; + +private + + type Node_Type; + type Node_Access is access Node_Type; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Access); + + use HT_Types; + + type Set is new Hash_Table_Type with null record; + + procedure Adjust (Container : in out Set); + + procedure Finalize (Container : in out Set); + + type Set_Access is access constant Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := (Container => null, Node => null); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := (Hash_Table_Type with null record); + +end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-cohata.ads b/gcc/ada/a-cohata.ads new file mode 100644 index 00000000000..068efc6a2a8 --- /dev/null +++ b/gcc/ada/a-cohata.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; + +package Ada.Containers.Hash_Tables is +pragma Preelaborate; + + generic + type Node_Access is private; + + package Generic_Hash_Table_Types is + type Buckets_Type is array (Hash_Type range <>) of Node_Access; + + type Buckets_Access is access Buckets_Type; + + type Hash_Table_Type is new Ada.Finalization.Controlled with record + Buckets : Buckets_Access; + Length : Count_Type := 0; + end record; + end Generic_Hash_Table_Types; + +end Ada.Containers.Hash_Tables; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb new file mode 100644 index 00000000000..c997430f6f0 --- /dev/null +++ b/gcc/ada/a-coinve.adb @@ -0,0 +1,2171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_VECTORS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit has originally being developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with Ada.Unchecked_Deallocation; +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Vectors is + + + type Int is range System.Min_Int .. System.Max_Int; + + procedure Free is + new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + + procedure Adjust (Container : in out Vector) is + begin + + if Container.Elements = null then + return; + end if; + + if Container.Elements'Length = 0 + or else Container.Last < Index_Type'First + then + Container.Elements := null; + return; + end if; + + declare + E : Elements_Type renames Container.Elements.all; + L : constant Index_Type := Container.Last; + begin + + Container.Elements := null; + Container.Last := Index_Type'Pred (Index_Type'First); + + Container.Elements := new Elements_Type (Index_Type'First .. L); + + for I in Container.Elements'Range loop + + if E (I) /= null then + Container.Elements (I) := new Element_Type'(E (I).all); + end if; + + Container.Last := I; + + end loop; + + end; + + end Adjust; + + + procedure Finalize (Container : in out Vector) is + + E : Elements_Access := Container.Elements; + L : constant Index_Type'Base := Container.Last; + + begin + + Container.Elements := null; + Container.Last := Index_Type'Pred (Index_Type'First); + + for I in Index_Type'First .. L loop + Free (E (I)); + end loop; + + Free (E); + + end Finalize; + + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : in Vector) is + + N : constant Count_Type := Length (Container); + + begin + + Count_Type'Base'Write (Stream, N); + + if N = 0 then + return; + end if; + + declare + E : Elements_Type renames Container.Elements.all; + begin + for I in Index_Type'First .. Container.Last loop + + -- There's another way to do this. Instead a separate + -- Boolean for each element, you could write a Boolean + -- followed by a count of how many nulls or non-nulls + -- follow in the array. Alternately you could use a + -- signed integer, and use the sign as the indicator + -- or null-ness. + + if E (I) = null then + Boolean'Write (Stream, False); + else + Boolean'Write (Stream, True); + Element_Type'Output (Stream, E (I).all); + end if; + + end loop; + end; + + end Write; + + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Vector) is + + Length : Count_Type'Base; + Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); + + B : Boolean; + + begin + + Clear (Container); + + Count_Type'Base'Read (Stream, Length); + + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; + + for I in Count_Type range 1 .. Length loop + + Last := Index_Type'Succ (Last); + + Boolean'Read (Stream, B); + + if B then + Container.Elements (Last) := + new Element_Type'(Element_Type'Input (Stream)); + end if; + + Container.Last := Last; + + end loop; + + end Read; + + + function To_Vector (Length : Count_Type) return Vector is + begin + + if Length = 0 then + return Empty_Vector; + end if; + + declare + + First : constant Int := Int (Index_Type'First); + + Last_As_Int : constant Int'Base := + First + Int (Length) - 1; + + Last : constant Index_Type := + Index_Type (Last_As_Int); + + Elements : constant Elements_Access := + new Elements_Type (Index_Type'First .. Last); + + begin + + return (Controlled with Elements, Last); + + end; + + end To_Vector; + + + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector is + + begin + + if Length = 0 then + return Empty_Vector; + end if; + + declare + + First : constant Int := Int (Index_Type'First); + + Last_As_Int : constant Int'Base := + First + Int (Length) - 1; + + Last : constant Index_Type := + Index_Type (Last_As_Int); + + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); + + begin + + for I in Elements'Range loop + + begin + Elements (I) := new Element_Type'(New_Item); + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + + Free (Elements); + raise; + end; + + end loop; + + return (Controlled with Elements, Last); + + end; + + end To_Vector; + + + function "=" (Left, Right : Vector) return Boolean is + begin + + if Left'Address = Right'Address then + return True; + end if; + + if Left.Last /= Right.Last then + return False; + end if; + + for I in Index_Type'First .. Left.Last loop + + -- NOTE: + -- I think it's a bounded error to read or otherwise manipulate + -- an "empty" element, which here means that it has the value + -- null. If it's a bounded error then an exception might + -- propagate, or it might not. We take advantage of that + -- permission here to allow empty elements to be compared. + -- + -- Whether this is the right decision I'm not really sure. If + -- you have a contrary argument then let me know. + -- END NOTE. + + if Left.Elements (I) = null then + + if Right.Elements (I) /= null then + return False; + end if; + + elsif Right.Elements (I) = null then + + return False; + + elsif Left.Elements (I).all /= Right.Elements (I).all then + + return False; + + end if; + + end loop; + + return True; + + end "="; + + + function Length (Container : Vector) return Count_Type is + + L : constant Int := Int (Container.Last); + F : constant Int := Int (Index_Type'First); + + N : constant Int'Base := L - F + 1; + begin + return Count_Type (N); + end Length; + + + function Is_Empty (Container : Vector) return Boolean is + begin + return Container.Last < Index_Type'First; + end Is_Empty; + + + procedure Set_Length + (Container : in out Vector; + Length : in Count_Type) is + + N : constant Count_Type := Indefinite_Vectors.Length (Container); + + begin + + if Length = N then + return; + end if; + + if Length = 0 then + Clear (Container); + return; + end if; + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Length) - 1; + + Last : constant Index_Type := + Index_Type (Last_As_Int); + begin + + if Length > N then + + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; + + Container.Last := Last; + + return; + + end if; + + for I in reverse Index_Type'Succ (Last) .. Container.Last loop + + declare + X : Element_Access := Container.Elements (I); + begin + Container.Elements (I) := null; + Container.Last := Index_Type'Pred (Container.Last); + Free (X); + end; + + end loop; + + end; + + end Set_Length; + + + procedure Clear (Container : in out Vector) is + begin + + for I in reverse Index_Type'First .. Container.Last loop + + declare + X : Element_Access := Container.Elements (I); + begin + Container.Elements (I) := null; + Container.Last := Index_Type'Pred (I); + Free (X); + end; + + end loop; + + end Clear; + + + procedure Append (Container : in out Vector; + New_Item : in Element_Type; + Count : in Count_Type := 1) is + begin + if Count = 0 then + return; + end if; + + Insert + (Container, + Index_Type'Succ (Container.Last), + New_Item, + Count); + end Append; + + + procedure Insert + (Container : in out Vector; + Before : in Extended_Index; + New_Item : in Element_Type; + Count : in Count_Type := 1) is + + Old_Last_As_Int : constant Int := Int (Container.Last); + + N : constant Int := Int (Count); + + New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; + + New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + + Index : Index_Type; + + Dst_Last : Index_Type; + Dst : Elements_Access; + + begin + + if Count = 0 then + return; + end if; + + declare + subtype Before_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Succ (Container.Last); + + Old_First : constant Before_Subtype := Before; + + Old_First_As_Int : constant Int := Int (Old_First); + + New_First_As_Int : constant Int'Base := Old_First_As_Int + N; + begin + Index := Index_Type (New_First_As_Int); + end; + + if Container.Elements = null then + + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. New_Last); + begin + Container.Elements := new Elements_Subtype; + Container.Last := Index_Type'Pred (Index_Type'First); + + for I in Container.Elements'Range loop + Container.Elements (I) := new Element_Type'(New_Item); + Container.Last := I; + end loop; + end; + + return; + + end if; + + if New_Last <= Container.Elements'Last then + + declare + E : Elements_Type renames Container.Elements.all; + begin + E (Index .. New_Last) := E (Before .. Container.Last); + Container.Last := New_Last; + + -- NOTE: + -- Now we do the allocation. If it fails, we can propagate the + -- exception and invariants are more or less satisfied. The + -- issue is that we have some slots still null, and the client + -- has no way of detecting whether the slot is null (unless we + -- give him a way). + -- + -- Another way is to allocate a subarray on the stack, do the + -- allocation into that array, and if that success then do + -- the insertion proper. The issue there is that you have to + -- allocate the subarray on the stack, and that may fail if the + -- subarray is long. + -- + -- Or we could try to roll-back the changes: deallocate the + -- elements we have successfully deallocated, and then copy + -- the elements ptrs back to their original posns. + -- END NOTE. + + -- NOTE: I have written the loop manually here. I could + -- have done it this way too: + -- E (Before .. Index_Type'Pred (Index)) := + -- (others => new Element_Type'New_Item); + -- END NOTE. + + for I in Before .. Index_Type'Pred (Index) loop + + begin + E (I) := new Element_Type'(New_Item); + exception + when others => + E (I .. Index_Type'Pred (Index)) := (others => null); + raise; + end; + + end loop; + end; + + return; + + end if; + + declare + + First : constant Int := Int (Index_Type'First); + + New_Size : constant Int'Base := + New_Last_As_Int - First + 1; + + Max_Size : constant Int'Base := + Int (Index_Type'Last) - First + 1; + + Size, Dst_Last_As_Int : Int'Base; + + begin + + if New_Size >= Max_Size / 2 then + + Dst_Last := Index_Type'Last; + + else + + Size := Container.Elements'Length; + + if Size = 0 then + Size := 1; + end if; + + while Size < New_Size loop + Size := 2 * Size; + end loop; + + Dst_Last_As_Int := First + Size - 1; + Dst_Last := Index_Type (Dst_Last_As_Int); + + end if; + + end; + + Dst := new Elements_Type (Index_Type'First .. Dst_Last); + + declare + Src : Elements_Type renames Container.Elements.all; + begin + Dst (Index_Type'First .. Index_Type'Pred (Before)) := + Src (Index_Type'First .. Index_Type'Pred (Before)); + + Dst (Index .. New_Last) := Src (Before .. Container.Last); + end; + + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := Dst; + Container.Last := New_Last; + + Free (X); + end; + + -- NOTE: + -- Now do the allocation. If the allocation fails, + -- then the worst thing is that we have a few null slots. + -- Our invariants are otherwise satisfied. + -- END NOTE. + + for I in Before .. Index_Type'Pred (Index) loop + Dst (I) := new Element_Type'(New_Item); + end loop; + + end Insert; + + + procedure Insert_Space + (Container : in out Vector; + Before : in Extended_Index; + Count : in Count_Type := 1) is + + Old_Last_As_Int : constant Int := Int (Container.Last); + + N : constant Int := Int (Count); + + New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; + + New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + + Index : Index_Type; + + Dst_Last : Index_Type; + Dst : Elements_Access; + + begin + + if Count = 0 then + return; + end if; + + declare + subtype Before_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Succ (Container.Last); + + Old_First : constant Before_Subtype := Before; + + Old_First_As_Int : constant Int := Int (Old_First); + + New_First_As_Int : constant Int'Base := Old_First_As_Int + N; + begin + Index := Index_Type (New_First_As_Int); + end; + + if Container.Elements = null then + + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. New_Last); + begin + Container.Elements := new Elements_Subtype; + Container.Last := New_Last; + end; + + return; + + end if; + + if New_Last <= Container.Elements'Last then + + declare + E : Elements_Type renames Container.Elements.all; + begin + E (Index .. New_Last) := E (Before .. Container.Last); + E (Before .. Index_Type'Pred (Index)) := (others => null); + + Container.Last := New_Last; + end; + + return; + + end if; + + declare + + First : constant Int := Int (Index_Type'First); + + New_Size : constant Int'Base := + Int (New_Last_As_Int) - First + 1; + + Max_Size : constant Int'Base := + Int (Index_Type'Last) - First + 1; + + Size, Dst_Last_As_Int : Int'Base; + + begin + + if New_Size >= Max_Size / 2 then + + Dst_Last := Index_Type'Last; + + else + + Size := Container.Elements'Length; + + if Size = 0 then + Size := 1; + end if; + + while Size < New_Size loop + Size := 2 * Size; + end loop; + + Dst_Last_As_Int := First + Size - 1; + Dst_Last := Index_Type (Dst_Last_As_Int); + + end if; + + end; + + Dst := new Elements_Type (Index_Type'First .. Dst_Last); + + declare + Src : Elements_Type renames Container.Elements.all; + begin + Dst (Index_Type'First .. Index_Type'Pred (Before)) := + Src (Index_Type'First .. Index_Type'Pred (Before)); + + Dst (Index .. New_Last) := Src (Before .. Container.Last); + end; + + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := Dst; + Container.Last := New_Last; + + Free (X); + end; + + end Insert_Space; + + + procedure Delete_First (Container : in out Vector; + Count : in Count_Type := 1) is + begin + + if Count = 0 then + return; + end if; + + if Count >= Length (Container) then + Clear (Container); + return; + end if; + + Delete (Container, Index_Type'First, Count); + + end Delete_First; + + + procedure Delete_Last (Container : in out Vector; + Count : in Count_Type := 1) is + + Index : Int'Base; + + begin + + if Count = 0 then + return; + end if; + + if Count >= Length (Container) then + Clear (Container); + return; + end if; + + Index := Int'Base (Container.Last) - Int'Base (Count) + 1; + + Delete (Container, Index_Type'Base (Index), Count); + + end Delete_Last; + + + procedure Delete + (Container : in out Vector; + Index : in Extended_Index; -- TODO: verify in Atlanta + Count : in Count_Type := 1) is + + begin + + if Count = 0 then + return; + end if; + + declare + + subtype I_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + I : constant I_Subtype := Index; + I_As_Int : constant Int := Int (I); + + Old_Last_As_Int : constant Int := Int (Container.Last); + + Count1 : constant Int'Base := Int (Count); + Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; + + N : constant Int'Base := Int'Min (Count1, Count2); + + J_As_Int : constant Int'Base := I_As_Int + N; + J : constant Index_Type'Base := Index_Type'Base (J_As_Int); + + E : Elements_Type renames Container.Elements.all; + + New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; + + New_Last : constant Extended_Index := + Extended_Index (New_Last_As_Int); + + begin + + for K in I .. Index_Type'Pred (J) loop + + begin + Free (E (K)); + exception + when others => + E (K) := null; + raise; + end; + + end loop; + + E (I .. New_Last) := E (J .. Container.Last); + Container.Last := New_Last; + + end; + + end Delete; + + + function Capacity (Container : Vector) return Count_Type is + begin + if Container.Elements = null then + return 0; + end if; + + return Container.Elements'Length; + end Capacity; + + + procedure Reserve_Capacity (Container : in out Vector; + Capacity : in Count_Type) is + + N : constant Count_Type := Length (Container); + + begin + + if Capacity = 0 then + + if N = 0 then + + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := null; + Free (X); + end; + + elsif N < Container.Elements'Length then + + declare + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Type renames + Container.Elements (Array_Index_Subtype); + + subtype Array_Subtype is + Elements_Type (Array_Index_Subtype); + + X : Elements_Access := Container.Elements; + begin + Container.Elements := new Array_Subtype'(Src); + Free (X); + end; + + end if; + + return; + + end if; + + if Container.Elements = null then + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Capacity) - 1; + + Last : constant Index_Type := + Index_Type (Last_As_Int); + + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); + begin + Container.Elements := new Array_Subtype; + end; + + return; + + end if; + + if Capacity <= N then + + if N < Container.Elements'Length then + + declare + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Type renames + Container.Elements (Array_Index_Subtype); + + subtype Array_Subtype is + Elements_Type (Array_Index_Subtype); + + X : Elements_Access := Container.Elements; + begin + Container.Elements := new Array_Subtype'(Src); + Free (X); + end; + + end if; + + return; + + end if; + + if Capacity = Container.Elements'Length then + return; + end if; + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Capacity) - 1; + + Last : constant Index_Type := + Index_Type (Last_As_Int); + + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); + + X : Elements_Access := Container.Elements; + begin + Container.Elements := new Array_Subtype; + + declare + Src : Elements_Type renames + X (Index_Type'First .. Container.Last); + + Tgt : Elements_Type renames + Container.Elements (Index_Type'First .. Container.Last); + begin + Tgt := Src; + end; + + Free (X); + end; + + end Reserve_Capacity; + + + function First_Index (Container : Vector) return Index_Type is + pragma Warnings (Off, Container); + begin + return Index_Type'First; + end First_Index; + + + function First_Element (Container : Vector) return Element_Type is + begin + return Element (Container, Index_Type'First); + end First_Element; + + + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + + + function Last_Element (Container : Vector) return Element_Type is + begin + return Element (Container, Container.Last); + end Last_Element; + + + function Element (Container : Vector; + Index : Index_Type) + return Element_Type is + + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + return Container.Elements (T'(Index)).all; + end Element; + + + procedure Replace_Element (Container : in Vector; + Index : in Index_Type; + By : in Element_Type) is + + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + + X : Element_Access := Container.Elements (T'(Index)); + begin + Container.Elements (T'(Index)) := new Element_Type'(By); + Free (X); + end Replace_Element; + + + procedure Generic_Sort (Container : in Vector) is + + function Is_Less (L, R : Element_Access) return Boolean; + pragma Inline (Is_Less); + + function Is_Less (L, R : Element_Access) return Boolean is + begin + if L = null then + return R /= null; + elsif R = null then + return False; + else + return L.all < R.all; + end if; + end Is_Less; + + procedure Sort is + new Generic_Array_Sort + (Index_Type, + Element_Access, + Elements_Type, + "<" => Is_Less); + + begin + + if Container.Elements = null then + return; + end if; + + Sort (Container.Elements (Index_Type'First .. Container.Last)); + + end Generic_Sort; + + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) + return Extended_Index is + + begin + + for I in Index .. Container.Last loop + if Container.Elements (I) /= null + and then Container.Elements (I).all = Item + then + return I; + end if; + end loop; + + return No_Index; + + end Find_Index; + + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) + return Extended_Index is + + Last : Index_Type'Base; + + begin + + if Index > Container.Last then + Last := Container.Last; + else + Last := Index; + end if; + + for I in reverse Index_Type'First .. Last loop + if Container.Elements (I) /= null + and then Container.Elements (I).all = Item + then + return I; + end if; + end loop; + + return No_Index; + + end Reverse_Find_Index; + + + function Contains (Container : Vector; + Item : Element_Type) return Boolean is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + + + procedure Assign + (Target : in out Vector; + Source : in Vector) is + + N : constant Count_Type := Length (Source); + + begin + + if Target'Address = Source'Address then + return; + end if; + + Clear (Target); + + if N = 0 then + return; + end if; + + if N > Capacity (Target) then + Reserve_Capacity (Target, Capacity => N); + end if; + + for I in Index_Type'First .. Source.Last loop + + declare + EA : constant Element_Access := Source.Elements (I); + begin + if EA /= null then + Target.Elements (I) := new Element_Type'(EA.all); + end if; + end; + + Target.Last := I; + + end loop; + + end Assign; + + + procedure Move + (Target : in out Vector; + Source : in out Vector) is + + X : Elements_Access := Target.Elements; + + begin + + if Target'Address = Source'Address then + return; + end if; + + if Target.Last >= Index_Type'First then + raise Constraint_Error; + end if; + + Target.Elements := null; + Free (X); -- shouldn't fail + + Target.Elements := Source.Elements; + Target.Last := Source.Last; + + Source.Elements := null; + Source.Last := Index_Type'Pred (Index_Type'First); + + end Move; + + + procedure Query_Element + (Container : in Vector; + Index : in Index_Type; + Process : not null access procedure (Element : in Element_Type)) is + + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + Process (Container.Elements (T'(Index)).all); + end Query_Element; + + + procedure Update_Element + (Container : in Vector; + Index : in Index_Type; + Process : not null access procedure (Element : in out Element_Type)) is + + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + Process (Container.Elements (T'(Index)).all); + end Update_Element; + + + procedure Prepend (Container : in out Vector; + New_Item : in Element_Type; + Count : in Count_Type := 1) is + begin + Insert (Container, + Index_Type'First, + New_Item, + Count); + end Prepend; + + + procedure Swap + (Container : in Vector; + I, J : in Index_Type) is + + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + + EI : constant Element_Access := Container.Elements (T'(I)); + + begin + + Container.Elements (T'(I)) := Container.Elements (T'(J)); + Container.Elements (T'(J)) := EI; + + end Swap; + + + function "&" (Left, Right : Vector) return Vector is + + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + + begin + + if LN = 0 then + + if RN = 0 then + return Empty_Vector; + end if; + + declare + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); + + Elements : Elements_Access := + new Elements_Type (RE'Range); + begin + for I in Elements'Range loop + begin + if RE (I) /= null then + Elements (I) := new Element_Type'(RE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + return (Controlled with Elements, Right.Last); + end; + + end if; + + if RN = 0 then + + declare + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); + + Elements : Elements_Access := + new Elements_Type (LE'Range); + begin + for I in Elements'Range loop + begin + if LE (I) /= null then + Elements (I) := new Element_Type'(LE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + + Free (Elements); + raise; + end; + end loop; + + return (Controlled with Elements, Left.Last); + end; + + end if; + + declare + + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (LN) + Int (RN) - 1; + + Last : constant Index_Type := Index_Type (Last_As_Int); + + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); + + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); + + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); + + I : Index_Type'Base := Index_Type'Pred (Index_Type'First); + + begin + + for LI in LE'Range loop + + I := Index_Type'Succ (I); + + begin + if LE (LI) /= null then + Elements (I) := new Element_Type'(LE (LI).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + + Free (Elements); + raise; + end; + + end loop; + + for RI in RE'Range loop + + I := Index_Type'Succ (I); + + begin + if RE (RI) /= null then + Elements (I) := new Element_Type'(RE (RI).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + + Free (Elements); + raise; + end; + + end loop; + + return (Controlled with Elements, Last); + end; + + end "&"; + + + function "&" (Left : Vector; + Right : Element_Type) return Vector is + + LN : constant Count_Type := Length (Left); + + begin + + if LN = 0 then + + declare + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Index_Type'First); + begin + + begin + Elements (Elements'First) := new Element_Type'(Right); + exception + when others => + Free (Elements); + raise; + end; + + return (Controlled with Elements, Index_Type'First); + + end; + + end if; + + declare + + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (LN); + + Last : constant Index_Type := Index_Type (Last_As_Int); + + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); + + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); + + begin + + for I in LE'Range loop + + begin + if LE (I) /= null then + Elements (I) := new Element_Type'(LE (I).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + + Free (Elements); + raise; + end; + + end loop; + + begin + Elements (Elements'Last) := new Element_Type'(Right); + exception + when others => + + declare + subtype J_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Pred (Elements'Last); + begin + for J in J_Subtype loop + Free (Elements (J)); + end loop; + end; + + Free (Elements); + raise; + end; + + return (Controlled with Elements, Last); + end; + + end "&"; + + + + function "&" (Left : Element_Type; + Right : Vector) return Vector is + + RN : constant Count_Type := Length (Right); + + begin + + if RN = 0 then + + declare + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Index_Type'First); + begin + + begin + Elements (Elements'First) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; + + return (Controlled with Elements, Index_Type'First); + + end; + + end if; + + declare + + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (RN); + + Last : constant Index_Type := Index_Type (Last_As_Int); + + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); + + Elements : Elements_Access := + new Elements_Type (Index_Type'First .. Last); + + I : Index_Type'Base := Index_Type'First; + + begin + + begin + Elements (I) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; + + for RI in RE'Range loop + + I := Index_Type'Succ (I); + + begin + if RE (RI) /= null then + Elements (I) := new Element_Type'(RE (RI).all); + end if; + exception + when others => + for J in Index_Type'First .. Index_Type'Pred (I) loop + Free (Elements (J)); + end loop; + + Free (Elements); + raise; + end; + + end loop; + + return (Controlled with Elements, Last); + end; + + end "&"; + + + function "&" (Left, Right : Element_Type) return Vector is + + subtype IT is Index_Type'Base range + Index_Type'First .. Index_Type'Succ (Index_Type'First); + + Elements : Elements_Access := new Elements_Type (IT); + + begin + + begin + Elements (Elements'First) := new Element_Type'(Left); + exception + when others => + Free (Elements); + raise; + end; + + begin + Elements (Elements'Last) := new Element_Type'(Right); + exception + when others => + Free (Elements (Elements'First)); + Free (Elements); + raise; + end; + + return (Controlled with Elements, Elements'Last); + + end "&"; + + + function To_Cursor (Container : Vector; + Index : Extended_Index) + return Cursor is + begin + if Index not in Index_Type'First .. Container.Last then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Index); + end To_Cursor; + + + function To_Index (Position : Cursor) return Extended_Index is + begin + if Position.Container = null then + return No_Index; + end if; + + if Position.Index <= Position.Container.Last then + return Position.Index; + end if; + + return No_Index; + end To_Index; + + + function Element (Position : Cursor) return Element_Type is + begin + return Element (Position.Container.all, Position.Index); + end Element; + + + function Next (Position : Cursor) return Cursor is + begin + + if Position.Container = null then + return No_Element; + end if; + + if Position.Index < Position.Container.Last then + return (Position.Container, Index_Type'Succ (Position.Index)); + end if; + + return No_Element; + + end Next; + + + function Previous (Position : Cursor) return Cursor is + begin + + if Position.Container = null then + return No_Element; + end if; + + if Position.Index > Index_Type'First then + return (Position.Container, Index_Type'Pred (Position.Index)); + end if; + + return No_Element; + + end Previous; + + + procedure Next (Position : in out Cursor) is + begin + + if Position.Container = null then + return; + end if; + + if Position.Index < Position.Container.Last then + Position.Index := Index_Type'Succ (Position.Index); + else + Position := No_Element; + end if; + + end Next; + + + procedure Previous (Position : in out Cursor) is + begin + + if Position.Container = null then + return; + end if; + + if Position.Index > Index_Type'First then + Position.Index := Index_Type'Pred (Position.Index); + else + Position := No_Element; + end if; + + end Previous; + + + function Has_Element (Position : Cursor) return Boolean is + begin + + if Position.Container = null then + return False; + end if; + + return Position.Index <= Position.Container.Last; + + end Has_Element; + + + procedure Iterate + (Container : in Vector; + Process : not null access procedure (Position : in Cursor)) is + begin + + for I in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, I)); + end loop; + + end Iterate; + + + procedure Reverse_Iterate + (Container : in Vector; + Process : not null access procedure (Position : in Cursor)) is + begin + + for I in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, I)); + end loop; + + end Reverse_Iterate; + + + procedure Query_Element + (Position : in Cursor; + Process : not null access procedure (Element : in Element_Type)) is + + C : Vector renames Position.Container.all; + E : Elements_Type renames C.Elements.all; + + subtype T is Index_Type'Base range + Index_Type'First .. C.Last; + begin + Process (E (T'(Position.Index)).all); + end Query_Element; + + + procedure Update_Element + (Position : in Cursor; + Process : not null access procedure (Element : in out Element_Type)) is + + C : Vector renames Position.Container.all; + E : Elements_Type renames C.Elements.all; + + subtype T is Index_Type'Base range + Index_Type'First .. C.Last; + begin + Process (E (T'(Position.Index)).all); + end Update_Element; + + + procedure Replace_Element (Position : in Cursor; + By : in Element_Type) is + + C : Vector renames Position.Container.all; + E : Elements_Type renames C.Elements.all; + + subtype T is Index_Type'Base range + Index_Type'First .. C.Last; + + X : Element_Access := E (T'(Position.Index)); + begin + E (T'(Position.Index)) := new Element_Type'(By); + Free (X); + end Replace_Element; + + + procedure Insert (Container : in out Vector; + Before : in Extended_Index; + New_Item : in Vector) is + + N : constant Count_Type := Length (New_Item); + + begin + + if N = 0 then + return; + end if; + + Insert_Space (Container, Before, Count => N); + + if Container'Address = New_Item'Address then + + declare + Dst_Last_As_Int : constant Int'Base := + Int'Base (Before) + Int'Base (N) - 1; + + Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + + Dst_Index : Index_Type'Base := Index_Type'Pred (Before); + + Dst : Elements_Type renames + Container.Elements (Before .. Dst_Last); + begin + + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Pred (Before); + + Src : Elements_Type renames + Container.Elements (Src_Index_Subtype); + begin + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); + + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; + + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'Succ (Dst_Last) .. Container.Last; + + Src : Elements_Type renames + Container.Elements (Src_Index_Subtype); + begin + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); + + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; + + end; + + else + + declare + Dst_Last_As_Int : constant Int'Base := + Int'Base (Before) + Int'Base (N) - 1; + + Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + + Dst_Index : Index_Type'Base := Index_Type'Pred (Before); + + Src : Elements_Type renames + New_Item.Elements (Index_Type'First .. New_Item.Last); + + Dst : Elements_Type renames + Container.Elements (Before .. Dst_Last); + begin + for Src_Index in Src'Range loop + Dst_Index := Index_Type'Succ (Dst_Index); + + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; + + end if; + + end Insert; + + + procedure Insert (Container : in out Vector; + Before : in Cursor; + New_Item : in Vector) is + + Index : Index_Type'Base; + + begin + + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Is_Empty (New_Item) then + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + + end Insert; + + + + procedure Insert (Container : in out Vector; + Before : in Cursor; + New_Item : in Vector; + Position : out Cursor) is + + Index : Index_Type'Base; + + begin + + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Is_Empty (New_Item) then + + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + + Position := (Container'Unchecked_Access, Index); + + end Insert; + + + procedure Insert (Container : in out Vector; + Before : in Cursor; + New_Item : in Element_Type; + Count : in Count_Type := 1) is + + Index : Index_Type'Base; + + begin + + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + + end Insert; + + + procedure Insert (Container : in out Vector; + Before : in Cursor; + New_Item : in Element_Type; + Position : out Cursor; + Count : in Count_Type := 1) is + + Index : Index_Type'Base; + + begin + + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + + Position := (Container'Unchecked_Access, Index); + + end Insert; + + + + procedure Prepend (Container : in out Vector; + New_Item : in Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + + procedure Append (Container : in out Vector; + New_Item : in Vector) is + begin + if Is_Empty (New_Item) then + return; + end if; + + Insert + (Container, + Index_Type'Succ (Container.Last), + New_Item); + end Append; + + + + procedure Insert_Space (Container : in out Vector; + Before : in Cursor; + Position : out Cursor; + Count : in Count_Type := 1) is + + Index : Index_Type'Base; + + begin + + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert_Space (Container, Index, Count); + + Position := (Container'Unchecked_Access, Index); + + end Insert_Space; + + + procedure Delete (Container : in out Vector; + Position : in out Cursor; + Count : in Count_Type := 1) is + begin + + if Position.Container /= null + and then Position.Container /= + Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Position.Container = null + or else Position.Index > Container.Last + then + Position := No_Element; + return; + end if; + + Delete (Container, Position.Index, Count); + + if Position.Index <= Container.Last then + Position := (Container'Unchecked_Access, Position.Index); + else + Position := No_Element; + end if; + + end Delete; + + + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unchecked_Access, Index_Type'First); + end First; + + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unchecked_Access, Container.Last); + end Last; + + + procedure Swap (I, J : in Cursor) is + + -- NOTE: I've liberalized the behavior here, to + -- allow I and J to designate different containers. + -- TODO: I think this is suppose to raise P_E. + + subtype TI is Index_Type'Base range + Index_Type'First .. I.Container.Last; + + EI : Element_Access renames + I.Container.Elements (TI'(I.Index)); + + EI_Copy : constant Element_Access := EI; + + subtype TJ is Index_Type'Base range + Index_Type'First .. J.Container.Last; + + EJ : Element_Access renames + J.Container.Elements (TJ'(J.Index)); + + begin + + EI := EJ; + EJ := EI_Copy; + + end Swap; + + + function Find (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor is + + begin + + if Position.Container /= null + and then Position.Container /= + Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + for I in Position.Index .. Container.Last loop + if Container.Elements (I) /= null + and then Container.Elements (I).all = Item + then + return (Container'Unchecked_Access, I); + end if; + end loop; + + return No_Element; + + end Find; + + + function Reverse_Find (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor is + + Last : Index_Type'Base; + + begin + + if Position.Container /= null + and then Position.Container /= + Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Position.Container = null + or else Position.Index > Container.Last + then + Last := Container.Last; + else + Last := Position.Index; + end if; + + for I in reverse Index_Type'First .. Last loop + if Container.Elements (I) /= null + and then Container.Elements (I).all = Item + then + return (Container'Unchecked_Access, I); + end if; + end loop; + + return No_Element; + + end Reverse_Find; + + +end Ada.Containers.Indefinite_Vectors; + diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads new file mode 100644 index 00000000000..6aa79a4fce4 --- /dev/null +++ b/gcc/ada/a-coinve.ads @@ -0,0 +1,343 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_VECTORS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with Ada.Streams; + +generic + type Index_Type is range <>; + + type Element_Type (<>) is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Vectors is +pragma Preelaborate (Indefinite_Vectors); + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Last + + Boolean'Pos (Index_Type'Base'Last > Index_Type'Last); + + No_Index : constant Extended_Index := Extended_Index'First; + + subtype Index_Subtype is Index_Type; + + type Vector is tagged private; + + type Cursor is private; + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + function To_Vector (Length : Count_Type) return Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector; + + function "&" (Left, Right : Vector) return Vector; + + function "&" (Left : Vector; Right : Element_Type) return Vector; + + function "&" (Left : Element_Type; Right : Vector) return Vector; + + function "&" (Left, Right : Element_Type) return Vector; + + function "=" (Left, Right : Vector) return Boolean; + + function Capacity (Container : Vector) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type); + + function Length (Container : Vector) return Count_Type; + + function Is_Empty (Container : Vector) return Boolean; + + procedure Clear (Container : in out Vector); + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor; + + function To_Index (Position : Cursor) return Extended_Index; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Replace_Element + (Container : Vector; + Index : Index_Type; + By : Element_Type); + + procedure Replace_Element + (Position : Cursor; + By : Element_Type); + + procedure Assign (Target : in out Vector; Source : Vector); + + procedure Move (Target : in out Vector; Source : in out Vector); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Vector); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out Vector; + New_Item : Vector); + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Set_Length + (Container : in out Vector; + Length : Count_Type); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; -- TODO: verify + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1); + + function First_Index (Container : Vector) return Index_Type; + + function First (Container : Vector) return Cursor; + + function First_Element (Container : Vector) return Element_Type; + + function Last_Index (Container : Vector) return Extended_Index; + + function Last (Container : Vector) return Cursor; + + function Last_Element (Container : Vector) return Element_Type; + + procedure Swap (Container : Vector; I, J : Index_Type); + + procedure Swap (I, J : Cursor); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + procedure Generic_Sort (Container : Vector); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index; + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index; + + function Reverse_Find (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) + return Cursor; + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + +private + + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Query_Element); + pragma Inline (Update_Element); + pragma Inline (Replace_Element); + pragma Inline (Contains); + + type Element_Access is access Element_Type; + + type Elements_Type is array (Index_Type range <>) of Element_Access; + + function "=" (L, R : Elements_Type) return Boolean is abstract; + + type Elements_Access is access Elements_Type; + + use Ada.Finalization; + + type Vector is new Controlled with record + Elements : Elements_Access; + Last : Extended_Index := No_Index; + end record; + + procedure Adjust (Container : in out Vector); + + procedure Finalize (Container : in out Vector); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Vector); + + for Vector'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Vector); + + for Vector'Read use Read; + + Empty_Vector : constant Vector := Vector'(Controlled with null, No_Index); + + type Vector_Access is access constant Vector; + for Vector_Access'Storage_Size use 0; + + type Cursor is record + Container : Vector_Access; + Index : Index_Type := Index_Type'First; + end record; + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + +end Ada.Containers.Indefinite_Vectors; + diff --git a/gcc/ada/a-contai.ads b/gcc/ada/a-contai.ads new file mode 100644 index 00000000000..e76f0765bfc --- /dev/null +++ b/gcc/ada/a-contai.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Containers is +pragma Pure (Containers); + + type Hash_Type is mod 2**32; + type Count_Type is range 0 .. 2**31 - 1; + +end Ada.Containers; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb new file mode 100644 index 00000000000..c98c58a3b21 --- /dev/null +++ b/gcc/ada/a-convec.adb @@ -0,0 +1,1741 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.VECTORS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Vectors is + + type Int is range System.Min_Int .. System.Max_Int; + + procedure Free is + new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); + + --------- + -- "&" -- + --------- + + function "&" (Left, Right : Vector) return Vector is + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + + begin + if LN = 0 then + if RN = 0 then + return Empty_Vector; + end if; + + declare + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); + + Elements : constant Elements_Access := + new Elements_Type'(RE); + + begin + return (Controlled with Elements, Right.Last); + end; + end if; + + if RN = 0 then + declare + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); + + Elements : constant Elements_Access := + new Elements_Type'(LE); + + begin + return (Controlled with Elements, Left.Last); + end; + + end if; + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (LN) + Int (RN) - 1; + + Last : constant Index_Type := Index_Type (Last_As_Int); + + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); + + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); + + Elements : constant Elements_Access := + new Elements_Type'(LE & RE); + + begin + return (Controlled with Elements, Last); + end; + end "&"; + + function "&" (Left : Vector; Right : Element_Type) return Vector is + LN : constant Count_Type := Length (Left); + + begin + if LN = 0 then + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. Index_Type'First); + + Elements : constant Elements_Access := + new Elements_Subtype'(others => Right); + + begin + return (Controlled with Elements, Index_Type'First); + end; + end if; + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (LN); + + Last : constant Index_Type := Index_Type (Last_As_Int); + + LE : Elements_Type renames + Left.Elements (Index_Type'First .. Left.Last); + + subtype ET is Elements_Type (Index_Type'First .. Last); + + Elements : constant Elements_Access := new ET'(LE & Right); + + begin + return (Controlled with Elements, Last); + end; + end "&"; + + function "&" (Left : Element_Type; Right : Vector) return Vector is + RN : constant Count_Type := Length (Right); + + begin + if RN = 0 then + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. Index_Type'First); + + Elements : constant Elements_Access := + new Elements_Subtype'(others => Left); + + begin + return (Controlled with Elements, Index_Type'First); + end; + end if; + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (RN); + + Last : constant Index_Type := Index_Type (Last_As_Int); + + RE : Elements_Type renames + Right.Elements (Index_Type'First .. Right.Last); + + subtype ET is Elements_Type (Index_Type'First .. Last); + + Elements : constant Elements_Access := new ET'(Left & RE); + + begin + return (Controlled with Elements, Last); + end; + end "&"; + + function "&" (Left, Right : Element_Type) return Vector is + subtype IT is Index_Type'Base range + Index_Type'First .. Index_Type'Succ (Index_Type'First); + + subtype ET is Elements_Type (IT); + + Elements : constant Elements_Access := new ET'(Left, Right); + + begin + return Vector'(Controlled with Elements, Elements'Last); + end "&"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Vector) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Last /= Right.Last then + return False; + end if; + + for J in Index_Type range Index_Type'First .. Left.Last loop + if Left.Elements (J) /= Right.Elements (J) then + return False; + end if; + end loop; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Vector) is + begin + if Container.Elements = null then + return; + end if; + + if Container.Elements'Length = 0 + or else Container.Last < Index_Type'First + then + Container.Elements := null; + return; + end if; + + declare + X : constant Elements_Access := Container.Elements; + L : constant Index_Type'Base := Container.Last; + E : Elements_Type renames X (Index_Type'First .. L); + begin + Container.Elements := null; + Container.Last := Index_Type'Pred (Index_Type'First); + Container.Elements := new Elements_Type'(E); + Container.Last := L; + end; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if Is_Empty (New_Item) then + return; + end if; + + Insert + (Container, + Index_Type'Succ (Container.Last), + New_Item); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; + + Insert + (Container, + Index_Type'Succ (Container.Last), + New_Item, + Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign + (Target : in out Vector; + Source : Vector) + is + N : constant Count_Type := Length (Source); + + begin + if Target'Address = Source'Address then + return; + end if; + + Clear (Target); + + if N = 0 then + return; + end if; + + if N > Capacity (Target) then + Reserve_Capacity (Target, Capacity => N); + end if; + + Target.Elements (Index_Type'First .. Source.Last) := + Source.Elements (Index_Type'First .. Source.Last); + + Target.Last := Source.Last; + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Count_Type is + begin + if Container.Elements = null then + return 0; + end if; + + return Container.Elements'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + Container.Last := Index_Type'Pred (Index_Type'First); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; + + declare + subtype I_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + I : constant I_Subtype := Index; + -- TODO: not sure whether to relax this check ??? + + I_As_Int : constant Int := Int (I); + + Old_Last_As_Int : constant Int := Index_Type'Pos (Container.Last); + + Count1 : constant Int'Base := Count_Type'Pos (Count); + Count2 : constant Int'Base := Old_Last_As_Int - I_As_Int + 1; + + N : constant Int'Base := Int'Min (Count1, Count2); + + J_As_Int : constant Int'Base := I_As_Int + N; + J : constant Index_Type'Base := Index_Type'Base (J_As_Int); + + E : Elements_Type renames Container.Elements.all; + + New_Last_As_Int : constant Int'Base := Old_Last_As_Int - N; + + New_Last : constant Extended_Index := + Extended_Index (New_Last_As_Int); + + begin + E (I .. New_Last) := E (J .. Container.Last); + Container.Last := New_Last; + end; + end Delete; + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1) + is + begin + + if Position.Container /= null + and then Position.Container /= + Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Position.Container = null + or else Position.Index > Container.Last + then + Position := No_Element; + return; + end if; + + Delete (Container, Position.Index, Count); + + if Position.Index <= Container.Last then + Position := (Container'Unchecked_Access, Position.Index); + else + Position := No_Element; + end if; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; + + if Count >= Length (Container) then + Clear (Container); + return; + end if; + + Delete (Container, Index_Type'First, Count); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1) + is + Index : Int'Base; + + begin + if Count = 0 then + return; + end if; + + if Count >= Length (Container) then + Clear (Container); + return; + end if; + + Index := Int'Base (Container.Last) - Int'Base (Count) + 1; + + Delete (Container, Index_Type'Base (Index), Count); + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + return Container.Elements (T'(Index)); + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + return Element (Position.Container.all, Position.Index); + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Vector) is + X : Elements_Access := Container.Elements; + begin + Container.Elements := null; + Container.Last := Index_Type'Pred (Index_Type'First); + Free (X); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor is + + begin + if Position.Container /= null + and then Position.Container /= + Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + for J in Position.Index .. Container.Last loop + if Container.Elements (J) = Item then + return (Container'Unchecked_Access, J); + end if; + end loop; + + return No_Element; + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index is + begin + for Indx in Index .. Container.Last loop + if Container.Elements (Indx) = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Find_Index; + + ----------- + -- First -- + ----------- + + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unchecked_Access, Index_Type'First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + return Element (Container, Index_Type'First); + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + ------------------ + -- Generic_Sort -- + ------------------ + + procedure Generic_Sort (Container : Vector) + is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Index_Type, + Element_Type => Element_Type, + Array_Type => Elements_Type, + "<" => "<"); + + begin + if Container.Elements = null then + return; + end if; + + Sort (Container.Elements (Index_Type'First .. Container.Last)); + end Generic_Sort; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; + + return Position.Index <= Position.Container.Last; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Old_Last : constant Extended_Index := Container.Last; + + Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last); + + N : constant Int := Count_Type'Pos (Count); + + New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; + + New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + + Index : Index_Type; + + Dst_Last : Index_Type; + Dst : Elements_Access; + + begin + if Count = 0 then + return; + end if; + + declare + subtype Before_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Succ (Container.Last); + + Old_First : constant Before_Subtype := Before; + + Old_First_As_Int : constant Int := Index_Type'Pos (Old_First); + + New_First_As_Int : constant Int'Base := Old_First_As_Int + N; + + begin + Index := Index_Type (New_First_As_Int); + end; + + if Container.Elements = null then + declare + subtype Elements_Subtype is + Elements_Type (Index_Type'First .. New_Last); + begin + Container.Elements := new Elements_Subtype'(others => New_Item); + end; + + Container.Last := New_Last; + return; + end if; + + if New_Last <= Container.Elements'Last then + declare + E : Elements_Type renames Container.Elements.all; + begin + E (Index .. New_Last) := E (Before .. Container.Last); + E (Before .. Index_Type'Pred (Index)) := (others => New_Item); + end; + + Container.Last := New_Last; + return; + end if; + + declare + First : constant Int := Int (Index_Type'First); + + New_Size : constant Int'Base := New_Last_As_Int - First + 1; + Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; + + Size, Dst_Last_As_Int : Int'Base; + + begin + if New_Size >= Max_Size / 2 then + Dst_Last := Index_Type'Last; + + else + Size := Container.Elements'Length; + + if Size = 0 then + Size := 1; + end if; + + while Size < New_Size loop + Size := 2 * Size; + end loop; + + Dst_Last_As_Int := First + Size - 1; + Dst_Last := Index_Type (Dst_Last_As_Int); + end if; + end; + + Dst := new Elements_Type (Index_Type'First .. Dst_Last); + + declare + Src : Elements_Type renames Container.Elements.all; + + begin + Dst (Index_Type'First .. Index_Type'Pred (Before)) := + Src (Index_Type'First .. Index_Type'Pred (Before)); + + Dst (Before .. Index_Type'Pred (Index)) := + (others => New_Item); + + Dst (Index .. New_Last) := + Src (Before .. Container.Last); + + exception + when others => + Free (Dst); + raise; + end; + + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := Dst; + Container.Last := New_Last; + Free (X); + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); + + begin + if N = 0 then + return; + end if; + + Insert_Space (Container, Before, Count => N); + + declare + Dst_Last_As_Int : constant Int'Base := + Int'Base (Before) + Int'Base (N) - 1; + + Dst_Last : constant Index_Type := Index_Type (Dst_Last_As_Int); + + begin + if Container'Address = New_Item'Address then + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Pred (Before); + + Src : Elements_Type renames + Container.Elements (Src_Index_Subtype); + + Index_As_Int : constant Int'Base := + Int (Before) + Src'Length - 1; + + Index : constant Index_Type'Base := + Index_Type'Base (Index_As_Int); + + Dst : Elements_Type renames + Container.Elements (Before .. Index); + + begin + Dst := Src; + end; + + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'Succ (Dst_Last) .. Container.Last; + + Src : Elements_Type renames + Container.Elements (Src_Index_Subtype); + + Index_As_Int : constant Int'Base := + Dst_Last_As_Int - Src'Length + 1; + + Index : constant Index_Type'Base := + Index_Type'Base (Index_As_Int); + + Dst : Elements_Type renames + Container.Elements (Index .. Dst_Last); + + begin + Dst := Src; + end; + + else + Container.Elements (Before .. Dst_Last) := + New_Item.Elements (Index_Type'First .. New_Item.Last); + end if; + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Is_Empty (New_Item) then + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Is_Empty (New_Item) then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert; + + ------------------ + -- Insert_Space -- + ------------------ + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + Old_Last : constant Extended_Index := Container.Last; + + Old_Last_As_Int : constant Int := Index_Type'Pos (Old_Last); + + N : constant Int := Count_Type'Pos (Count); + + New_Last_As_Int : constant Int'Base := Old_Last_As_Int + N; + + New_Last : constant Extended_Index := Extended_Index (New_Last_As_Int); + + Index : Index_Type; + + Dst_Last : Index_Type; + Dst : Elements_Access; + + begin + if Count = 0 then + return; + end if; + + declare + subtype Before_Subtype is Index_Type'Base range + Index_Type'First .. Index_Type'Succ (Container.Last); + + Old_First : constant Before_Subtype := Before; + + Old_First_As_Int : constant Int := Index_Type'Pos (Old_First); + + New_First_As_Int : constant Int'Base := Old_First_As_Int + N; + + begin + Index := Index_Type (New_First_As_Int); + end; + + if Container.Elements = null then + Container.Elements := + new Elements_Type (Index_Type'First .. New_Last); + + Container.Last := New_Last; + return; + end if; + + if New_Last <= Container.Elements'Last then + declare + E : Elements_Type renames Container.Elements.all; + begin + E (Index .. New_Last) := E (Before .. Container.Last); + end; + + Container.Last := New_Last; + return; + end if; + + declare + First : constant Int := Int (Index_Type'First); + + New_Size : constant Int'Base := New_Last_As_Int - First + 1; + Max_Size : constant Int'Base := Int (Index_Type'Last) - First + 1; + + Size, Dst_Last_As_Int : Int'Base; + + begin + if New_Size >= Max_Size / 2 then + Dst_Last := Index_Type'Last; + + else + Size := Container.Elements'Length; + + if Size = 0 then + Size := 1; + end if; + + while Size < New_Size loop + Size := 2 * Size; + end loop; + + Dst_Last_As_Int := First + Size - 1; + Dst_Last := Index_Type (Dst_Last_As_Int); + end if; + end; + + Dst := new Elements_Type (Index_Type'First .. Dst_Last); + + declare + Src : Elements_Type renames Container.Elements.all; + + begin + Dst (Index_Type'First .. Index_Type'Pred (Before)) := + Src (Index_Type'First .. Index_Type'Pred (Before)); + + Dst (Index .. New_Last) := + Src (Before .. Container.Last); + + exception + when others => + Free (Dst); + raise; + end; + + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := Dst; + Container.Last := New_Last; + + Free (X); + end; + end Insert_Space; + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Before.Container /= null + and then Before.Container /= Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + Index := Index_Type'Succ (Container.Last); + else + Index := Before.Index; + end if; + + Insert_Space (Container, Index, Count); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert_Space; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Vector) return Boolean is + begin + return Container.Last < Index_Type'First; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unchecked_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + return Element (Container, Container.Last); + end Last_Element; + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + + ------------ + -- Length -- + ------------ + + function Length (Container : Vector) return Count_Type is + L : constant Int := Int (Container.Last); + F : constant Int := Int (Index_Type'First); + N : constant Int'Base := L - F + 1; + begin + return Count_Type (N); + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Vector; + Source : in out Vector) + is + X : Elements_Access := Target.Elements; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Last >= Index_Type'First then + raise Constraint_Error; + end if; + + Target.Elements := null; + Free (X); + + Target.Elements := Source.Elements; + Target.Last := Source.Last; + + Source.Elements := null; + Source.Last := Index_Type'Pred (Index_Type'First); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Index < Position.Container.Last then + return (Position.Container, Index_Type'Succ (Position.Index)); + end if; + + return No_Element; + end Next; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + if Position.Container = null then + return; + end if; + + if Position.Index < Position.Container.Last then + Position.Index := Index_Type'Succ (Position.Index); + else + Position := No_Element; + end if; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out Vector; New_Item : Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, + Index_Type'First, + New_Item, + Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + if Position.Container = null then + return; + end if; + + if Position.Index > Index_Type'First then + Position.Index := Index_Type'Pred (Position.Index); + else + Position := No_Element; + end if; + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Index > Index_Type'First then + return (Position.Container, Index_Type'Pred (Position.Index)); + end if; + + return No_Element; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + Process (Container.Elements (T'(Index))); + end Query_Element; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + Container : Vector renames Position.Container.all; + + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + + begin + Process (Container.Elements (T'(Position.Index))); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Vector) + is + Length : Count_Type'Base; + Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, Length); + + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; + + for J in Count_Type range 1 .. Length loop + Last := Index_Type'Succ (Last); + Element_Type'Read (Stream, Container.Elements (Last)); + Container.Last := Last; + end loop; + end Read; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : Vector; + Index : Index_Type; + By : Element_Type) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + Container.Elements (T'(Index)) := By; + end Replace_Element; + + procedure Replace_Element (Position : Cursor; By : Element_Type) is + subtype T is Index_Type'Base range + Index_Type'First .. Position.Container.Last; + begin + Position.Container.Elements (T'(Position.Index)) := By; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type) + is + N : constant Count_Type := Length (Container); + + begin + if Capacity = 0 then + if N = 0 then + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := null; + Free (X); + end; + + elsif N < Container.Elements'Length then + declare + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Type renames + Container.Elements (Array_Index_Subtype); + + subtype Array_Subtype is + Elements_Type (Array_Index_Subtype); + + X : Elements_Access := Container.Elements; + + begin + Container.Elements := new Array_Subtype'(Src); + Free (X); + end; + end if; + + return; + end if; + + if Container.Elements = null then + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Capacity) - 1; + + Last : constant Index_Type := Index_Type (Last_As_Int); + + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); + + begin + Container.Elements := new Array_Subtype; + end; + + return; + end if; + + if Capacity <= N then + if N < Container.Elements'Length then + declare + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Type renames + Container.Elements (Array_Index_Subtype); + + subtype Array_Subtype is + Elements_Type (Array_Index_Subtype); + + X : Elements_Access := Container.Elements; + + begin + Container.Elements := new Array_Subtype'(Src); + Free (X); + end; + + end if; + + return; + end if; + + if Capacity = Container.Elements'Length then + return; + end if; + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Capacity) - 1; + + Last : constant Index_Type := Index_Type (Last_As_Int); + + subtype Array_Subtype is + Elements_Type (Index_Type'First .. Last); + + E : Elements_Access := new Array_Subtype; + + begin + declare + Src : Elements_Type renames + Container.Elements (Index_Type'First .. Container.Last); + + Tgt : Elements_Type renames + E (Index_Type'First .. Container.Last); + + begin + Tgt := Src; + + exception + when others => + Free (E); + raise; + end; + + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := E; + Free (X); + end; + end; + end Reserve_Capacity; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Last : Index_Type'Base; + + begin + if Position.Container /= null + and then Position.Container /= + Vector_Access'(Container'Unchecked_Access) + then + raise Program_Error; + end if; + + if Position.Container = null + or else Position.Index > Container.Last + then + Last := Container.Last; + else + Last := Position.Index; + end if; + + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (Indx) = Item then + return (Container'Unchecked_Access, Indx); + end if; + end loop; + + return No_Element; + end Reverse_Find; + + ------------------------ + -- Reverse_Find_Index -- + ------------------------ + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + Last : Index_Type'Base; + + begin + if Index > Container.Last then + Last := Container.Last; + else + Last := Index; + end if; + + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (Indx) = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Reverse_Find_Index; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unchecked_Access, Indx)); + end loop; + end Reverse_Iterate; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length (Container : in out Vector; Length : Count_Type) is + begin + if Length = 0 then + Clear (Container); + return; + end if; + + declare + Last_As_Int : constant Int'Base := + Int (Index_Type'First) + Int (Length) - 1; + + Last : constant Index_Type := Index_Type (Last_As_Int); + + begin + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; + + Container.Last := Last; + end; + end Set_Length; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : Vector; + I, J : Index_Type) + is + + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + + EI : constant Element_Type := Container.Elements (T'(I)); + + begin + + Container.Elements (T'(I)) := Container.Elements (T'(J)); + Container.Elements (T'(J)) := EI; + + end Swap; + + procedure Swap (I, J : Cursor) is + + -- NOTE: The behavior has been liberalized here to + -- allow I and J to designate different containers. + -- TODO: Probably this is supposed to raise P_E ??? + + subtype TI is Index_Type'Base range + Index_Type'First .. I.Container.Last; + + EI : Element_Type renames I.Container.Elements (TI'(I.Index)); + + EI_Copy : constant Element_Type := EI; + + subtype TJ is Index_Type'Base range + Index_Type'First .. J.Container.Last; + + EJ : Element_Type renames J.Container.Elements (TJ'(J.Index)); + + begin + EI := EJ; + EJ := EI_Copy; + end Swap; + + --------------- + -- To_Cursor -- + --------------- + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor + is + begin + if Index not in Index_Type'First .. Container.Last then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Index); + end To_Cursor; + + -------------- + -- To_Index -- + -------------- + + function To_Index (Position : Cursor) return Extended_Index is + begin + if Position.Container = null then + return No_Index; + end if; + + if Position.Index <= Position.Container.Last then + return Position.Index; + end if; + + return No_Index; + end To_Index; + + --------------- + -- To_Vector -- + --------------- + + function To_Vector (Length : Count_Type) return Vector is + begin + if Length = 0 then + return Empty_Vector; + end if; + + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : constant Index_Type := Index_Type (Last_As_Int); + Elements : constant Elements_Access := + new Elements_Type (Index_Type'First .. Last); + begin + return (Controlled with Elements, Last); + end; + end To_Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector + is + begin + if Length = 0 then + return Empty_Vector; + end if; + + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : constant Index_Type := Index_Type (Last_As_Int); + Elements : constant Elements_Access := + new Elements_Type' + (Index_Type'First .. Last => New_Item); + begin + return (Controlled with Elements, Last); + end; + end To_Vector; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)) + is + subtype T is Index_Type'Base range + Index_Type'First .. Container.Last; + begin + Process (Container.Elements (T'(Index))); + end Update_Element; + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + subtype T is Index_Type'Base range + Index_Type'First .. Position.Container.Last; + begin + Process (Position.Container.Elements (T'(Position.Index))); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Vector) + is + begin + Count_Type'Base'Write (Stream, Length (Container)); + + for J in Index_Type'First .. Container.Last loop + Element_Type'Write (Stream, Container.Elements (J)); + end loop; + end Write; + +end Ada.Containers.Vectors; + diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads new file mode 100644 index 00000000000..ef877c0f797 --- /dev/null +++ b/gcc/ada/a-convec.ads @@ -0,0 +1,336 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.VECTORS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ +with Ada.Finalization; +with Ada.Streams; + +generic + type Index_Type is range <>; + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Vectors is +pragma Preelaborate (Vectors); + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Last + + Boolean'Pos (Index_Type'Base'Last > Index_Type'Last); + + No_Index : constant Extended_Index := Extended_Index'First; + + subtype Index_Subtype is Index_Type; + + type Vector is tagged private; + + type Cursor is private; + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + function To_Vector (Length : Count_Type) return Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector; + + function "&" (Left, Right : Vector) return Vector; + + function "&" (Left : Vector; Right : Element_Type) return Vector; + + function "&" (Left : Element_Type; Right : Vector) return Vector; + + function "&" (Left, Right : Element_Type) return Vector; + + function "=" (Left, Right : Vector) return Boolean; + + function Capacity (Container : Vector) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type); + + function Length (Container : Vector) return Count_Type; + + function Is_Empty (Container : Vector) return Boolean; + + procedure Clear (Container : in out Vector); + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor; + + function To_Index (Position : Cursor) return Extended_Index; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Replace_Element + (Container : Vector; + Index : Index_Type; + By : Element_Type); + + procedure Replace_Element (Position : Cursor; By : Element_Type); + + procedure Assign (Target : in out Vector; Source : Vector); + + procedure Move (Target : in out Vector; Source : in out Vector); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Vector); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out Vector; + New_Item : Vector); + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Set_Length + (Container : in out Vector; + Length : Count_Type); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; -- TODO: verify + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1); + + function First_Index (Container : Vector) return Index_Type; + + function First (Container : Vector) return Cursor; + + function First_Element (Container : Vector) return Element_Type; + + function Last_Index (Container : Vector) return Extended_Index; + + function Last (Container : Vector) return Cursor; + + function Last_Element (Container : Vector) return Element_Type; + + procedure Swap (Container : Vector; I, J : Index_Type); + + procedure Swap (I, J : Cursor); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + procedure Generic_Sort (Container : Vector); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index; + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index; + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + +private + + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Query_Element); + pragma Inline (Update_Element); + pragma Inline (Replace_Element); + pragma Inline (Contains); + + type Elements_Type is array (Index_Type range <>) of Element_Type; + + function "=" (L, R : Elements_Type) return Boolean is abstract; + + type Elements_Access is access Elements_Type; + + use Ada.Finalization; + + type Vector is new Controlled with record + Elements : Elements_Access; + Last : Extended_Index := No_Index; + end record; + + procedure Adjust (Container : in out Vector); + + procedure Finalize (Container : in out Vector); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Vector); + + for Vector'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Vector); + + for Vector'Read use Read; + + Empty_Vector : constant Vector := (Controlled with null, No_Index); + + type Vector_Access is access constant Vector; + for Vector_Access'Storage_Size use 0; + + type Cursor is record + Container : Vector_Access; + Index : Index_Type := Index_Type'First; + end record; + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + +end Ada.Containers.Vectors; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb new file mode 100644 index 00000000000..2a706ab4d59 --- /dev/null +++ b/gcc/ada/a-coorma.adb @@ -0,0 +1,1031 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.ORDERED_MAPS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with System; use type System.Address; + +package body Ada.Containers.Ordered_Maps is + + use Red_Black_Trees; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red; + Key : Key_Type; + Element : Element_Type; + end record; + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Copy_Tree (Source_Root : Node_Access) return Node_Access; + + procedure Delete_Tree (X : in out Node_Access); + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + procedure Free is new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations + (Tree_Types => Tree_Types, + Null_Node => Node_Access'(null)); + + use Tree_Operations; + + package Key_Ops is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + return Left.Node.Key < Right.Node.Key; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Left.Node.Key < Right; + end "<"; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Key; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + return Right.Node.Key < Left.Node.Key; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right < Left.Node.Key; + end ">"; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Right.Node.Key < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Map) is + Tree : Tree_Type renames Container.Tree; + + N : constant Count_Type := Tree.Length; + X : constant Node_Access := Tree.Root; + + begin + if N = 0 then + pragma Assert (X = null); + return; + end if; + + Tree := (Length => 0, others => null); + + Tree.Root := Copy_Tree (X); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Adjust; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + Tree : Tree_Type renames Container.Tree; + Root : Node_Access := Tree.Root; + begin + Tree := (Length => 0, others => null); + Delete_Tree (Root); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Target : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Key => Source.Key, + Element => Source.Element); + begin + return Target; + end Copy_Node; + + --------------- + -- Copy_Tree -- + --------------- + + function Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + P, X : Node_Access; + + begin + if Source_Root.Right /= null then + Target_Root.Right := Copy_Tree (Source_Root.Right); + Target_Root.Right.Parent := Target_Root; + end if; + + P := Target_Root; + X := Source_Root.Left; + + while X /= null loop + declare + Y : Node_Access := Copy_Node (X); + + begin + P.Left := Y; + Y.Parent := P; + + if X.Right /= null then + Y.Right := Copy_Tree (X.Right); + Y.Right.Parent := Y; + end if; + + P := Y; + X := X.Left; + end; + end loop; + + return Target_Root; + + exception + when others => + Delete_Tree (Target_Root); + raise; + end Copy_Tree; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= Map_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if X = null then + raise Constraint_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Map) is + Position : Cursor := First (Container); + begin + Delete (Container, Position); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Map) is + Position : Cursor := Last (Container); + begin + Delete (Container, Position); + end Delete_Last; + + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + begin + while X /= null loop + Y := X.Right; + Delete_Tree (Y); + Y := X.Left; + Free (X); + X := Y; + end loop; + end Delete_Tree; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element; + end Element; + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + return Node.Element; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if X /= null then + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + begin + if Container.Tree.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + begin + return Container.Tree.First.Element; + end First_Element; + + --------------- + -- First_Key -- + --------------- + + function First_Key (Container : Map) return Key_Type is + begin + return Container.Tree.First.Key; + end First_Key; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + Position.Node.Key := Key; + Position.Node.Element := New_Item; + end if; + end Include; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Key => Key, + Element => New_Item); + begin + return Node; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + begin + begin + Node.Key := Key; + exception + when others => + Free (Node); + raise; + end; + + return Node; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unchecked_Access; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node + (L, R : Node_Access) return Boolean is + begin + return L.Element = R.Element; + end Is_Equal_Node_Node; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + -- k > node same as node < k + + return Right.Key < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Key; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree); + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + return Position.Node.Key; + end Key; + + ---------- + -- Last -- + ---------- + + function Last (Container : Map) return Cursor is + begin + if Container.Tree.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + begin + return Container.Tree.Last.Element; + end Last_Element; + + -------------- + -- Last_Key -- + -------------- + + function Last_Key (Container : Map) return Key_Type is + begin + return Container.Tree.Last.Key; + end Last_Key; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Map; Source : in out Map) is + begin + if Target'Address = Source'Address then + return; + end if; + + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + Process (Position.Node.Key, Position.Node.Element); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Map) + is + N : Count_Type'Base; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + begin + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + exception + when others => + Free (Node); + raise; + end; + + return Node; + end New_Node; + + -- Start of processing for Read + + begin + Clear (Container); + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + Local_Read (Container.Tree, N); + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error; + end if; + + Node.Key := Key; + Node.Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element (Position : Cursor; By : Element_Type) is + begin + Position.Node.Element := By; + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : Node_Access; + Color : Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + Process (Position.Node.Key, Position.Node.Element); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Map) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Process; + + -- Start of processing for Write + + begin + Count_Type'Base'Write (Stream, Container.Tree.Length); + Iterate (Container.Tree); + end Write; + +end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads new file mode 100644 index 00000000000..7fa06e0e31b --- /dev/null +++ b/gcc/ada/a-coorma.ads @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.ORDERED_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees; +with Ada.Finalization; +with Ada.Streams; + +generic + + type Key_Type is private; + + type Element_Type is private; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Ordered_Maps is +pragma Preelaborate (Ordered_Maps); + + type Map is tagged private; + + type Cursor is private; + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + function Key (Position : Cursor) return Key_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + + procedure Update_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + + procedure Replace_Element (Position : Cursor; By : in Element_Type); + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Exclude (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); + + procedure Delete_First (Container : in out Map); + + procedure Delete_Last (Container : in out Map); + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Floor (Container : Map; Key : Key_Type) return Cursor; + + function Ceiling (Container : Map; Key : Key_Type) return Cursor; + + function First (Container : Map) return Cursor; + + function First_Key (Container : Map) return Key_Type; + + function First_Element (Container : Map) return Element_Type; + + function Last (Container : Map) return Cursor; + + function Last_Key (Container : Map) return Key_Type; + + function Last_Element (Container : Map) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + +private + + type Node_Type; + type Node_Access is access Node_Type; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Access); + + use Tree_Types; + use Ada.Finalization; + + type Map is new Controlled with record + Tree : Tree_Type := (Length => 0, others => null); + end record; + + procedure Adjust (Container : in out Map); + + procedure Finalize (Container : in out Map) renames Clear; + + type Map_Access is access constant Map; + for Map_Access'Storage_Size use 0; + + type Cursor is record + Container : Map_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := Cursor'(null, null); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + Empty_Map : constant Map := + (Controlled with Tree => (Length => 0, others => null)); + +end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb new file mode 100644 index 00000000000..20712960bf9 --- /dev/null +++ b/gcc/ada/a-coormu.adb @@ -0,0 +1,1635 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.ORDERED_MULTISETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Ordered_Multisets is + + use Red_Black_Trees; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red; + Element : Element_Type; + end record; + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Copy_Tree (Source_Root : Node_Access) return Node_Access; + + procedure Delete_Tree (X : in out Node_Access); + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Less_Node_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations + (Tree_Types => Tree_Types, + Null_Node => Node_Access'(null)); + + use Tree_Operations; + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + package Element_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Generic_Set_Operations + (Tree_Operations => Tree_Operations, + Insert_With_Hint => Insert_With_Hint, + Copy_Tree => Copy_Tree, + Delete_Tree => Delete_Tree, + Is_Less => Is_Less_Node_Node, + Free => Free); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + return Left.Node.Element < Right.Node.Element; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) + return Boolean is + begin + return Left.Node.Element < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) + return Boolean is + begin + return Left < Right.Node.Element; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + -- L > R same as R < L + + return Right.Node.Element < Left.Node.Element; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) + return Boolean is + begin + return Right < Left.Node.Element; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) + return Boolean is + begin + return Right.Node.Element < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + + N : constant Count_Type := Tree.Length; + X : constant Node_Access := Tree.Root; + + begin + if N = 0 then + pragma Assert (X = null); + return; + end if; + + Tree := (Length => 0, others => null); + + Tree.Root := Copy_Tree (X); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Adjust; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Ceiling (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + Root : Node_Access := Tree.Root; + begin + Tree := (Length => 0, others => null); + Delete_Tree (Root); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Target : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Element => Source.Element); + begin + return Target; + end Copy_Node; + + --------------- + -- Copy_Tree -- + --------------- + + function Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + + P, X : Node_Access; + + begin + if Source_Root.Right /= null then + Target_Root.Right := Copy_Tree (Source_Root.Right); + Target_Root.Right.Parent := Target_Root; + end if; + + P := Target_Root; + X := Source_Root.Left; + while X /= null loop + declare + Y : Node_Access := Copy_Node (X); + + begin + P.Left := Y; + Y.Parent := P; + + if X.Right /= null then + Y.Right := Copy_Tree (X.Right); + Y.Right.Parent := Y; + end if; + + P := Y; + X := X.Left; + end; + end loop; + + return Target_Root; + + exception + when others => + Delete_Tree (Target_Root); + raise; + end Copy_Tree; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Item : Element_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Element_Keys.Ceiling (Tree, Item); + Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); + X : Node_Access; + + begin + if Node = Done then + raise Constraint_Error; + end if; + + loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + + exit when Node = Done; + end loop; + end Delete; + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + + begin + if X = null then + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; + + begin + if X = null then + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end Delete_Last; + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + begin + while X /= null loop + Y := X.Right; + Delete_Tree (Y); + Y := X.Left; + Free (X); + X := Y; + end loop; + end Delete_Tree; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Set_Ops.Difference (Target.Tree, Source.Tree); + end Difference; + + function Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Element_Keys.Ceiling (Tree, Item); + Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); + X : Node_Access; + begin + while Node /= Done loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end loop; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Container.Tree.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + return Container.Tree.First.Element; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Floor (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local_Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Element; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right > Left.Node.Element; + end "<"; + + --------- + -- ">" -- + --------- + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right < Left.Node.Element; + end ">"; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left > Right.Node.Element; + end ">"; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Ceiling (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ---------------------------- + -- Checked_Update_Element -- + ---------------------------- + + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Position.Container = null then + raise Constraint_Error; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + declare + Old_Key : Key_Type renames Key (Position.Node.Element); + + begin + Process (Position.Node.Element); + + if Old_Key < Position.Node.Element + or else Old_Key > Position.Node.Element + then + null; + else + return; + end if; + end; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + + Do_Insert : declare + Result : Node_Access; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Keys.Generic_Insert_Post (New_Node); + + procedure Insert is + new Key_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return Position.Node; + end New_Node; + + -- Start of processing for Do_Insert + + begin + Insert + (Tree => Container.Tree, + Key => Key (Position.Node.Element), + Node => Result); + + pragma Assert (Result = Position.Node); + end Do_Insert; + end Checked_Update_Element; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Key_Keys.Ceiling (Tree, Key); + Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); + X : Node_Access; + + begin + if Node = Done then + raise Constraint_Error; + end if; + + loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + + exit when Node = Done; + end loop; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + begin + return Node.Element; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Key_Keys.Ceiling (Tree, Key); + Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); + X : Node_Access; + begin + while Node /= Done loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end loop; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Floor (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left > Right.Element; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left < Right.Element; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Key_Keys.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree, Key); + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + return Key (Position.Node.Element); + end Key; + + ------------- + -- Replace -- + ------------- + + -- In post-madision api:??? + +-- procedure Replace +-- (Container : in out Set; +-- Key : Key_Type; +-- New_Item : Element_Type) +-- is +-- Node : Node_Access := Key_Keys.Find (Container.Tree, Key); + +-- begin +-- if Node = null then +-- raise Constraint_Error; +-- end if; + +-- Replace_Node (Container, Node, New_Item); +-- end Replace; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Key_Keys.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree, Key); + end Reverse_Iterate; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + begin + Insert (Container, New_Item, Position); + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => New_Item); + begin + return Node; + end New_Node; + + -- Start of processing for Insert + + begin + Unconditional_Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node); + + Position.Container := Container'Unchecked_Access; + end Insert; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => Src_Node.Element); + begin + return Node; + end New_Node; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Tree, + Dst_Hint, + Src_Node.Element, + Dst_Node); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Set_Ops.Intersection (Target.Tree, Source.Tree); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element = R.Element; + end Is_Equal_Node_Node; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + -- e > node same as node < e + + return Right.Element < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element < R.Element; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree); + end Iterate; + + procedure Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Element_Keys.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree, Item); + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + if Container.Tree.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + return Container.Tree.Last.Element; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) + is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + if Left'Address = Right'Address then + return Left.Tree.Length /= 0; + end if; + + return Set_Ops.Overlap (Left.Tree, Right.Tree); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) + is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + Process (Position.Node.Element); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set) + is + N : Count_Type'Base; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + begin + begin + Element_Type'Read (Stream, Node.Element); + + exception + when others => + Free (Node); + raise; + end; + + return Node; + end New_Node; + + -- Start of processing for Read + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + Local_Read (Container.Tree, N); + end Read; + + ------------- + -- Replace -- + ------------- + + -- NOTE: from post-madison api ??? + +-- procedure Replace +-- (Container : in out Set; +-- Position : Cursor; +-- By : Element_Type) +-- is +-- begin +-- if Position.Container = null then +-- raise Constraint_Error; +-- end if; + +-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then +-- raise Program_Error; +-- end if; + +-- Replace_Node (Container, Position.Node, By); +-- end Replace; + + ------------------ + -- Replace_Node -- + ------------------ + + -- NOTE: from post-madison api ??? + +-- procedure Replace_Node +-- (Container : in out Set; +-- Position : Node_Access; +-- By : Element_Type) +-- is +-- Tree : Tree_Type renames Container.Tree; +-- Node : Node_Access := Position; + +-- begin +-- if By < Node.Element +-- or else Node.Element < By +-- then +-- null; + +-- else +-- begin +-- Node.Element := By; + +-- exception +-- when others => +-- Tree_Operations.Delete_Node_Sans_Free (Tree, Node); +-- Free (Node); +-- raise; +-- end; + +-- return; +-- end if; + +-- Tree_Operations.Delete_Node_Sans_Free (Tree, Node); + +-- begin +-- Node.Element := By; + +-- exception +-- when others => +-- Free (Node); +-- raise; +-- end; +-- +-- Do_Insert : declare +-- Result : Node_Access; +-- Success : Boolean; + +-- function New_Node return Node_Access; +-- pragma Inline (New_Node); + +-- procedure Insert_Post is +-- new Element_Keys.Generic_Insert_Post (New_Node); +-- +-- procedure Insert is +-- new Element_Keys.Generic_Conditional_Insert (Insert_Post); + +-- -------------- +-- -- New_Node -- +-- -------------- + +-- function New_Node return Node_Access is +-- begin +-- return Node; +-- end New_Node; + +-- -- Start of processing for Do_Insert + +-- begin +-- Insert +-- (Tree => Tree, +-- Key => Node.Element, +-- Node => Result, +-- Success => Success); +-- +-- if not Success then +-- Free (Node); +-- raise Program_Error; +-- end if; +-- +-- pragma Assert (Result = Node); +-- end Do_Insert; +-- end Replace_Node; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree); + end Reverse_Iterate; + + procedure Reverse_Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Element_Keys.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree, Item); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Set_Ops.Union (Target.Tree, Source.Tree); + end Union; + + function Union (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Union (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Element_Type'Write (Stream, Node.Element); + end Process; + + -- Start of processing for Write + + begin + Count_Type'Base'Write (Stream, Container.Tree.Length); + Iterate (Container.Tree); + end Write; + +end Ada.Containers.Ordered_Multisets; + + diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads new file mode 100644 index 00000000000..6d848a8215a --- /dev/null +++ b/gcc/ada/a-coormu.ads @@ -0,0 +1,301 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.ORDERED_MULTISETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees; +with Ada.Finalization; +with Ada.Streams; + +generic + type Element_Type is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Ordered_Multisets is +pragma Preelaborate (Ordered_Multisets); + + type Set is tagged private; + + type Cursor is private; + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Move + (Target : in out Set; + Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + + procedure Delete + (Container : in out Set; + Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + -- NOTE: The following operation is named Replace in the Madison API. + -- However, it should be named Replace_Element. ??? + -- + -- procedure Replace + -- (Container : in out Set; + -- Position : Cursor; + -- By : Element_Type); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)); + + generic + type Key_Type (<>) is limited private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left : Key_Type; Right : Element_Type) + return Boolean is <>; + + with function ">" (Left : Key_Type; Right : Element_Type) + return Boolean is <>; + + package Generic_Keys is + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Floor (Container : Set; Key : Key_Type) return Cursor; + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + -- NOTE: in post-madison api ??? + -- procedure Replace + -- (Container : in out Set; + -- Key : Key_Type; + -- New_Item : Element_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + -- Should name of following be "Update_Element" ??? + + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + procedure Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)); + + end Generic_Keys; + +private + + type Node_Type; + type Node_Access is access Node_Type; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Access); + + use Tree_Types; + use Ada.Finalization; + + type Set is new Controlled with record + Tree : Tree_Type := (Length => 0, others => null); + end record; + + procedure Adjust (Container : in out Set); + + procedure Finalize (Container : in out Set) renames Clear; + + type Set_Access is access constant Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := Cursor'(null, null); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := + (Controlled with Tree => (Length => 0, others => null)); + +end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb new file mode 100644 index 00000000000..03cf0036ddb --- /dev/null +++ b/gcc/ada/a-coorse.adb @@ -0,0 +1,1529 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.ORDERED_SETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Ordered_Sets is + + use Red_Black_Trees; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red; + Element : Element_Type; + end record; + + ------------------------------ + -- Access to Fields of Node -- + ------------------------------ + + -- These subprograms provide functional notation for access to fields + -- of a node, and procedural notation for modifiying these fields. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Copy_Tree (Source_Root : Node_Access) return Node_Access; + + procedure Delete_Tree (X : in out Node_Access); + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Less_Node_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations + (Tree_Types => Tree_Types, + Null_Node => Node_Access'(null)); + + use Tree_Operations; + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + package Element_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Generic_Set_Operations + (Tree_Operations => Tree_Operations, + Insert_With_Hint => Insert_With_Hint, + Copy_Tree => Copy_Tree, + Delete_Tree => Delete_Tree, + Is_Less => Is_Less_Node_Node, + Free => Free); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + return Left.Node.Element < Right.Node.Element; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean is + begin + return Left.Node.Element < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Element; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + -- L > R same as R < L + + return Right.Node.Element < Left.Node.Element; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean is + begin + return Right.Node.Element < Left; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + return Right < Left.Node.Element; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + + N : constant Count_Type := Tree.Length; + X : constant Node_Access := Tree.Root; + + begin + if N = 0 then + pragma Assert (X = null); + return; + end if; + + Tree := (Length => 0, others => null); + + Tree.Root := Copy_Tree (X); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Adjust; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Ceiling (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + Root : Node_Access := Tree.Root; + begin + Tree := (Length => 0, others => null); + Delete_Tree (Root); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Target : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Element => Source.Element); + begin + return Target; + end Copy_Node; + + --------------- + -- Copy_Tree -- + --------------- + + function Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + + P, X : Node_Access; + + begin + if Source_Root.Right /= null then + Target_Root.Right := Copy_Tree (Source_Root.Right); + Target_Root.Right.Parent := Target_Root; + end if; + + P := Target_Root; + X := Source_Root.Left; + while X /= null loop + declare + Y : Node_Access := Copy_Node (X); + + begin + P.Left := Y; + Y.Parent := P; + + if X.Right /= null then + Y.Right := Copy_Tree (X.Right); + Y.Right.Parent := Y; + end if; + + P := Y; + X := X.Left; + end; + end loop; + + return Target_Root; + + exception + when others => + + Delete_Tree (Target_Root); + raise; + end Copy_Tree; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Position = No_Element then + return; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + Position.Container := null; + end Delete; + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : Node_Access := Element_Keys.Find (Container.Tree, Item); + + begin + if X = null then + raise Constraint_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + C : Cursor := First (Container); + begin + Delete (Container, C); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + C : Cursor := Last (Container); + begin + Delete (Container, C); + end Delete_Last; + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + begin + while X /= null loop + Y := X.Right; + Delete_Tree (Y); + Y := X.Left; + Free (X); + X := Y; + end loop; + end Delete_Tree; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Set_Ops.Difference (Target.Tree, Source.Tree); + end Difference; + + function Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + return Position.Node.Element; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : Node_Access := Element_Keys.Find (Container.Tree, Item); + + begin + if X /= null then + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Container.Tree.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + return Container.Tree.First.Element; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Floor (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left < Right.Node.Element; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right > Left.Node.Element; + end "<"; + + --------- + -- ">" -- + --------- + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + return Left > Right.Node.Element; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + return Right < Left.Node.Element; + end ">"; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Ceiling (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Ceiling; + + ---------------------------- + -- Checked_Update_Element -- + ---------------------------- + + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Position.Container = null then + raise Constraint_Error; + end if; + + if Position.Container /= Set_Access'(Container'Unchecked_Access) then + raise Program_Error; + end if; + + declare + Old_Key : Key_Type renames Key (Position.Node.Element); + + begin + Process (Position.Node.Element); + + if Old_Key < Position.Node.Element + or else Old_Key > Position.Node.Element + then + null; + else + return; + end if; + end; + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + + declare + Result : Node_Access; + Success : Boolean; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Key_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Conditional_Insert is + new Key_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return Position.Node; + end New_Node; + + + begin + Local_Conditional_Insert + (Tree => Container.Tree, + Key => Key (Position.Node.Element), + Node => Result, + Success => Success); + + if not Success then + declare + X : Node_Access := Position.Node; + begin + Free (X); + end; + + raise Program_Error; + end if; + + pragma Assert (Result = Position.Node); + end; + end Checked_Update_Element; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if X = null then + raise Constraint_Error; + end if; + + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + return Node.Element; + end Element; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + if X /= null then + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Node); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Left > Right.Element; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + return Key (Position.Node.Element); + end Key; + + ------------- + -- Replace -- + ------------- + +-- TODO??? + +-- procedure Replace +-- (Container : in out Set; +-- Key : Key_Type; +-- New_Item : Element_Type) +-- is +-- Node : Node_Access := Key_Keys.Find (Container.Tree, Key); + +-- begin +-- if Node = null then +-- raise Constraint_Error; +-- end if; + +-- Replace_Element (Container, Node, New_Item); +-- end Replace; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + Position.Node.Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => New_Item); + begin + return Node; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node, + Inserted); + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error; + end if; + end Insert; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access) + is + Success : Boolean; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => Src_Node.Element); + begin + return Node; + end New_Node; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Tree, + Dst_Hint, + Src_Node.Element, + Dst_Node, + Success); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Set_Ops.Intersection (Target.Tree, Source.Tree); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element = R.Element; + end Is_Equal_Node_Node; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + -- Compute e > node same as node < e + + return Right.Element < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element < R.Element; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of prccessing for Iterate + + begin + Local_Iterate (Container.Tree); + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + if Container.Tree.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unchecked_Access, Container.Tree.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + return Container.Tree.Last.Element; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + if Left'Address = Right'Address then + return Left.Tree.Length /= 0; + end if; + + return Set_Ops.Overlap (Left.Tree, Right.Tree); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + Process (Position.Node.Element); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set) + is + N : Count_Type'Base; + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Read is new Tree_Operations.Generic_Read (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + begin + begin + Element_Type'Read (Stream, Node.Element); + + exception + when others => + Free (Node); + raise; + end; + + return Node; + end New_Node; + + -- Start of processing for Read + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + Local_Read (Container.Tree, N); + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, New_Item); + + begin + if Node = null then + raise Constraint_Error; + end if; + + Node.Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + +-- TODO: ??? +-- procedure Replace_Element +-- (Container : in out Set; +-- Position : Node_Access; +-- By : Element_Type) +-- is +-- Node : Node_Access := Position; + +-- begin +-- if By < Node.Element +-- or else Node.Element < By +-- then +-- null; + +-- else +-- begin +-- Node.Element := By; + +-- exception +-- when others => +-- Delete_Node_Sans_Free (Container.Tree, Node); +-- Free (Node); +-- raise; +-- end; + +-- return; +-- end if; + +-- Delete_Node_Sans_Free (Container.Tree, Node); + +-- begin +-- Node.Element := By; +-- exception +-- when others => +-- Free (Node); +-- raise; +-- end; + +-- declare +-- function New_Node return Node_Access; +-- pragma Inline (New_Node); + +-- function New_Node return Node_Access is +-- begin +-- return Node; +-- end New_Node; + +-- procedure Insert_Post is +-- new Element_Keys.Generic_Insert_Post (New_Node); + +-- procedure Insert is +-- new Element_Keys.Generic_Conditional_Insert (Insert_Post); + +-- Result : Node_Access; +-- Success : Boolean; + +-- begin +-- Insert +-- (Tree => Container.Tree, +-- Key => Node.Element, +-- Node => Result, +-- Success => Success); + +-- if not Success then +-- Free (Node); +-- raise Program_Error; +-- end if; + +-- pragma Assert (Result = Node); +-- end; +-- end Replace_Element; + + +-- procedure Replace_Element +-- (Container : in out Set; +-- Position : Cursor; +-- By : Element_Type) +-- is +-- begin +-- if Position.Container = null then +-- raise Constraint_Error; +-- end if; + +-- if Position.Container /= Set_Access'(Container'Unchecked_Access) then +-- raise Program_Error; +-- end if; + +-- Replace_Element (Container, Position.Node, By); +-- end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unchecked_Access, Node)); + end Process_Node; + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + declare + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + + if Target'Address = Source'Address then + return; + end if; + + Set_Ops.Union (Target.Tree, Source.Tree); + end Union; + + function Union (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left; + end if; + + declare + Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree); + begin + return (Controlled with Tree); + end; + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Element_Type'Write (Stream, Node.Element); + end Process; + + -- Start of processing for Write + + begin + Count_Type'Base'Write (Stream, Container.Tree.Length); + Iterate (Container.Tree); + end Write; + + + + +end Ada.Containers.Ordered_Sets; + + diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads new file mode 100644 index 00000000000..1dca837ccb6 --- /dev/null +++ b/gcc/ada/a-coorse.ads @@ -0,0 +1,290 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.ORDERED_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees; +with Ada.Finalization; +with Ada.Streams; + +generic + + type Element_Type is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Ordered_Sets is +pragma Preelaborate (Ordered_Sets); + + type Set is tagged private; + + type Cursor is private; + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function "=" (Left, Right : Set) return Boolean; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + +-- TODO: resolve in Atlanta. ??? +-- procedure Replace_Element +-- (Container : in out Set; +-- Position : Cursor; +-- By : Element_Type); + + procedure Move + (Target : in out Set; + Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + + procedure Include + (Container : in out Set; + New_Item : Element_Type); + + procedure Replace + (Container : in out Set; + New_Item : Element_Type); + + procedure Delete + (Container : in out Set; + Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; + Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + function Previous (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + procedure Previous (Position : in out Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + generic + type Key_Type (<>) is limited private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" + (Left : Key_Type; + Right : Element_Type) return Boolean is <>; + + with function ">" + (Left : Key_Type; + Right : Element_Type) return Boolean is <>; + + package Generic_Keys is + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Floor (Container : Set; Key : Key_Type) return Cursor; + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + +-- TODO: resolve in Atlanta ??? +-- procedure Replace +-- (Container : in out Set; +-- Key : Key_Type; +-- New_Item : Element_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + +-- TODO: resolve name in Atlanta. Should name be just "Update_Element" ??? + procedure Checked_Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + end Generic_Keys; + +private + + type Node_Type; + type Node_Access is access Node_Type; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Access); + + use Tree_Types; + use Ada.Finalization; + + type Set is new Controlled with record + Tree : Tree_Type := (Length => 0, others => null); + end record; + + procedure Adjust (Container : in out Set); + + procedure Finalize (Container : in out Set) renames Clear; + + type Set_Access is access constant Set; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + No_Element : constant Cursor := Cursor'(null, null); + + use Ada.Streams; + + procedure Write + (Stream : access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + Empty_Set : constant Set := + (Controlled with Tree => (Length => 0, others => null)); + +end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/a-coprnu.adb b/gcc/ada/a-coprnu.adb new file mode 100644 index 00000000000..a27557afd96 --- /dev/null +++ b/gcc/ada/a-coprnu.adb @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.PRIME_NUMBERS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Prime_Numbers is + + -------------- + -- To_Prime -- + -------------- + + function To_Prime (Length : Count_Type) return Hash_Type is + I, J, K : Integer'Base; + Index : Integer'Base; + + begin + I := Primes'Last - Primes'First; + Index := Primes'First; + while I > 0 loop + J := I / 2; + K := Index + J; + + if Primes (K) < Hash_Type (Length) then + Index := K + 1; + I := I - J - 1; + else + I := J; + end if; + end loop; + + return Primes (Index); + end To_Prime; + +end Ada.Containers.Prime_Numbers; diff --git a/gcc/ada/a-coprnu.ads b/gcc/ada/a-coprnu.ads new file mode 100644 index 00000000000..9960b9d480f --- /dev/null +++ b/gcc/ada/a-coprnu.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.PRIME_NUMBERS -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Containers.Prime_Numbers is +pragma Pure (Prime_Numbers); + + type Primes_Type is array (Positive range <>) of Hash_Type; + + Primes : constant Primes_Type := + (53, 97, 193, 389, 769, + 1543, 3079, 6151, 12289, 24593, + 49157, 98317, 196613, 393241, 786433, + 1572869, 3145739, 6291469, 12582917, 25165843, + 50331653, 100663319, 201326611, 402653189, 805306457, + 1610612741, 3221225473, 4294967291); + + function To_Prime (Length : Count_Type) return Hash_Type; + +end Ada.Containers.Prime_Numbers; diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads new file mode 100644 index 00000000000..fe20d457c49 --- /dev/null +++ b/gcc/ada/a-crbltr.ads @@ -0,0 +1,31 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Containers.Red_Black_Trees is +pragma Pure (Red_Black_Trees); + + type Color_Type is (Red, Black); + + generic + type Node_Access is private; + package Generic_Tree_Types is + type Tree_Type is record + First : Node_Access; + Last : Node_Access; + Root : Node_Access; + Length : Count_Type; + end record; + end Generic_Tree_Types; +end Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb new file mode 100644 index 00000000000..70c8f35278c --- /dev/null +++ b/gcc/ada/a-crbtgk.adb @@ -0,0 +1,523 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Red_Black_Trees.Generic_Keys is + + package Ops renames Tree_Operations; + + ------------- + -- Ceiling -- + ------------- + + -- AKA Lower_Bound + + function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is + Y : Node_Access; + X : Node_Access := Tree.Root; + + begin + while X /= Ops.Null_Node loop + if Is_Greater_Key_Node (Key, X) then + X := Ops.Right (X); + else + Y := X; + X := Ops.Left (X); + end if; + end loop; + + return Y; + end Ceiling; + + ---------- + -- Find -- + ---------- + + function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is + Y : Node_Access; + X : Node_Access := Tree.Root; + + begin + while X /= Ops.Null_Node loop + if Is_Greater_Key_Node (Key, X) then + X := Ops.Right (X); + else + Y := X; + X := Ops.Left (X); + end if; + end loop; + + if Y = Ops.Null_Node then + return Ops.Null_Node; + end if; + + if Is_Less_Key_Node (Key, Y) then + return Ops.Null_Node; + end if; + + return Y; + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is + Y : Node_Access; + X : Node_Access := Tree.Root; + + begin + while X /= Ops.Null_Node loop + if Is_Less_Key_Node (Key, X) then + X := Ops.Left (X); + else + Y := X; + X := Ops.Right (X); + end if; + end loop; + + return Y; + end Floor; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Success : out Boolean) + is + Y : Node_Access := Ops.Null_Node; + X : Node_Access := Tree.Root; + + begin + Success := True; + while X /= Ops.Null_Node loop + Y := X; + Success := Is_Less_Key_Node (Key, X); + + if Success then + X := Ops.Left (X); + else + X := Ops.Right (X); + end if; + end loop; + + Node := Y; + + if Success then + if Node = Tree.First then + Insert_Post (Tree, X, Y, Key, Node); + return; + end if; + + Node := Ops.Previous (Node); + end if; + + if Is_Greater_Key_Node (Key, Node) then + Insert_Post (Tree, X, Y, Key, Node); + Success := True; + return; + end if; + + Success := False; + end Generic_Conditional_Insert; + + ------------------------------------------ + -- Generic_Conditional_Insert_With_Hint -- + ------------------------------------------ + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type; + Position : Node_Access; + Key : Key_Type; + Node : out Node_Access; + Success : out Boolean) + is + begin + if Position = Ops.Null_Node then -- largest + if Tree.Length > 0 + and then Is_Greater_Key_Node (Key, Tree.Last) + then + Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node); + Success := True; + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); + end if; + + return; + end if; + + pragma Assert (Tree.Length > 0); + + if Is_Less_Key_Node (Key, Position) then + if Position = Tree.First then + Insert_Post (Tree, Position, Position, Key, Node); + Success := True; + return; + end if; + + declare + Before : constant Node_Access := Ops.Previous (Position); + + begin + if Is_Greater_Key_Node (Key, Before) then + if Ops.Right (Before) = Ops.Null_Node then + Insert_Post (Tree, Ops.Null_Node, Before, Key, Node); + else + Insert_Post (Tree, Position, Position, Key, Node); + end if; + + Success := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); + end if; + end; + + return; + end if; + + if Is_Greater_Key_Node (Key, Position) then + if Position = Tree.Last then + Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node); + Success := True; + return; + end if; + + declare + After : constant Node_Access := Ops.Next (Position); + + begin + if Is_Less_Key_Node (Key, After) then + if Ops.Right (Position) = Ops.Null_Node then + Insert_Post (Tree, Ops.Null_Node, Position, Key, Node); + else + Insert_Post (Tree, After, After, Key, Node); + end if; + + Success := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Success); + end if; + end; + + return; + end if; + + Node := Position; + Success := False; + end Generic_Conditional_Insert_With_Hint; + + ------------------------- + -- Generic_Insert_Post -- + ------------------------- + + procedure Generic_Insert_Post + (Tree : in out Tree_Type; + X, Y : Node_Access; + Key : Key_Type; + Z : out Node_Access) + is + subtype Length_Subtype is Count_Type range 0 .. Count_Type'Last - 1; + + New_Length : constant Count_Type := Length_Subtype'(Tree.Length) + 1; + + begin + if Y = Ops.Null_Node + or else X /= Ops.Null_Node + or else Is_Less_Key_Node (Key, Y) + then + pragma Assert (Y = Ops.Null_Node + or else Ops.Left (Y) = Ops.Null_Node); + + -- Delay allocation as long as we can, in order to defend + -- against exceptions propagated by relational operators. + + Z := New_Node; + + pragma Assert (Z /= Ops.Null_Node); + pragma Assert (Ops.Color (Z) = Red); + + if Y = Ops.Null_Node then + pragma Assert (Tree.Length = 0); + pragma Assert (Tree.Root = Ops.Null_Node); + pragma Assert (Tree.First = Ops.Null_Node); + pragma Assert (Tree.Last = Ops.Null_Node); + + Tree.Root := Z; + Tree.First := Z; + Tree.Last := Z; + + else + Ops.Set_Left (Y, Z); + + if Y = Tree.First then + Tree.First := Z; + end if; + end if; + + else + pragma Assert (Ops.Right (Y) = Ops.Null_Node); + + -- Delay allocation as long as we can, in order to defend + -- against exceptions propagated by relational operators. + + Z := New_Node; + + pragma Assert (Z /= Ops.Null_Node); + pragma Assert (Ops.Color (Z) = Red); + + Ops.Set_Right (Y, Z); + + if Y = Tree.Last then + Tree.Last := Z; + end if; + end if; + + Ops.Set_Parent (Z, Y); + Ops.Rebalance_For_Insert (Tree, Z); + Tree.Length := New_Length; + end Generic_Insert_Post; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration + (Tree : Tree_Type; + Key : Key_Type) + is + procedure Iterate (Node : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (Node : Node_Access) is + N : Node_Access := Node; + begin + while N /= Ops.Null_Node loop + if Is_Less_Key_Node (Key, N) then + N := Ops.Left (N); + elsif Is_Greater_Key_Node (Key, N) then + N := Ops.Right (N); + else + Iterate (Ops.Left (N)); + Process (N); + N := Ops.Right (N); + end if; + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration + (Tree : Tree_Type; + Key : Key_Type) + is + procedure Iterate (Node : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (Node : Node_Access) is + N : Node_Access := Node; + begin + while N /= Ops.Null_Node loop + if Is_Less_Key_Node (Key, N) then + N := Ops.Left (N); + elsif Is_Greater_Key_Node (Key, N) then + N := Ops.Right (N); + else + Iterate (Ops.Right (N)); + Process (N); + N := Ops.Left (N); + end if; + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ---------------------------------- + -- Generic_Unconditional_Insert -- + ---------------------------------- + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access) + is + Y : Node_Access := Ops.Null_Node; + X : Node_Access := Tree.Root; + + begin + while X /= Ops.Null_Node loop + Y := X; + + if Is_Less_Key_Node (Key, X) then + X := Ops.Left (X); + else + X := Ops.Right (X); + end if; + end loop; + + Insert_Post (Tree, X, Y, Key, Node); + end Generic_Unconditional_Insert; + + -------------------------------------------- + -- Generic_Unconditional_Insert_With_Hint -- + -------------------------------------------- + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type; + Hint : Node_Access; + Key : Key_Type; + Node : out Node_Access) + is + -- TODO: verify this algorithm. It was (quickly) adapted it from the + -- same algorithm for conditional_with_hint. It may be that the test + -- Key > Hint should be something like a Key >= Hint, to handle the + -- case when Hint is The Last Item of A (Contiguous) sequence of + -- Equivalent Items. (The Key < Hint Test is probably OK. It is not + -- clear that you can use Key <= Hint, since new items are always + -- inserted last in the sequence of equivalent items.) ??? + + begin + if Hint = Ops.Null_Node then -- largest + if Tree.Length > 0 + and then Is_Greater_Key_Node (Key, Tree.Last) + then + Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node); + else + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + end if; + + return; + end if; + + pragma Assert (Tree.Length > 0); + + if Is_Less_Key_Node (Key, Hint) then + if Hint = Tree.First then + Insert_Post (Tree, Hint, Hint, Key, Node); + return; + end if; + + declare + Before : constant Node_Access := Ops.Previous (Hint); + begin + if Is_Greater_Key_Node (Key, Before) then + if Ops.Right (Before) = Ops.Null_Node then + Insert_Post (Tree, Ops.Null_Node, Before, Key, Node); + else + Insert_Post (Tree, Hint, Hint, Key, Node); + end if; + else + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + end if; + end; + + return; + end if; + + if Is_Greater_Key_Node (Key, Hint) then + if Hint = Tree.Last then + Insert_Post (Tree, Ops.Null_Node, Tree.Last, Key, Node); + return; + end if; + + declare + After : constant Node_Access := Ops.Next (Hint); + begin + if Is_Less_Key_Node (Key, After) then + if Ops.Right (Hint) = Ops.Null_Node then + Insert_Post (Tree, Ops.Null_Node, Hint, Key, Node); + else + Insert_Post (Tree, After, After, Key, Node); + end if; + else + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + end if; + end; + + return; + end if; + + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + end Generic_Unconditional_Insert_With_Hint; + + ----------------- + -- Upper_Bound -- + ----------------- + + function Upper_Bound + (Tree : Tree_Type; + Key : Key_Type) return Node_Access + is + Y : Node_Access; + X : Node_Access := Tree.Root; + + begin + while X /= Ops.Null_Node loop + if Is_Less_Key_Node (Key, X) then + Y := X; + X := Ops.Left (X); + else + X := Ops.Right (X); + end if; + end loop; + + return Y; + end Upper_Bound; + +end Ada.Containers.Red_Black_Trees.Generic_Keys; + + diff --git a/gcc/ada/a-crbtgk.ads b/gcc/ada/a-crbtgk.ads new file mode 100644 index 00000000000..445c28b1c9d --- /dev/null +++ b/gcc/ada/a-crbtgk.ads @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees.Generic_Operations; + +generic + with package Tree_Operations is new Generic_Operations (<>); + + use Tree_Operations.Tree_Types; + + type Key_Type (<>) is limited private; + + with function Is_Less_Key_Node + (L : Key_Type; + R : Node_Access) return Boolean; + + with function Is_Greater_Key_Node + (L : Key_Type; + R : Node_Access) return Boolean; + +package Ada.Containers.Red_Black_Trees.Generic_Keys is +pragma Pure (Generic_Keys); + + generic + with function New_Node return Node_Access; + procedure Generic_Insert_Post + (Tree : in out Tree_Type; + X, Y : Node_Access; + Key : Key_Type; + Z : out Node_Access); + + generic + with procedure Insert_Post + (Tree : in out Tree_Type; + X, Y : Node_Access; + Key : Key_Type; + Z : out Node_Access); + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Success : out Boolean); + + generic + with procedure Insert_Post + (Tree : in out Tree_Type; + X, Y : Node_Access; + Key : Key_Type; + Z : out Node_Access); + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access); + + generic + with procedure Insert_Post + (Tree : in out Tree_Type; + X, Y : Node_Access; + Key : Key_Type; + Z : out Node_Access); + + with procedure Unconditional_Insert_Sans_Hint + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access); + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type; + Hint : Node_Access; + Key : Key_Type; + Node : out Node_Access); + + generic + with procedure Insert_Post + (Tree : in out Tree_Type; + X, Y : Node_Access; + Key : Key_Type; + Z : out Node_Access); + + with procedure Conditional_Insert_Sans_Hint + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Success : out Boolean); + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type; + Position : Node_Access; + Key : Key_Type; + Node : out Node_Access; + Success : out Boolean); + + function Find + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + + function Ceiling + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + + function Floor + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + + function Upper_Bound + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Iteration + (Tree : Tree_Type; + Key : Key_Type); + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Reverse_Iteration + (Tree : Tree_Type; + Key : Key_Type); + +end Ada.Containers.Red_Black_Trees.Generic_Keys; + + + diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb new file mode 100644 index 00000000000..9f9b7125c6f --- /dev/null +++ b/gcc/ada/a-crbtgo.adb @@ -0,0 +1,879 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Red_Black_Trees.Generic_Operations is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access); + + procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access); + + procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); + procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); + + --------------------- + -- Check_Invariant -- + --------------------- + + procedure Check_Invariant (Tree : Tree_Type) is + Root : constant Node_Access := Tree.Root; + + function Check (Node : Node_Access) return Natural; + + ----------- + -- Check -- + ----------- + + function Check (Node : Node_Access) return Natural is + begin + if Node = Null_Node then + return 0; + end if; + + if Color (Node) = Red then + declare + L : constant Node_Access := Left (Node); + begin + pragma Assert (L = Null_Node or else Color (L) = Black); + null; + end; + + declare + R : constant Node_Access := Right (Node); + begin + pragma Assert (R = Null_Node or else Color (R) = Black); + null; + end; + + declare + NL : constant Natural := Check (Left (Node)); + NR : constant Natural := Check (Right (Node)); + begin + pragma Assert (NL = NR); + return NL; + end; + end if; + + declare + NL : constant Natural := Check (Left (Node)); + NR : constant Natural := Check (Right (Node)); + begin + pragma Assert (NL = NR); + return NL + 1; + end; + end Check; + + -- Start of processing for Check_Invariant + + begin + if Root = Null_Node then + pragma Assert (Tree.First = Null_Node); + pragma Assert (Tree.Last = Null_Node); + pragma Assert (Tree.Length = 0); + null; + + else + pragma Assert (Color (Root) = Black); + pragma Assert (Tree.Length > 0); + pragma Assert (Tree.Root /= Null_Node); + pragma Assert (Tree.First /= Null_Node); + pragma Assert (Tree.Last /= Null_Node); + pragma Assert (Parent (Tree.Root) = Null_Node); + pragma Assert ((Tree.Length > 1) + or else (Tree.First = Tree.Last + and Tree.First = Tree.Root)); + pragma Assert (Left (Tree.First) = Null_Node); + pragma Assert (Right (Tree.Last) = Null_Node); + + declare + L : constant Node_Access := Left (Root); + R : constant Node_Access := Right (Root); + NL : constant Natural := Check (L); + NR : constant Natural := Check (R); + begin + pragma Assert (NL = NR); + null; + end; + end if; + end Check_Invariant; + + ------------------ + -- Delete_Fixup -- + ------------------ + + procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is + + -- CLR p274 ??? + + X : Node_Access := Node; + W : Node_Access; + + begin + while X /= Tree.Root + and then Color (X) = Black + loop + if X = Left (Parent (X)) then + W := Right (Parent (X)); + + if Color (W) = Red then + Set_Color (W, Black); + Set_Color (Parent (X), Red); + Left_Rotate (Tree, Parent (X)); + W := Right (Parent (X)); + end if; + + if (Left (W) = Null_Node or else Color (Left (W)) = Black) + and then + (Right (W) = Null_Node or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Right (W) = Null_Node + or else Color (Right (W)) = Black + then + if Left (W) /= Null_Node then + Set_Color (Left (W), Black); + end if; + + Set_Color (W, Red); + Right_Rotate (Tree, W); + W := Right (Parent (X)); + end if; + + Set_Color (W, Color (Parent (X))); + Set_Color (Parent (X), Black); + Set_Color (Right (W), Black); + Left_Rotate (Tree, Parent (X)); + X := Tree.Root; + end if; + + else + pragma Assert (X = Right (Parent (X))); + + W := Left (Parent (X)); + + if Color (W) = Red then + Set_Color (W, Black); + Set_Color (Parent (X), Red); + Right_Rotate (Tree, Parent (X)); + W := Left (Parent (X)); + end if; + + if (Left (W) = Null_Node or else Color (Left (W)) = Black) + and then + (Right (W) = Null_Node or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Left (W) = Null_Node or else Color (Left (W)) = Black then + if Right (W) /= Null_Node then + Set_Color (Right (W), Black); + end if; + + Set_Color (W, Red); + Left_Rotate (Tree, W); + W := Left (Parent (X)); + end if; + + Set_Color (W, Color (Parent (X))); + Set_Color (Parent (X), Black); + Set_Color (Left (W), Black); + Right_Rotate (Tree, Parent (X)); + X := Tree.Root; + end if; + end if; + end loop; + + Set_Color (X, Black); + end Delete_Fixup; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type; + Node : Node_Access) + is + -- CLR p273 ??? + + X, Y : Node_Access; + + Z : constant Node_Access := Node; + pragma Assert (Z /= Null_Node); + + begin + pragma Assert (Tree.Length > 0); + pragma Assert (Tree.Root /= Null_Node); + pragma Assert (Tree.First /= Null_Node); + pragma Assert (Tree.Last /= Null_Node); + pragma Assert (Parent (Tree.Root) = Null_Node); + pragma Assert ((Tree.Length > 1) + or else (Tree.First = Tree.Last + and then Tree.First = Tree.Root)); + pragma Assert ((Left (Node) = Null_Node) + or else (Parent (Left (Node)) = Node)); + pragma Assert ((Right (Node) = Null_Node) + or else (Parent (Right (Node)) = Node)); + pragma Assert (((Parent (Node) = Null_Node) and then (Tree.Root = Node)) + or else ((Parent (Node) /= Null_Node) and then + ((Left (Parent (Node)) = Node) + or else (Right (Parent (Node)) = Node)))); + + if Left (Z) = Null_Node then + if Right (Z) = Null_Node then + if Z = Tree.First then + Tree.First := Parent (Z); + end if; + + if Z = Tree.Last then + Tree.Last := Parent (Z); + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (Z) = Null_Node); + pragma Assert (Right (Z) = Null_Node); + + if Z = Tree.Root then + pragma Assert (Tree.Length = 1); + pragma Assert (Parent (Z) = Null_Node); + Tree.Root := Null_Node; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Null_Node); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Null_Node); + end if; + + else + pragma Assert (Z /= Tree.Last); + + X := Right (Z); + + if Z = Tree.First then + Tree.First := Min (X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), X); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), X); + end if; + + Set_Parent (X, Parent (Z)); + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + + elsif Right (Z) = Null_Node then + pragma Assert (Z /= Tree.First); + + X := Left (Z); + + if Z = Tree.Last then + Tree.Last := Max (X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), X); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), X); + end if; + + Set_Parent (X, Parent (Z)); + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + + else + pragma Assert (Z /= Tree.First); + pragma Assert (Z /= Tree.Last); + + Y := Next (Z); + pragma Assert (Left (Y) = Null_Node); + + X := Right (Y); + + if X = Null_Node then + if Y = Left (Parent (Y)) then + pragma Assert (Parent (Y) /= Z); + Delete_Swap (Tree, Z, Y); + Set_Left (Parent (Z), Z); + + else + pragma Assert (Y = Right (Parent (Y))); + pragma Assert (Parent (Y) = Z); + Set_Parent (Y, Parent (Z)); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Y); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Y); + end if; + + Set_Left (Y, Left (Z)); + Set_Parent (Left (Y), Y); + Set_Right (Y, Z); + Set_Parent (Z, Y); + Set_Left (Z, Null_Node); + Set_Right (Z, Null_Node); + + declare + Y_Color : constant Color_Type := Color (Y); + begin + Set_Color (Y, Color (Z)); + Set_Color (Z, Y_Color); + end; + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (Z) = Null_Node); + pragma Assert (Right (Z) = Null_Node); + + if Z = Right (Parent (Z)) then + Set_Right (Parent (Z), Null_Node); + else + pragma Assert (Z = Left (Parent (Z))); + Set_Left (Parent (Z), Null_Node); + end if; + + else + if Y = Left (Parent (Y)) then + pragma Assert (Parent (Y) /= Z); + + Delete_Swap (Tree, Z, Y); + + Set_Left (Parent (Z), X); + Set_Parent (X, Parent (Z)); + + else + pragma Assert (Y = Right (Parent (Y))); + pragma Assert (Parent (Y) = Z); + + Set_Parent (Y, Parent (Z)); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Y); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Y); + end if; + + Set_Left (Y, Left (Z)); + Set_Parent (Left (Y), Y); + + declare + Y_Color : constant Color_Type := Color (Y); + begin + Set_Color (Y, Color (Z)); + Set_Color (Z, Y_Color); + end; + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + end if; + + Tree.Length := Tree.Length - 1; + end Delete_Node_Sans_Free; + + ----------------- + -- Delete_Swap -- + ----------------- + + procedure Delete_Swap + (Tree : in out Tree_Type; + Z, Y : Node_Access) + is + pragma Assert (Z /= Y); + pragma Assert (Parent (Y) /= Z); + + Y_Parent : constant Node_Access := Parent (Y); + Y_Color : constant Color_Type := Color (Y); + + begin + Set_Parent (Y, Parent (Z)); + Set_Left (Y, Left (Z)); + Set_Right (Y, Right (Z)); + Set_Color (Y, Color (Z)); + + if Tree.Root = Z then + Tree.Root := Y; + elsif Right (Parent (Y)) = Z then + Set_Right (Parent (Y), Y); + else + pragma Assert (Left (Parent (Y)) = Z); + Set_Left (Parent (Y), Y); + end if; + + if Right (Y) /= Null_Node then + Set_Parent (Right (Y), Y); + end if; + + if Left (Y) /= Null_Node then + Set_Parent (Left (Y), Y); + end if; + + Set_Parent (Z, Y_Parent); + Set_Color (Z, Y_Color); + Set_Left (Z, Null_Node); + Set_Right (Z, Null_Node); + end Delete_Swap; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal (Left, Right : Tree_Type) return Boolean is + L_Node : Node_Access; + R_Node : Node_Access; + + begin + if Left.Length /= Right.Length then + return False; + end if; + + L_Node := Left.First; + R_Node := Right.First; + while L_Node /= Null_Node loop + if not Is_Equal (L_Node, R_Node) then + return False; + end if; + + L_Node := Next (L_Node); + R_Node := Next (R_Node); + end loop; + + return True; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (Tree : Tree_Type) is + procedure Iterate (P : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Node_Access) is + X : Node_Access := P; + begin + while X /= Null_Node loop + Iterate (Left (X)); + Process (X); + X := Right (X); + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type) is + + pragma Assert (Tree.Length = 0); + -- Clear and back node reinit was done by caller + + Node, Last_Node : Node_Access; + + begin + if N = 0 then + return; + end if; + + Node := New_Node; + pragma Assert (Node /= Null_Node); + pragma Assert (Color (Node) = Red); + + Set_Color (Node, Black); + + Tree.Root := Node; + Tree.First := Node; + Tree.Last := Node; + + Tree.Length := 1; + + for J in Count_Type range 2 .. N loop + Last_Node := Node; + pragma Assert (Last_Node = Tree.Last); + + Node := New_Node; + pragma Assert (Node /= Null_Node); + pragma Assert (Color (Node) = Red); + + Set_Right (Node => Last_Node, Right => Node); + Tree.Last := Node; + Set_Parent (Node => Node, Parent => Last_Node); + Rebalance_For_Insert (Tree, Node); + Tree.Length := Tree.Length + 1; + end loop; + end Generic_Read; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration (Tree : Tree_Type) + is + procedure Iterate (P : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Node_Access) is + X : Node_Access := P; + begin + while X /= Null_Node loop + Iterate (Right (X)); + Process (X); + X := Left (X); + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ----------------- + -- Left_Rotate -- + ----------------- + + procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is + + -- CLR p266 ??? + + Y : constant Node_Access := Right (X); + pragma Assert (Y /= Null_Node); + + begin + Set_Right (X, Left (Y)); + + if Left (Y) /= Null_Node then + Set_Parent (Left (Y), X); + end if; + + Set_Parent (Y, Parent (X)); + + if X = Tree.Root then + Tree.Root := Y; + elsif X = Left (Parent (X)) then + Set_Left (Parent (X), Y); + else + pragma Assert (X = Right (Parent (X))); + Set_Right (Parent (X), Y); + end if; + + Set_Left (Y, X); + Set_Parent (X, Y); + end Left_Rotate; + + --------- + -- Max -- + --------- + + function Max (Node : Node_Access) return Node_Access is + + -- CLR p248 ??? + + X : Node_Access := Node; + Y : Node_Access; + + begin + loop + Y := Right (X); + + if Y = Null_Node then + return X; + end if; + + X := Y; + end loop; + end Max; + + --------- + -- Min -- + --------- + + function Min (Node : Node_Access) return Node_Access is + + -- CLR p248 ??? + + X : Node_Access := Node; + Y : Node_Access; + + begin + loop + Y := Left (X); + + if Y = Null_Node then + return X; + end if; + + X := Y; + end loop; + end Min; + + ---------- + -- Move -- + ---------- + + procedure Move (Target, Source : in out Tree_Type) is + begin + if Target.Length > 0 then + raise Constraint_Error; + end if; + + Target := Source; + Source := (First => Null_Node, + Last => Null_Node, + Root => Null_Node, + Length => 0); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + -- CLR p249 ??? + + if Node = Null_Node then + return Null_Node; + end if; + + if Right (Node) /= Null_Node then + return Min (Right (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= Null_Node + and then X = Right (Y) + loop + X := Y; + Y := Parent (Y); + end loop; + + -- Why is this code commented out ??? + +-- if Right (X) /= Y then +-- return Y; +-- else +-- return X; +-- end if; + + return Y; + end; + end Next; + + -------------- + -- Previous -- + -------------- + + function Previous (Node : Node_Access) return Node_Access is + begin + if Node = Null_Node then + return Null_Node; + end if; + + if Left (Node) /= Null_Node then + return Max (Left (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= Null_Node + and then X = Left (Y) + loop + X := Y; + Y := Parent (Y); + end loop; + + -- Why is this code commented out ??? + +-- if Left (X) /= Y then +-- return Y; +-- else +-- return X; +-- end if; + + return Y; + end; + end Previous; + + -------------------------- + -- Rebalance_For_Insert -- + -------------------------- + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type; + Node : Node_Access) + is + -- CLR p.268 ??? + + X : Node_Access := Node; + pragma Assert (X /= Null_Node); + pragma Assert (Color (X) = Red); + + Y : Node_Access; + + begin + while X /= Tree.Root and then Color (Parent (X)) = Red loop + if Parent (X) = Left (Parent (Parent (X))) then + Y := Right (Parent (Parent (X))); + + if Y /= Null_Node and then Color (Y) = Red then + Set_Color (Parent (X), Black); + Set_Color (Y, Black); + Set_Color (Parent (Parent (X)), Red); + X := Parent (Parent (X)); + + else + if X = Right (Parent (X)) then + X := Parent (X); + Left_Rotate (Tree, X); + end if; + + Set_Color (Parent (X), Black); + Set_Color (Parent (Parent (X)), Red); + Right_Rotate (Tree, Parent (Parent (X))); + end if; + + else + pragma Assert (Parent (X) = Right (Parent (Parent (X)))); + + Y := Left (Parent (Parent (X))); + + if Y /= Null_Node and then Color (Y) = Red then + Set_Color (Parent (X), Black); + Set_Color (Y, Black); + Set_Color (Parent (Parent (X)), Red); + X := Parent (Parent (X)); + + else + if X = Left (Parent (X)) then + X := Parent (X); + Right_Rotate (Tree, X); + end if; + + Set_Color (Parent (X), Black); + Set_Color (Parent (Parent (X)), Red); + Left_Rotate (Tree, Parent (Parent (X))); + end if; + end if; + end loop; + + Set_Color (Tree.Root, Black); + end Rebalance_For_Insert; + + ------------------ + -- Right_Rotate -- + ------------------ + + procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is + X : constant Node_Access := Left (Y); + pragma Assert (X /= Null_Node); + + begin + Set_Left (Y, Right (X)); + + if Right (X) /= Null_Node then + Set_Parent (Right (X), Y); + end if; + + Set_Parent (X, Parent (Y)); + + if Y = Tree.Root then + Tree.Root := X; + elsif Y = Left (Parent (Y)) then + Set_Left (Parent (Y), X); + else + pragma Assert (Y = Right (Parent (Y))); + Set_Right (Parent (Y), X); + end if; + + Set_Right (X, Y); + Set_Parent (Y, X); + end Right_Rotate; + +end Ada.Containers.Red_Black_Trees.Generic_Operations; diff --git a/gcc/ada/a-crbtgo.ads b/gcc/ada/a-crbtgo.ads new file mode 100644 index 00000000000..3e13ae58e85 --- /dev/null +++ b/gcc/ada/a-crbtgo.ads @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + with package Tree_Types is new Generic_Tree_Types (<>); + use Tree_Types; + + Null_Node : Node_Access; + + with function Parent (Node : Node_Access) return Node_Access is <>; + with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>; + with function Left (Node : Node_Access) return Node_Access is <>; + with procedure Set_Left (Node : Node_Access; Left : Node_Access) is <>; + with function Right (Node : Node_Access) return Node_Access is <>; + with procedure Set_Right (Node : Node_Access; Right : Node_Access) is <>; + with function Color (Node : Node_Access) return Color_Type is <>; + with procedure Set_Color (Node : Node_Access; Color : Color_Type) is <>; + +package Ada.Containers.Red_Black_Trees.Generic_Operations is +pragma Pure; + + function Min (Node : Node_Access) return Node_Access; + + function Max (Node : Node_Access) return Node_Access; + + procedure Check_Invariant (Tree : Tree_Type); + + function Next (Node : Node_Access) return Node_Access; + + function Previous (Node : Node_Access) return Node_Access; + + procedure Move (Target, Source : in out Tree_Type); + + generic + with function Is_Equal (L, R : Node_Access) return Boolean; + function Generic_Equal (Left, Right : Tree_Type) return Boolean; + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type; + Node : Node_Access); + + generic + with procedure Process (Node : Node_Access) is <>; + procedure Generic_Iteration (Tree : Tree_Type); + + generic + with procedure Process (Node : Node_Access) is <>; + procedure Generic_Reverse_Iteration (Tree : Tree_Type); + + generic + with function New_Node return Node_Access is <>; + procedure Generic_Read (Tree : in out Tree_Type; N : Count_Type); + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type; + Node : Node_Access); + +end Ada.Containers.Red_Black_Trees.Generic_Operations; diff --git a/gcc/ada/a-lfztio.ads b/gcc/ada/a-lfztio.ads new file mode 100644 index 00000000000..d007464952c --- /dev/null +++ b/gcc/ada/a-lfztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-liztio.ads b/gcc/ada/a-liztio.ads new file mode 100644 index 00000000000..1bb3ef50bdf --- /dev/null +++ b/gcc/ada/a-liztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-llfzti.ads b/gcc/ada/a-llfzti.ads new file mode 100644 index 00000000000..9bda49b3a0e --- /dev/null +++ b/gcc/ada/a-llfzti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +--A D A . L O N G _ L O N G _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Long_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llizti.ads b/gcc/ada/a-llizti.ads new file mode 100644 index 00000000000..75b05df28dc --- /dev/null +++ b/gcc/ada/a-llizti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Long_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb new file mode 100644 index 00000000000..d775234a9c3 --- /dev/null +++ b/gcc/ada/a-rbtgso.adb @@ -0,0 +1,534 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is + Tgt : Node_Access := Target.First; + Src : Node_Access := Source.First; + + begin + + -- NOTE: must be done by client: + -- if Target'Address = Source'Address then + -- Clear (Target); + -- return; + -- end if; + + loop + if Tgt = Tree_Operations.Null_Node then + return; + end if; + + if Src = Tree_Operations.Null_Node then + return; + end if; + + if Is_Less (Tgt, Src) then + Tgt := Tree_Operations.Next (Tgt); + + elsif Is_Less (Src, Tgt) then + Src := Tree_Operations.Next (Src); + + else + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + Src := Tree_Operations.Next (Src); + end if; + end loop; + end Difference; + + function Difference (Left, Right : Tree_Type) return Tree_Type is + Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node); + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + + begin + -- NOTE: must by done by client: + -- if Left'Address = Right'Address then + -- return Empty_Set; + -- end if; + + loop + if L_Node = Tree_Operations.Null_Node then + return Tree; + end if; + + if R_Node = Tree_Operations.Null_Node then + while L_Node /= Tree_Operations.Null_Node loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Tree_Operations.Null_Node, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + + end loop; + + return Tree; + end if; + + if Is_Less (L_Node, R_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Tree_Operations.Null_Node, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end Difference; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Tree_Type; + Source : Tree_Type) + is + Tgt : Node_Access := Target.First; + Src : Node_Access := Source.First; + + begin + -- NOTE: must be done by caller: ??? + -- if Target'Address = Source'Address then + -- return; + -- end if; + + while Tgt /= Tree_Operations.Null_Node + and then Src /= Tree_Operations.Null_Node + loop + if Is_Less (Tgt, Src) then + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + elsif Is_Less (Src, Tgt) then + Src := Tree_Operations.Next (Src); + + else + Tgt := Tree_Operations.Next (Tgt); + Src := Tree_Operations.Next (Src); + end if; + end loop; + end Intersection; + + function Intersection (Left, Right : Tree_Type) return Tree_Type is + Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node); + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + + begin + -- NOTE: must be done by caller: ??? + -- if Left'Address = Right'Address then + -- return Left; + -- end if; + + loop + if L_Node = Tree_Operations.Null_Node then + return Tree; + end if; + + if R_Node = Tree_Operations.Null_Node then + return Tree; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Tree_Operations.Null_Node, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end Intersection; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Subset : Tree_Type; + Of_Set : Tree_Type) return Boolean + is + begin + -- NOTE: must by done by caller: + -- if Subset'Address = Of_Set'Address then + -- return True; + -- end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + declare + Subset_Node : Node_Access := Subset.First; + Set_Node : Node_Access := Of_Set.First; + + begin + loop + if Set_Node = Tree_Operations.Null_Node then + return Subset_Node = Tree_Operations.Null_Node; + end if; + + if Subset_Node = Tree_Operations.Null_Node then + return True; + end if; + + if Is_Less (Subset_Node, Set_Node) then + return False; + end if; + + if Is_Less (Set_Node, Subset_Node) then + Set_Node := Tree_Operations.Next (Set_Node); + else + Set_Node := Tree_Operations.Next (Set_Node); + Subset_Node := Tree_Operations.Next (Subset_Node); + end if; + end loop; + end; + end Is_Subset; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Tree_Type) return Boolean is + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + begin + -- NOTE: must be done by caller: ??? + -- if Left'Address = Right'Address then + -- return Left.Tree.Length /= 0; + -- end if; + + loop + if L_Node = Tree_Operations.Null_Node + or else R_Node = Tree_Operations.Null_Node + then + return False; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + return True; + end if; + end loop; + end Overlap; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Tree_Type; + Source : Tree_Type) + is + Tgt : Node_Access := Target.First; + Src : Node_Access := Source.First; + + New_Tgt_Node : Node_Access; + + begin + -- NOTE: must by done by client: ??? + -- if Target'Address = Source'Address then + -- Clear (Target); + -- return; + -- end if; + + loop + if Tgt = Tree_Operations.Null_Node then + while Src /= Tree_Operations.Null_Node loop + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => Tree_Operations.Null_Node, + Src_Node => Src, + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Src); + end loop; + + return; + end if; + + if Src = Tree_Operations.Null_Node then + return; + end if; + + if Is_Less (Tgt, Src) then + Tgt := Tree_Operations.Next (Tgt); + + elsif Is_Less (Src, Tgt) then + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => Tgt, + Src_Node => Src, + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Src); + + else + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + Src := Tree_Operations.Next (Src); + end if; + end loop; + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is + Tree : Tree_Type := (Length => 0, others => Tree_Operations.Null_Node); + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + + Dst_Node : Node_Access; + + begin + -- NOTE: must by done by caller ??? + -- if Left'Address = Right'Address then + -- return Empty_Set; + -- end if; + + loop + if L_Node = Tree_Operations.Null_Node then + while R_Node /= Tree_Operations.Null_Node loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Tree_Operations.Null_Node, + Src_Node => R_Node, + Dst_Node => Dst_Node); + R_Node := Tree_Operations.Next (R_Node); + end loop; + + return Tree; + end if; + + if R_Node = Tree_Operations.Null_Node then + while L_Node /= Tree_Operations.Null_Node loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Tree_Operations.Null_Node, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + return Tree; + end if; + + if Is_Less (L_Node, R_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Tree_Operations.Null_Node, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Tree_Operations.Null_Node, + Src_Node => R_Node, + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (R_Node); + + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Tree_Type; Source : Tree_Type) + is + Hint : Node_Access; + + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => Hint, + Src_Node => Node, + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + -- NOTE: must be done by caller: ??? + -- if Target'Address = Source'Address then + -- return; + -- end if; + + Iterate (Source); + end Union; + + function Union (Left, Right : Tree_Type) return Tree_Type is + Tree : Tree_Type; + + begin + -- NOTE: must be done by caller: + -- if Left'Address = Right'Address then + -- return Left; + -- end if; + + declare + Root : constant Node_Access := Copy_Tree (Left.Root); + begin + Tree := (Root => Root, + First => Tree_Operations.Min (Root), + Last => Tree_Operations.Max (Root), + Length => Left.Length); + end; + + declare + Hint : Node_Access; + + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Hint, + Src_Node => Node, + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + Iterate (Right); + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end; + + return Tree; + end Union; + +end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/a-rbtgso.ads b/gcc/ada/a-rbtgso.ads new file mode 100644 index 00000000000..e22059c0af4 --- /dev/null +++ b/gcc/ada/a-rbtgso.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees.Generic_Operations; + +generic + with package Tree_Operations is new Generic_Operations (<>); + + use Tree_Operations.Tree_Types; + + with procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + with function Copy_Tree (Source_Root : Node_Access) + return Node_Access; + + with procedure Delete_Tree (X : in out Node_Access); + + with function Is_Less (Left, Right : Node_Access) return Boolean; + + with procedure Free (X : in out Node_Access); + +package Ada.Containers.Red_Black_Trees.Generic_Set_Operations is +pragma Pure (Generic_Set_Operations); + + procedure Union (Target : in out Tree_Type; Source : Tree_Type); + + function Union (Left, Right : Tree_Type) return Tree_Type; + + procedure Intersection (Target : in out Tree_Type; Source : Tree_Type); + + function Intersection (Left, Right : Tree_Type) return Tree_Type; + + procedure Difference (Target : in out Tree_Type; Source : Tree_Type); + + function Difference (Left, Right : Tree_Type) return Tree_Type; + + procedure Symmetric_Difference + (Target : in out Tree_Type; + Source : Tree_Type); + + function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type; + + function Is_Subset (Subset : Tree_Type; Of_Set : Tree_Type) return Boolean; + + function Overlap (Left, Right : Tree_Type) return Boolean; + +end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/a-secain.adb b/gcc/ada/a-secain.adb new file mode 100644 index 00000000000..052632b3226 --- /dev/null +++ b/gcc/ada/a-secain.adb @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.EQUAL_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +function Ada.Strings.Equal_Case_Insensitive + (Left, Right : String) return Boolean +is + LI : Integer := Left'First; + RI : Integer := Right'First; + +begin + if Left'Length /= Right'Length then + return False; + end if; + + if Left'Length = 0 then + return True; + end if; + + loop + if To_Lower (Left (LI)) /= To_Lower (Right (RI)) then + return False; + end if; + + if LI = Left'Last then + return True; + end if; + + LI := LI + 1; + RI := RI + 1; + end loop; +end Ada.Strings.Equal_Case_Insensitive; + + + + + diff --git a/gcc/ada/a-secain.ads b/gcc/ada/a-secain.ads new file mode 100644 index 00000000000..f56b62ac9ee --- /dev/null +++ b/gcc/ada/a-secain.ads @@ -0,0 +1,20 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.EQUAL_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +function Ada.Strings.Equal_Case_Insensitive + (Left, Right : String) return Boolean; + +pragma Pure (Ada.Strings.Equal_Case_Insensitive); + diff --git a/gcc/ada/a-sfztio.ads b/gcc/ada/a-sfztio.ads new file mode 100644 index 00000000000..9fea38c8ff0 --- /dev/null +++ b/gcc/ada/a-sfztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-shcain.adb b/gcc/ada/a-shcain.adb new file mode 100644 index 00000000000..1c6e78f7f68 --- /dev/null +++ b/gcc/ada/a-shcain.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.HASH_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) + +function Ada.Strings.Hash_Case_Insensitive + (Key : String) return Containers.Hash_Type +is + use Ada.Containers; + + Tmp : Hash_Type; + + function Rotate_Left + (Value : Hash_Type; + Amount : Natural) return Hash_Type; + pragma Import (Intrinsic, Rotate_Left); + +begin + Tmp := 0; + for J in Key'Range loop + Tmp := Rotate_Left (Tmp, 1) + Character'Pos (To_Lower (Key (J))); + end loop; + + return Tmp; +end Ada.Strings.Hash_Case_Insensitive; + + + + + + + + + diff --git a/gcc/ada/a-shcain.ads b/gcc/ada/a-shcain.ads new file mode 100644 index 00000000000..24bd62c5978 --- /dev/null +++ b/gcc/ada/a-shcain.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.HASH_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Hash_Case_Insensitive + (Key : String) return Containers.Hash_Type; + +pragma Pure (Ada.Strings.Hash_Case_Insensitive); diff --git a/gcc/ada/a-siztio.ads b/gcc/ada/a-siztio.ads new file mode 100644 index 00000000000..ea42cc323c5 --- /dev/null +++ b/gcc/ada/a-siztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-slcain.adb b/gcc/ada/a-slcain.adb new file mode 100644 index 00000000000..6d395afaab8 --- /dev/null +++ b/gcc/ada/a-slcain.adb @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.LESS_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +function Ada.Strings.Less_Case_Insensitive + (Left, Right : String) return Boolean +is + LI : Integer := Left'First; + RI : Integer := Right'First; + + LC, RC : Character; + +begin + if LI > Left'Last then + return RI <= Right'Last; + end if; + + if RI > Right'Last then + return False; + end if; + + loop + LC := To_Lower (Left (LI)); + RC := To_Lower (Right (RI)); + + if LC < RC then + return True; + end if; + + if LC > RC then + return False; + end if; + + if LI = Left'Last then + return RI < Right'Last; + end if; + + if RI = Right'Last then + return False; + end if; + + LI := LI + 1; + RI := RI + 1; + end loop; +end Ada.Strings.Less_Case_Insensitive; + + diff --git a/gcc/ada/a-slcain.ads b/gcc/ada/a-slcain.ads new file mode 100644 index 00000000000..c54c6f24ec4 --- /dev/null +++ b/gcc/ada/a-slcain.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +function Ada.Strings.Less_Case_Insensitive + (Left, Right : String) return Boolean; + +pragma Pure (Ada.Strings.Less_Case_Insensitive); diff --git a/gcc/ada/a-ssizti.ads b/gcc/ada/a-ssizti.ads new file mode 100644 index 00000000000..a99211042cd --- /dev/null +++ b/gcc/ada/a-ssizti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Short_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-strhas.adb b/gcc/ada/a-strhas.adb new file mode 100644 index 00000000000..3dffb2006d9 --- /dev/null +++ b/gcc/ada/a-strhas.adb @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.HASH -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) + +function Ada.Strings.Hash (Key : String) return Containers.Hash_Type is + use Ada.Containers; + + function Rotate_Left + (Value : Hash_Type; + Amount : Natural) return Hash_Type; + pragma Import (Intrinsic, Rotate_Left); + + Tmp : Hash_Type; + +begin + Tmp := 0; + for J in Key'Range loop + Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key (J)); + end loop; + + return Tmp; +end Ada.Strings.Hash; + + + + + + + + diff --git a/gcc/ada/a-strhas.ads b/gcc/ada/a-strhas.ads new file mode 100644 index 00000000000..b3b71aecdea --- /dev/null +++ b/gcc/ada/a-strhas.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.HASH -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Hash (Key : String) return Containers.Hash_Type; + +pragma Pure (Ada.Strings.Hash); + + diff --git a/gcc/ada/a-stunha.adb b/gcc/ada/a-stunha.adb new file mode 100644 index 00000000000..a6b6920514e --- /dev/null +++ b/gcc/ada/a-stunha.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.HASH -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) + +function Ada.Strings.Unbounded.Hash + (Key : Unbounded_String) return Containers.Hash_Type +is + use Ada.Containers; + + function Rotate_Left + (Value : Hash_Type; + Amount : Natural) return Hash_Type; + pragma Import (Intrinsic, Rotate_Left); + + Tmp : Hash_Type; + +begin + Tmp := 0; + for J in 1 .. Key.Last loop + Tmp := Rotate_Left (Tmp, 1) + Character'Pos (Key.Reference (J)); + end loop; + + return Tmp; +end Ada.Strings.Unbounded.Hash; diff --git a/gcc/ada/a-stunha.ads b/gcc/ada/a-stunha.ads new file mode 100644 index 00000000000..b838bcbdcdf --- /dev/null +++ b/gcc/ada/a-stunha.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.HASH -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004 Free Software Foundation, Inc. -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Unbounded.Hash + (Key : Unbounded_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Unbounded.Hash); diff --git a/gcc/ada/a-stwiha.adb b/gcc/ada/a-stwiha.adb new file mode 100644 index 00000000000..f218b486cc3 --- /dev/null +++ b/gcc/ada/a-stwiha.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_HASH -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) + +function Ada.Strings.Wide_Hash + (Key : Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + + function Rotate_Left + (Value : Hash_Type; + Amount : Natural) return Hash_Type; + pragma Import (Intrinsic, Rotate_Left); + + Tmp : Hash_Type; + +begin + Tmp := 0; + for J in Key'Range loop + Tmp := Rotate_Left (Tmp, 1) + Wide_Character'Pos (Key (J)); + end loop; + + return Tmp; +end Ada.Strings.Wide_Hash; + + diff --git a/gcc/ada/a-stwiha.ads b/gcc/ada/a-stwiha.ads new file mode 100644 index 00000000000..349b8919f16 --- /dev/null +++ b/gcc/ada/a-stwiha.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_HASH -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Wide_Hash + (Key : Wide_String) return Containers.Hash_Type; + +pragma Pure (Ada.Strings.Wide_Hash); + + + diff --git a/gcc/ada/a-stzbou.adb b/gcc/ada/a-stzbou.adb new file mode 100644 index 00000000000..baf4c537d21 --- /dev/null +++ b/gcc/ada/a-stzbou.adb @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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_Bounded is + + package body Generic_Bounded_Length is + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Bounded_Wide_Wide_String + is + begin + return Times (Left, Right, Max_Length); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Bounded_Wide_Wide_String + is + begin + return Times (Left, Right, Max_Length); + end "*"; + + --------------- + -- Replicate -- + --------------- + + function Replicate + (Count : Natural; + Item : Wide_Wide_Character; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_Wide_String + is + begin + return Super_Replicate (Count, Item, Drop, Max_Length); + end Replicate; + + function Replicate + (Count : Natural; + Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_Wide_String + is + begin + return Super_Replicate (Count, Item, Drop, Max_Length); + end Replicate; + + --------------------------------- + -- To_Bounded_Wide_Wide_String -- + --------------------------------- + + function To_Bounded_Wide_Wide_String + (Source : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_Wide_String + is + begin + return To_Super_String (Source, Max_Length, Drop); + end To_Bounded_Wide_Wide_String; + + end Generic_Bounded_Length; +end Ada.Strings.Wide_Wide_Bounded; diff --git a/gcc/ada/a-stzbou.ads b/gcc/ada/a-stzbou.ads new file mode 100644 index 00000000000..5ea7f7aa480 --- /dev/null +++ b/gcc/ada/a-stzbou.ads @@ -0,0 +1,920 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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_Maps; +with Ada.Strings.Wide_Wide_Superbounded; + +package Ada.Strings.Wide_Wide_Bounded is +pragma Preelaborate (Wide_Wide_Bounded); + + generic + Max : Positive; + -- Maximum length of a Bounded_Wide_Wide_String + + package Generic_Bounded_Length is + + Max_Length : constant Positive := Max; + + type Bounded_Wide_Wide_String is private; + + Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String; + + subtype Length_Range is Natural range 0 .. Max_Length; + + function Length (Source : Bounded_Wide_Wide_String) return Length_Range; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Bounded_Wide_Wide_String + (Source : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function To_Wide_Wide_String + (Source : Bounded_Wide_Wide_String) return Wide_Wide_String; + + procedure Set_Bounded_Wide_Wide_String + (Target : out Bounded_Wide_Wide_String; + Source : Wide_Wide_String; + Drop : Truncation := Error); + pragma Ada_05 (Set_Bounded_Wide_Wide_String); + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Append + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Append + (Left : Wide_Wide_Character; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Bounded_Wide_Wide_String; + Drop : Truncation := Error); + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Wide_Wide_Character; + Drop : Truncation := Error); + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Bounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Bounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_Character; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; + + function Element + (Source : Bounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character; + + procedure Replace_Element + (Source : in out Bounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character); + + function Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Bounded_Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Bounded_Wide_Wide_String; + pragma Ada_05 (Bounded_Slice); + + procedure Bounded_Slice + (Source : Bounded_Wide_Wide_String; + Target : out Bounded_Wide_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Bounded_Slice); + + function "=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Index + (Source : Bounded_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 : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Bounded_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 : Bounded_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 : Bounded_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 : Bounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Bounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Bounded_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 : Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Bounded_Wide_Wide_String; + + procedure Translate + (Source : in out Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Bounded_Wide_Wide_String; + + procedure Translate + (Source : in out Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Bounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error); + + function Insert + (Source : Bounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Insert + (Source : in out Bounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Overwrite + (Source : Bounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Overwrite + (Source : in out Bounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Delete + (Source : Bounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Bounded_Wide_Wide_String; + + procedure Delete + (Source : in out Bounded_Wide_Wide_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Trim + (Source : Bounded_Wide_Wide_String; + Side : Trim_End) return Bounded_Wide_Wide_String; + + procedure Trim + (Source : in out Bounded_Wide_Wide_String; + Side : Trim_End); + + function Trim + (Source : Bounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Bounded_Wide_Wide_String; + + procedure Trim + (Source : in out Bounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Head + (Source : Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Head + (Source : in out Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error); + + function Tail + (Source : Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Tail + (Source : in out Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Bounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Bounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; + + function Replicate + (Count : Natural; + Item : Wide_Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Replicate + (Count : Natural; + Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Replicate + (Count : Natural; + Item : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + private + -- Most of the implementation is in the separate non generic package + -- Ada.Strings.Wide_Wide_Superbounded. Type Bounded_Wide_Wide_String is + -- derived from type Wide_Wide_Superbounded.Super_String with the + -- maximum length constraint. In almost all cases, the routines in + -- Wide_Wide_Superbounded can be called with no requirement to pass the + -- maximum length explicitly, since there is at least one + -- Bounded_Wide_Wide_String argument from which the maximum length can + -- be obtained. For all such routines, the implementation in this + -- private part is simply renaming of the corresponding routine in the + -- super bouded package. + + -- The five exceptions are the * and Replicate routines operating on + -- character values. For these cases, we have a routine in the body + -- that calls the superbounded routine passing the maximum length + -- explicitly as an extra parameter. + + type Bounded_Wide_Wide_String is + new Wide_Wide_Superbounded.Super_String (Max_Length); + -- Deriving Bounded_Wide_Wide_String from + -- Wide_Wide_Superbounded.Super_String is the real trick, it ensures + -- that the type Bounded_Wide_Wide_String declared in the generic + -- instantiation is compatible with the Super_String type declared in + -- the Wide_Wide_Superbounded package. + + Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String := + (Max_Length => Max_Length, + Current_Length => 0, + Data => + (1 .. Max_Length => + Wide_Wide_Superbounded.Wide_Wide_NUL)); + + pragma Inline (To_Bounded_Wide_Wide_String); + + procedure Set_Bounded_Wide_Wide_String + (Target : out Bounded_Wide_Wide_String; + Source : Wide_Wide_String; + Drop : Truncation := Error) + renames Set_Super_String; + + function Length + (Source : Bounded_Wide_Wide_String) return Length_Range + renames Super_Length; + + function To_Wide_Wide_String + (Source : Bounded_Wide_Wide_String) return Wide_Wide_String + renames Super_To_String; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + function Append + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + function Append + (Left : Wide_Wide_Character; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Bounded_Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Wide_Wide_Character; + Drop : Truncation := Error) + renames Super_Append; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String + renames Concat; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Bounded_Wide_Wide_String + renames Concat; + + function "&" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String + renames Concat; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Bounded_Wide_Wide_String + renames Concat; + + function "&" + (Left : Wide_Wide_Character; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String + renames Concat; + + function Element + (Source : Bounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + renames Super_Element; + + procedure Replace_Element + (Source : in out Bounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + renames Super_Replace_Element; + + function Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + renames Super_Slice; + + function Bounded_Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Bounded_Wide_Wide_String + renames Super_Slice; + + procedure Bounded_Slice + (Source : Bounded_Wide_Wide_String; + Target : out Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) + renames Super_Slice; + + function "=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Equal; + + function "=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Equal; + + function "=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Equal; + + function "<" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Less; + + function "<" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Less; + + function "<" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Less; + + function "<=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Less_Or_Equal; + + function "<=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Less_Or_Equal; + + function "<=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Less_Or_Equal; + + function ">" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Greater; + + function ">" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Greater; + + function ">" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Greater; + + function ">=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Greater_Or_Equal; + + function ">=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Greater_Or_Equal; + + function ">=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Greater_Or_Equal; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Super_Index; + + function Index + (Source : Bounded_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 + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Super_Index; + + function Index_Non_Blank + (Source : Bounded_Wide_Wide_String; + Going : Direction := Forward) return Natural + renames Super_Index_Non_Blank; + + function Index_Non_Blank + (Source : Bounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + renames Super_Index_Non_Blank; + + function Count + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Super_Count; + + function Count + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Super_Count; + + function Count + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + renames Super_Count; + + procedure Find_Token + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Super_Find_Token; + + function Translate + (Source : Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Bounded_Wide_Wide_String + renames Super_Translate; + + procedure Translate + (Source : in out Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + renames Super_Translate; + + function Translate + (Source : Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Bounded_Wide_Wide_String + renames Super_Translate; + + procedure Translate + (Source : in out Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + renames Super_Translate; + + function Replace_Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Replace_Slice; + + procedure Replace_Slice + (Source : in out Bounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Replace_Slice; + + function Insert + (Source : Bounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Insert; + + procedure Insert + (Source : in out Bounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Insert; + + function Overwrite + (Source : Bounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Overwrite; + + procedure Overwrite + (Source : in out Bounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Overwrite; + + function Delete + (Source : Bounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Bounded_Wide_Wide_String + renames Super_Delete; + + procedure Delete + (Source : in out Bounded_Wide_Wide_String; + From : Positive; + Through : Natural) + renames Super_Delete; + + function Trim + (Source : Bounded_Wide_Wide_String; + Side : Trim_End) return Bounded_Wide_Wide_String + renames Super_Trim; + + procedure Trim + (Source : in out Bounded_Wide_Wide_String; + Side : Trim_End) + renames Super_Trim; + + function Trim + (Source : Bounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Bounded_Wide_Wide_String + renames Super_Trim; + + procedure Trim + (Source : in out Bounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + renames Super_Trim; + + function Head + (Source : Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Head; + + procedure Head + (Source : in out Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) + renames Super_Head; + + function Tail + (Source : Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Tail; + + procedure Tail + (Source : in out Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) + renames Super_Tail; + + function "*" + (Left : Natural; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String + renames Times; + + function Replicate + (Count : Natural; + Item : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Replicate; + + end Generic_Bounded_Length; + +end Ada.Strings.Wide_Wide_Bounded; diff --git a/gcc/ada/a-stzfix.adb b/gcc/ada/a-stzfix.adb new file mode 100644 index 00000000000..7ab6e4434c4 --- /dev/null +++ b/gcc/ada/a-stzfix.adb @@ -0,0 +1,681 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ F I X E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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_Maps; use Ada.Strings.Wide_Wide_Maps; +with Ada.Strings.Wide_Wide_Search; + +package body Ada.Strings.Wide_Wide_Fixed is + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : 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 + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Ada.Strings.Wide_Wide_Search.Count; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Ada.Strings.Wide_Wide_Search.Count; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + renames Ada.Strings.Wide_Wide_Search.Count; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Wide_Wide_Search.Find_Token; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Left); + + begin + for J in Result'Range loop + Result (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Left * Right'Length); + Ptr : Integer := 1; + + begin + for J in 1 .. Left loop + Result (Ptr .. Ptr + Right'Length - 1) := Right; + Ptr := Ptr + Right'Length; + end loop; + + return Result; + end "*"; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Wide_Wide_String; + From : Positive; + Through : Natural) return Wide_Wide_String + is + begin + if From not in Source'Range + or else Through > Source'Last + then + raise Index_Error; + + elsif From > Through then + return Source; + + else + declare + Len : constant Integer := Source'Length - (Through - From + 1); + Result : constant Wide_Wide_String + (Source'First .. Source'First + Len - 1) := + Source (Source'First .. From - 1) & + Source (Through + 1 .. Source'Last); + begin + return Result; + end; + end if; + end Delete; + + procedure Delete + (Source : in out Wide_Wide_String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Source => Delete (Source, From, Through), + Target => Source, + Justify => Justify, + Pad => Pad); + end Delete; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Count); + + begin + if Count <= Source'Length then + Result := Source (Source'First .. Source'First + Count - 1); + + else + Result (1 .. Source'Length) := Source; + + for J in Source'Length + 1 .. Count loop + Result (J) := Pad; + end loop; + end if; + + return Result; + end Head; + + procedure Head + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + is + begin + Move (Source => Head (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Head; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Source'Length + New_Item'Length); + + begin + if Before < Source'First or else Before > Source'Last + 1 then + raise Index_Error; + end if; + + Result := Source (Source'First .. Before - 1) & New_Item & + Source (Before .. Source'Last); + return Result; + end Insert; + + procedure Insert + (Source : in out Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + is + begin + Move (Source => Insert (Source, Before, New_Item), + Target => Source, + Drop => Drop); + end Insert; + + ---------- + -- Move -- + ---------- + + procedure Move + (Source : Wide_Wide_String; + Target : out Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + Sfirst : constant Integer := Source'First; + Slast : constant Integer := Source'Last; + Slength : constant Integer := Source'Length; + + Tfirst : constant Integer := Target'First; + Tlast : constant Integer := Target'Last; + Tlength : constant Integer := Target'Length; + + function Is_Padding (Item : Wide_Wide_String) return Boolean; + -- Determinbe if all characters in Item are pad characters + + function Is_Padding (Item : Wide_Wide_String) return Boolean is + begin + for J in Item'Range loop + if Item (J) /= Pad then + return False; + end if; + end loop; + + return True; + end Is_Padding; + + -- Start of processing for Move + + begin + if Slength = Tlength then + Target := Source; + + elsif Slength > Tlength then + + case Drop is + when Left => + Target := Source (Slast - Tlength + 1 .. Slast); + + when Right => + Target := Source (Sfirst .. Sfirst + Tlength - 1); + + when Error => + case Justify is + when Left => + if Is_Padding (Source (Sfirst + Tlength .. Slast)) then + Target := + Source (Sfirst .. Sfirst + Target'Length - 1); + else + raise Length_Error; + end if; + + when Right => + if Is_Padding (Source (Sfirst .. Slast - Tlength)) then + Target := Source (Slast - Tlength + 1 .. Slast); + else + raise Length_Error; + end if; + + when Center => + raise Length_Error; + end case; + + end case; + + -- Source'Length < Target'Length + + else + case Justify is + when Left => + Target (Tfirst .. Tfirst + Slength - 1) := Source; + + for J in Tfirst + Slength .. Tlast loop + Target (J) := Pad; + end loop; + + when Right => + for J in Tfirst .. Tlast - Slength loop + Target (J) := Pad; + end loop; + + Target (Tlast - Slength + 1 .. Tlast) := Source; + + when Center => + declare + Front_Pad : constant Integer := (Tlength - Slength) / 2; + Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; + + begin + for J in Tfirst .. Tfirst_Fpad - 1 loop + Target (J) := Pad; + end loop; + + Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; + + for J in Tfirst_Fpad + Slength .. Tlast loop + Target (J) := Pad; + end loop; + end; + end case; + end if; + end Move; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String + is + begin + if Position not in Source'First .. Source'Last + 1 then + raise Index_Error; + else + declare + Result_Length : constant Natural := + Natural'Max + (Source'Length, + Position - Source'First + New_Item'Length); + + Result : Wide_Wide_String (1 .. Result_Length); + + begin + Result := Source (Source'First .. Position - 1) & New_Item & + Source (Position + New_Item'Length .. Source'Last); + return Result; + end; + end if; + end Overwrite; + + procedure Overwrite + (Source : in out Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Right) + is + begin + Move (Source => Overwrite (Source, Position, New_Item), + Target => Source, + Drop => Drop); + end Overwrite; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Wide_Wide_String + is + Result_Length : Natural; + + begin + if Low > Source'Last + 1 or else High < Source'First - 1 then + raise Index_Error; + else + Result_Length := + Source'Length - Natural'Max (High - Low + 1, 0) + By'Length; + + declare + Result : Wide_Wide_String (1 .. Result_Length); + + begin + if High >= Low then + Result := + Source (Source'First .. Low - 1) & By & + Source (High + 1 .. Source'Last); + else + Result := Source (Source'First .. Low - 1) & By & + Source (Low .. Source'Last); + end if; + + return Result; + end; + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); + end Replace_Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Count); + + begin + if Count < Source'Length then + Result := Source (Source'Last - Count + 1 .. Source'Last); + + -- Pad on left + + else + for J in 1 .. Count - Source'Length loop + Result (J) := Pad; + end loop; + + Result (Count - Source'Length + 1 .. Count) := Source; + end if; + + return Result; + end Tail; + + procedure Tail + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + is + begin + Move (Source => Tail (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Tail; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + begin + for J in Source'Range loop + Source (J) := Value (Mapping, Source (J)); + end loop; + end Translate; + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Mapping (Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + begin + for J in Source'Range loop + Source (J) := Mapping (Source (J)); + end loop; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Wide_Wide_String; + Side : Trim_End) return Wide_Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + if Side = Left or else Side = Both then + while Low <= High and then Source (Low) = Wide_Wide_Space loop + Low := Low + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while High >= Low and then Source (High) = Wide_Wide_Space loop + High := High - 1; + end loop; + end if; + + -- All blanks case + + if Low > High then + return ""; + + -- At least one non-blank + + else + declare + Result : constant Wide_Wide_String (1 .. High - Low + 1) := + Source (Low .. High); + + begin + return Result; + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Source => Trim (Source, Side), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + + function Trim + (Source : Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Wide_Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + while Low <= High and then Is_In (Source (Low), Left) loop + Low := Low + 1; + end loop; + + while High >= Low and then Is_In (Source (High), Right) loop + High := High - 1; + end loop; + + -- Case where source comprises only characters in the sets + + if Low > High then + return ""; + else + declare + subtype WS is Wide_Wide_String (1 .. High - Low + 1); + + begin + return WS (Source (Low .. High)); + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set; + Justify : Alignment := Strings.Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Source => Trim (Source, Left, Right), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + +end Ada.Strings.Wide_Wide_Fixed; diff --git a/gcc/ada/a-stzfix.ads b/gcc/ada/a-stzfix.ads new file mode 100644 index 00000000000..b7f3ae77194 --- /dev/null +++ b/gcc/ada/a-stzfix.ads @@ -0,0 +1,256 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + + +with Ada.Strings.Wide_Wide_Maps; + +package Ada.Strings.Wide_Wide_Fixed is +pragma Preelaborate (Wide_Wide_Fixed); + + ------------------------------------------------------------------------ + -- Copy Procedure for Wide_Wide_Strings of Possibly Different Lengths -- + ------------------------------------------------------------------------ + + procedure Move + (Source : Wide_Wide_String; + Target : out Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : 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 : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : 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 : 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 : 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 : Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ---------------------------------------------- + -- Wide_Wide_String Translation Subprograms -- + ---------------------------------------------- + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Wide_Wide_String; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Wide_Wide_String; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + ------------------------------------------------- + -- Wide_Wide_String Transformation Subprograms -- + ------------------------------------------------- + + function Replace_Slice + (Source : Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Insert + (Source : Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String; + + procedure Insert + (Source : in out Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Overwrite + (Source : Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String; + + procedure Overwrite + (Source : in out Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Right); + + function Delete + (Source : Wide_Wide_String; + From : Positive; + Through : Natural) return Wide_Wide_String; + + procedure Delete + (Source : in out Wide_Wide_String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + ------------------------------------------- + -- Wide_Wide_String Selector Subprograms -- + ------------------------------------------- + + function Trim + (Source : Wide_Wide_String; + Side : Trim_End) return Wide_Wide_String; + + procedure Trim + (Source : in out Wide_Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Trim + (Source : Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Wide_Wide_String; + + procedure Trim + (Source : in out Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set; + Justify : Alignment := Ada.Strings.Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Head + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + return Wide_Wide_String; + + procedure Head + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Tail + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + return Wide_Wide_String; + + procedure Tail + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + -------------------------------------------- + -- Wide_Wide_String Constructor Functions -- + -------------------------------------------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Fixed; diff --git a/gcc/ada/a-stzhas.adb b/gcc/ada/a-stzhas.adb new file mode 100644 index 00000000000..b6fa3a9904e --- /dev/null +++ b/gcc/ada/a-stzhas.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) + +function Ada.Strings.Wide_Wide_Hash + (Key : Wide_Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + + function Rotate_Left + (Value : Hash_Type; + Amount : Natural) return Hash_Type; + pragma Import (Intrinsic, Rotate_Left); + + Tmp : Hash_Type; + +begin + Tmp := 0; + for J in Key'Range loop + Tmp := Rotate_Left (Tmp, 1) + Wide_Wide_Character'Pos (Key (J)); + end loop; + + return Tmp; +end Ada.Strings.Wide_Wide_Hash; + + diff --git a/gcc/ada/a-stzhas.ads b/gcc/ada/a-stzhas.ads new file mode 100644 index 00000000000..f2059288d20 --- /dev/null +++ b/gcc/ada/a-stzhas.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Wide_Wide_Hash + (Key : Wide_Wide_String) return Containers.Hash_Type; + +pragma Pure (Ada.Strings.Wide_Wide_Hash); + + + diff --git a/gcc/ada/a-stzmap.adb b/gcc/ada/a-stzmap.adb new file mode 100644 index 00000000000..065f0aca8b2 --- /dev/null +++ b/gcc/ada/a-stzmap.adb @@ -0,0 +1,744 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Maps is + + --------- + -- "-" -- + --------- + + function "-" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); + -- Each range on the right can generate at least one more range in + -- the result, by splitting one of the left operand ranges. + + N : Natural := 0; + R : Natural := 1; + L : Natural := 1; + + Left_Low : Wide_Wide_Character; + -- Left_Low is lowest character of the L'th range not yet dealt with + + begin + if LS'Last = 0 or else RS'Last = 0 then + return Left; + end if; + + Left_Low := LS (L).Low; + while R <= RS'Last loop + + -- If next right range is below current left range, skip it + + if RS (R).High < Left_Low then + R := R + 1; + + -- If next right range above current left range, copy remainder of + -- the left range to the result + + elsif RS (R).Low > LS (L).High then + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := LS (L).High; + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + + else + -- Next right range overlaps bottom of left range + + if RS (R).Low <= Left_Low then + + -- Case of right range complete overlaps left range + + if RS (R).High >= LS (L).High then + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + + -- Case of right range eats lower part of left range + + else + Left_Low := Wide_Wide_Character'Succ (RS (R).High); + R := R + 1; + end if; + + -- Next right range overlaps some of left range, but not bottom + + else + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := Wide_Wide_Character'Pred (RS (R).Low); + + -- Case of right range splits left range + + if RS (R).High < LS (L).High then + Left_Low := Wide_Wide_Character'Succ (RS (R).High); + R := R + 1; + + -- Case of right range overlaps top of left range + + else + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + end if; + end if; + end if; + end loop; + + -- Copy remainder of left ranges to result + + if L <= LS'Last then + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := LS (L).High; + + loop + L := L + 1; + exit when L > LS'Last; + N := N + 1; + Result (N) := LS (L); + end loop; + end if; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end "-"; + + --------- + -- "=" -- + --------- + + -- The sorted, discontiguous form is canonical, so equality can be used + + function "=" (Left, Right : in Wide_Wide_Character_Set) return Boolean is + begin + return Left.Set.all = Right.Set.all; + end "="; + + ----------- + -- "and" -- + ----------- + + function "and" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); + N : Natural := 0; + L, R : Natural := 1; + + begin + -- Loop to search for overlapping character ranges + + while L <= LS'Last and then R <= RS'Last loop + + if LS (L).High < RS (R).Low then + L := L + 1; + + elsif RS (R).High < LS (L).Low then + R := R + 1; + + -- Here we have LS (L).High >= RS (R).Low + -- and RS (R).High >= LS (L).Low + -- so we have an overlapping range + + else + N := N + 1; + Result (N).Low := + Wide_Wide_Character'Max (LS (L).Low, RS (R).Low); + Result (N).High := + Wide_Wide_Character'Min (LS (L).High, RS (R).High); + + if RS (R).High = LS (L).High then + L := L + 1; + R := R + 1; + elsif RS (R).High < LS (L).High then + R := R + 1; + else + L := L + 1; + end if; + end if; + end loop; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" + (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1); + N : Natural := 0; + + begin + if RS'Last = 0 then + N := 1; + Result (1) := (Low => Wide_Wide_Character'First, + High => Wide_Wide_Character'Last); + + else + if RS (1).Low /= Wide_Wide_Character'First then + N := N + 1; + Result (N).Low := Wide_Wide_Character'First; + Result (N).High := Wide_Wide_Character'Pred (RS (1).Low); + end if; + + for K in 1 .. RS'Last - 1 loop + N := N + 1; + Result (N).Low := Wide_Wide_Character'Succ (RS (K).High); + Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low); + end loop; + + if RS (RS'Last).High /= Wide_Wide_Character'Last then + N := N + 1; + Result (N).Low := Wide_Wide_Character'Succ (RS (RS'Last).High); + Result (N).High := Wide_Wide_Character'Last; + end if; + end if; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end "not"; + + ---------- + -- "or" -- + ---------- + + function "or" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); + N : Natural; + L, R : Natural; + + begin + N := 0; + L := 1; + R := 1; + + -- Loop through ranges in output file + + loop + -- If no left ranges left, copy next right range + + if L > LS'Last then + exit when R > RS'Last; + N := N + 1; + Result (N) := RS (R); + R := R + 1; + + -- If no right ranges left, copy next left range + + elsif R > RS'Last then + N := N + 1; + Result (N) := LS (L); + L := L + 1; + + else + -- We have two ranges, choose lower one + + N := N + 1; + + if LS (L).Low <= RS (R).Low then + Result (N) := LS (L); + L := L + 1; + else + Result (N) := RS (R); + R := R + 1; + end if; + + -- Loop to collapse ranges into last range + + loop + -- Collapse next length range into current result range + -- if possible. + + if L <= LS'Last + and then LS (L).Low <= + Wide_Wide_Character'Succ (Result (N).High) + then + Result (N).High := + Wide_Wide_Character'Max (Result (N).High, LS (L).High); + L := L + 1; + + -- Collapse next right range into current result range + -- if possible + + elsif R <= RS'Last + and then RS (R).Low <= + Wide_Wide_Character'Succ (Result (N).High) + then + Result (N).High := + Wide_Wide_Character'Max (Result (N).High, RS (R).High); + R := R + 1; + + -- If neither range collapses, then done with this range + + else + exit; + end if; + end loop; + end if; + end loop; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end "or"; + + ----------- + -- "xor" -- + ----------- + + function "xor" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + begin + return (Left or Right) - (Left and Right); + end "xor"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is + begin + Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all); + end Adjust; + + procedure Adjust (Object : in out Wide_Wide_Character_Set) is + begin + Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all); + end Adjust; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is + + procedure Free is new Unchecked_Deallocation + (Wide_Wide_Character_Mapping_Values, + Wide_Wide_Character_Mapping_Values_Access); + + begin + if Object.Map /= Null_Map'Unrestricted_Access then + Free (Object.Map); + end if; + end Finalize; + + procedure Finalize (Object : in out Wide_Wide_Character_Set) is + + procedure Free is new Unchecked_Deallocation + (Wide_Wide_Character_Ranges, + Wide_Wide_Character_Ranges_Access); + + begin + if Object.Set /= Null_Range'Unrestricted_Access then + Free (Object.Set); + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is + begin + Object := Identity; + end Initialize; + + procedure Initialize (Object : in out Wide_Wide_Character_Set) is + begin + Object := Null_Set; + end Initialize; + + ----------- + -- Is_In -- + ----------- + + function Is_In + (Element : Wide_Wide_Character; + Set : Wide_Wide_Character_Set) return Boolean + is + L, R, M : Natural; + SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; + + begin + L := 1; + R := SS'Last; + + -- Binary search loop. The invariant is that if Element is in any of + -- of the constituent ranges it is in one between Set (L) and Set (R). + + loop + if L > R then + return False; + + else + M := (L + R) / 2; + + if Element > SS (M).High then + L := M + 1; + elsif Element < SS (M).Low then + R := M - 1; + else + return True; + end if; + end if; + end loop; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Elements : Wide_Wide_Character_Set; + Set : Wide_Wide_Character_Set) return Boolean + is + ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set; + SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; + + S : Positive := 1; + E : Positive := 1; + + begin + loop + -- If no more element ranges, done, and result is true + + if E > ES'Last then + return True; + + -- If more element ranges, but no more set ranges, result is false + + elsif S > SS'Last then + return False; + + -- Remove irrelevant set range + + elsif SS (S).High < ES (E).Low then + S := S + 1; + + -- Get rid of element range that is properly covered by set + + elsif SS (S).Low <= ES (E).Low + and then ES (E).High <= SS (S).High + then + E := E + 1; + + -- Otherwise we have a non-covered element range, result is false + + else + return False; + end if; + end loop; + end Is_Subset; + + --------------- + -- To_Domain -- + --------------- + + function To_Domain + (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence + is + begin + return Map.Map.Domain; + end To_Domain; + + ---------------- + -- To_Mapping -- + ---------------- + + function To_Mapping + (From, To : Wide_Wide_Character_Sequence) + return Wide_Wide_Character_Mapping + is + Domain : Wide_Wide_Character_Sequence (1 .. From'Length); + Rangev : Wide_Wide_Character_Sequence (1 .. To'Length); + N : Natural := 0; + + begin + if From'Length /= To'Length then + raise Translation_Error; + + else + pragma Warnings (Off); -- apparent uninit use of Domain + + for J in From'Range loop + for M in 1 .. N loop + if From (J) = Domain (M) then + raise Translation_Error; + elsif From (J) < Domain (M) then + Domain (M + 1 .. N + 1) := Domain (M .. N); + Rangev (M + 1 .. N + 1) := Rangev (M .. N); + Domain (M) := From (J); + Rangev (M) := To (J); + goto Continue; + end if; + end loop; + + Domain (N + 1) := From (J); + Rangev (N + 1) := To (J); + + <<Continue>> + N := N + 1; + end loop; + + pragma Warnings (On); + + return (AF.Controlled with + Map => new Wide_Wide_Character_Mapping_Values'( + Length => N, + Domain => Domain (1 .. N), + Rangev => Rangev (1 .. N))); + end if; + end To_Mapping; + + -------------- + -- To_Range -- + -------------- + + function To_Range + (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence + is + begin + return Map.Map.Rangev; + end To_Range; + + --------------- + -- To_Ranges -- + --------------- + + function To_Ranges + (Set : in Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges + is + begin + return Set.Set.all; + end To_Ranges; + + ----------------- + -- To_Sequence -- + ----------------- + + function To_Sequence + (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence + is + SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; + + Result : Wide_Wide_String (Positive range 1 .. 2 ** 16); + N : Natural := 0; + + begin + for J in SS'Range loop + for K in SS (J).Low .. SS (J).High loop + N := N + 1; + Result (N) := K; + end loop; + end loop; + + return Result (1 .. N); + end To_Sequence; + + ------------ + -- To_Set -- + ------------ + + -- Case of multiple range input + + function To_Set + (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set + is + Result : Wide_Wide_Character_Ranges (Ranges'Range); + N : Natural := 0; + J : Natural; + + begin + -- The output of To_Set is required to be sorted by increasing Low + -- values, and discontiguous, so first we sort them as we enter them, + -- using a simple insertion sort. + + pragma Warnings (Off); + -- Kill bogus warning on Result being uninitialized + + for J in Ranges'Range loop + for K in 1 .. N loop + if Ranges (J).Low < Result (K).Low then + Result (K + 1 .. N + 1) := Result (K .. N); + Result (K) := Ranges (J); + goto Continue; + end if; + end loop; + + Result (N + 1) := Ranges (J); + + <<Continue>> + N := N + 1; + end loop; + + pragma Warnings (On); + + -- Now collapse any contiguous or overlapping ranges + + J := 1; + while J < N loop + if Result (J).High < Result (J).Low then + N := N - 1; + Result (J .. N) := Result (J + 1 .. N + 1); + + elsif Wide_Wide_Character'Succ (Result (J).High) >= + Result (J + 1).Low + then + Result (J).High := + Wide_Wide_Character'Max (Result (J).High, Result (J + 1).High); + + N := N - 1; + Result (J + 1 .. N) := Result (J + 2 .. N + 1); + + else + J := J + 1; + end if; + end loop; + + if Result (N).High < Result (N).Low then + N := N - 1; + end if; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end To_Set; + + -- Case of single range input + + function To_Set + (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set + is + begin + if Span.Low > Span.High then + return Null_Set; + -- This is safe, because there is no procedure with parameter + -- Wide_Wide_Character_Set of mode "out" or "in out". + + else + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(1 => Span)); + end if; + end To_Set; + + -- Case of wide string input + + function To_Set + (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set + is + R : Wide_Wide_Character_Ranges (1 .. Sequence'Length); + + begin + for J in R'Range loop + R (J) := (Sequence (J), Sequence (J)); + end loop; + + return To_Set (R); + end To_Set; + + -- Case of single wide character input + + function To_Set + (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set + is + begin + return + (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton))); + end To_Set; + + ----------- + -- Value -- + ----------- + + function Value + (Map : Wide_Wide_Character_Mapping; + Element : Wide_Wide_Character) return Wide_Wide_Character + is + L, R, M : Natural; + + MV : constant Wide_Wide_Character_Mapping_Values_Access := Map.Map; + + begin + L := 1; + R := MV.Domain'Last; + + -- Binary search loop + + loop + -- If not found, identity + + if L > R then + return Element; + + -- Otherwise do binary divide + + else + M := (L + R) / 2; + + if Element < MV.Domain (M) then + R := M - 1; + + elsif Element > MV.Domain (M) then + L := M + 1; + + else -- Element = MV.Domain (M) then + return MV.Rangev (M); + end if; + end if; + end loop; + end Value; + +end Ada.Strings.Wide_Wide_Maps; diff --git a/gcc/ada/a-stzmap.ads b/gcc/ada/a-stzmap.ads new file mode 100644 index 00000000000..8d563acffaa --- /dev/null +++ b/gcc/ada/a-stzmap.ads @@ -0,0 +1,242 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; + +package Ada.Strings.Wide_Wide_Maps is + pragma Preelaborate (Wide_Wide_Maps); + + ------------------------------------------ + -- Wide_Wide_Character Set Declarations -- + ------------------------------------------ + + type Wide_Wide_Character_Set is private; + -- Representation for a set of Wide_Wide_Character values: + + Null_Set : constant Wide_Wide_Character_Set; + + ----------------------------------------------- + -- Constructors for Wide_Wide_Character Sets -- + ----------------------------------------------- + + type Wide_Wide_Character_Range is record + Low : Wide_Wide_Character; + High : Wide_Wide_Character; + end record; + -- Represents Wide_Wide_Character range Low .. High + + type Wide_Wide_Character_Ranges is + array (Positive range <>) of Wide_Wide_Character_Range; + + function To_Set + (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set; + + function To_Set + (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set; + + function To_Ranges + (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges; + + --------------------------------------- + -- Operations on Wide Character Sets -- + --------------------------------------- + + function "=" (Left, Right : in Wide_Wide_Character_Set) return Boolean; + + function "not" + (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function "and" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function "or" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function "xor" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function "-" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function Is_In + (Element : Wide_Wide_Character; + Set : Wide_Wide_Character_Set) return Boolean; + + function Is_Subset + (Elements : Wide_Wide_Character_Set; + Set : Wide_Wide_Character_Set) return Boolean; + + function "<=" + (Left : Wide_Wide_Character_Set; + Right : Wide_Wide_Character_Set) return Boolean + renames Is_Subset; + + subtype Wide_Wide_Character_Sequence is Wide_Wide_String; + -- Alternative representation for a set of character values + + function To_Set + (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set; + + function To_Set + (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set; + + function To_Sequence + (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence; + + ---------------------------------------------- + -- Wide_Wide_Character Mapping Declarations -- + ---------------------------------------------- + + type Wide_Wide_Character_Mapping is private; + -- Representation for a wide character to wide character mapping: + + function Value + (Map : Wide_Wide_Character_Mapping; + Element : Wide_Wide_Character) return Wide_Wide_Character; + + Identity : constant Wide_Wide_Character_Mapping; + + -------------------------------------- + -- Operations on Wide Wide Mappings -- + --------------------------------------- + + function To_Mapping + (From, To : Wide_Wide_Character_Sequence) + return Wide_Wide_Character_Mapping; + + function To_Domain + (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence; + + function To_Range + (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence; + + type Wide_Wide_Character_Mapping_Function is + access function (From : Wide_Wide_Character) return Wide_Wide_Character; + +private + package AF renames Ada.Finalization; + + ----------------------------------------------- + -- Representation of Wide_Wide_Character_Set -- + ----------------------------------------------- + + -- A wide character set is represented as a sequence of wide character + -- ranges (i.e. an object of type Wide_Wide_Character_Ranges) in which the + -- following hold: + + -- The lower bound is 1 + -- The ranges are in order by increasing Low values + -- The ranges are non-overlapping and discontigous + + -- A character value is in the set if it is contained in one of the + -- ranges. The actual Wide_Wide_Character_Set value is a controlled pointer + -- to this Wide_Wide_Character_Ranges value. The use of a controlled type + -- is necessary to prevent storage leaks. + + type Wide_Wide_Character_Ranges_Access is + access all Wide_Wide_Character_Ranges; + + type Wide_Wide_Character_Set is new AF.Controlled with record + Set : Wide_Wide_Character_Ranges_Access; + end record; + + pragma Finalize_Storage_Only (Wide_Wide_Character_Set); + -- This avoids useless finalizations, and, more importantly avoids + -- incorrect attempts to finalize constants that are statically + -- declared here and in Ada.Strings.Wide_Wide_Maps, which is incorrect. + + procedure Initialize (Object : in out Wide_Wide_Character_Set); + procedure Adjust (Object : in out Wide_Wide_Character_Set); + procedure Finalize (Object : in out Wide_Wide_Character_Set); + + Null_Range : aliased constant Wide_Wide_Character_Ranges := + (1 .. 0 => (Low => ' ', High => ' ')); + + Null_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Set => Null_Range'Unrestricted_Access); + + --------------------------------------------------- + -- Representation of Wide_Wide_Character_Mapping -- + --------------------------------------------------- + + -- A wide character mapping is represented as two strings of equal + -- length, where any character appearing in Domain is mapped to the + -- corresponding character in Rangev. A character not appearing in + -- Domain is mapped to itself. The characters in Domain are sorted + -- in ascending order. + + -- The actual Wide_Wide_Character_Mapping value is a controlled record + -- that contains a pointer to a discriminated record containing the + -- range and domain values. + + -- Note: this representation is canonical, and the values stored in + -- Domain and Rangev are exactly the values that are returned by the + -- functions To_Domain and To_Range. The use of a controlled type is + -- necessary to prevent storage leaks. + + type Wide_Wide_Character_Mapping_Values (Length : Natural) is record + Domain : Wide_Wide_Character_Sequence (1 .. Length); + Rangev : Wide_Wide_Character_Sequence (1 .. Length); + end record; + + type Wide_Wide_Character_Mapping_Values_Access is + access all Wide_Wide_Character_Mapping_Values; + + type Wide_Wide_Character_Mapping is new AF.Controlled with record + Map : Wide_Wide_Character_Mapping_Values_Access; + end record; + + pragma Finalize_Storage_Only (Wide_Wide_Character_Mapping); + -- This avoids useless finalizations, and, more importantly avoids + -- incorrect attempts to finalize constants that are statically + -- declared here and in Ada.Strings.Wide_Wide_Maps, which is incorrect. + + procedure Initialize (Object : in out Wide_Wide_Character_Mapping); + procedure Adjust (Object : in out Wide_Wide_Character_Mapping); + procedure Finalize (Object : in out Wide_Wide_Character_Mapping); + + Null_Map : aliased constant Wide_Wide_Character_Mapping_Values := + (Length => 0, + Domain => "", + Rangev => ""); + + Identity : constant Wide_Wide_Character_Mapping := + (AF.Controlled with + Map => Null_Map'Unrestricted_Access); + +end Ada.Strings.Wide_Wide_Maps; diff --git a/gcc/ada/a-stzsea.adb b/gcc/ada/a-stzsea.adb new file mode 100644 index 00000000000..bb65fd97742 --- /dev/null +++ b/gcc/ada/a-stzsea.adb @@ -0,0 +1,420 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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_Maps; use Ada.Strings.Wide_Wide_Maps; + +package body Ada.Strings.Wide_Wide_Search is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Belongs + (Element : Wide_Wide_Character; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership) return Boolean; + pragma Inline (Belongs); + -- Determines if the given element is in (Test = Inside) or not in + -- (Test = Outside) the given character set. + + ------------- + -- Belongs -- + ------------- + + function Belongs + (Element : Wide_Wide_Character; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership) return Boolean + is + begin + if Test = Inside then + return Is_In (Element, Set); + else + return not Is_In (Element, Set); + end if; + end Belongs; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + N : Natural; + J : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Handle the case of non-identity mappings by creating a mapped + -- string and making a recursive call using the identity mapping + -- on this mapped string. + + if Mapping /= Wide_Wide_Maps.Identity then + declare + Mapped_Source : Wide_Wide_String (Source'Range); + + begin + for J in Source'Range loop + Mapped_Source (J) := Value (Mapping, Source (J)); + end loop; + + return Count (Mapped_Source, Pattern); + end; + end if; + + N := 0; + J := Source'First; + + while J <= Source'Last - (Pattern'Length - 1) loop + if Source (J .. J + (Pattern'Length - 1)) = Pattern then + N := N + 1; + J := J + Pattern'Length; + else + J := J + 1; + end if; + end loop; + + return N; + end Count; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + Mapped_Source : Wide_Wide_String (Source'Range); + + begin + for J in Source'Range loop + Mapped_Source (J) := Mapping (Source (J)); + end loop; + + return Count (Mapped_Source, Pattern); + end Count; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + N : Natural := 0; + + begin + for J in Source'Range loop + if Is_In (Source (J), Set) then + N := N + 1; + end if; + end loop; + + return N; + end Count; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + is + begin + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + First := J; + + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + end loop; + + -- Here if J indexes 1st char of token, and all chars + -- after J are in the token + + Last := Source'Last; + return; + end if; + end loop; + + -- Here if no token found + + First := Source'First; + Last := 0; + end Find_Token; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Handle the case of non-identity mappings by creating a mapped + -- string and making a recursive call using the identity mapping + -- on this mapped string. + + if Mapping /= Identity then + declare + Mapped_Source : Wide_Wide_String (Source'Range); + + begin + for J in Source'Range loop + Mapped_Source (J) := Value (Mapping, Source (J)); + end loop; + + return Index (Mapped_Source, Pattern, Going); + end; + end if; + + if Going = Forward then + for J in Source'First .. Source'Last - Pattern'Length + 1 loop + if Pattern = Source (J .. J + Pattern'Length - 1) then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'First .. Source'Last - Pattern'Length + 1 loop + if Pattern = Source (J .. J + Pattern'Length - 1) then + return J; + end if; + end loop; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + Mapped_Source : Wide_Wide_String (Source'Range); + + begin + for J in Source'Range loop + Mapped_Source (J) := Mapping (Source (J)); + end loop; + + return Index (Mapped_Source, Pattern, Going); + end Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index; + + function Index + (Source : 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 + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return Index + (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return Index + (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Set, Test, Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Set, Test, Backward); + end if; + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + for J in Source'Range loop + if Source (J) /= Wide_Wide_Space then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'Range loop + if Source (J) /= Wide_Wide_Space then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (From .. Source'Last), Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (Source'First .. From), Backward); + end if; + end Index_Non_Blank; + +end Ada.Strings.Wide_Wide_Search; diff --git a/gcc/ada/a-stzsea.ads b/gcc/ada/a-stzsea.ads new file mode 100644 index 00000000000..52e42047ea1 --- /dev/null +++ b/gcc/ada/a-stzsea.ads @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains search functions from Ada.Strings.Wide_Wide_Fixed. +-- They are separated because Ada.Strings.Wide_Wide_Bounded shares these +-- search functions with Ada.Strings.Wide_Wide_Unbounded, and we don't want +-- to drag other irrelevant stuff from Ada.Strings.Wide_Wide_Fixed when using +-- the other two packages. We make this a private package, since user +-- programs should access these subprograms via one of the standard string +-- packages. + +with Ada.Strings.Wide_Wide_Maps; + +private package Ada.Strings.Wide_Wide_Search is +pragma Preelaborate (Wide_Wide_Search); + + function Index + (Source : 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 : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : 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; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + +end Ada.Strings.Wide_Wide_Search; diff --git a/gcc/ada/a-stzsup.adb b/gcc/ada/a-stzsup.adb new file mode 100644 index 00000000000..eac117249d1 --- /dev/null +++ b/gcc/ada/a-stzsup.adb @@ -0,0 +1,1920 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S U P E R B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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_Maps; use Ada.Strings.Wide_Wide_Maps; +with Ada.Strings.Wide_Wide_Search; + +package body Ada.Strings.Wide_Wide_Superbounded is + + ------------ + -- Concat -- + ------------ + + function Concat + (Left : Super_String; + Right : Super_String) return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Wide_String) return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + + Nlen : constant Natural := Llen + Right'Length; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end if; + return Result; + end Concat; + + function Concat + (Left : Wide_Wide_String; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Wide_Character) return Super_String + is + Result : Super_String (Left.Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end if; + + return Result; + end Concat; + + function Concat + (Left : Wide_Wide_Character; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := Right.Data (1 .. Rlen); + end if; + + return Result; + end Concat; + + ----------- + -- Equal -- + ----------- + + function "=" + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Current_Length = Right.Current_Length + and then Left.Data (1 .. Left.Current_Length) = + Right.Data (1 .. Right.Current_Length); + end "="; + + function Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Current_Length = Right'Length + and then Left.Data (1 .. Left.Current_Length) = Right; + end Equal; + + function Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left'Length = Right.Current_Length + and then Left = Right.Data (1 .. Right.Current_Length); + end Equal; + + ------------- + -- Greater -- + ------------- + + function Greater + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > + Right.Data (1 .. Right.Current_Length); + end Greater; + + function Greater + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > Right; + end Greater; + + function Greater + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left > Right.Data (1 .. Right.Current_Length); + end Greater; + + ---------------------- + -- Greater_Or_Equal -- + ---------------------- + + function Greater_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= + Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= Right; + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left >= Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + ---------- + -- Less -- + ---------- + + function Less + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < + Right.Data (1 .. Right.Current_Length); + end Less; + + function Less + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < Right; + end Less; + + function Less + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left < Right.Data (1 .. Right.Current_Length); + end Less; + + ------------------- + -- Less_Or_Equal -- + ------------------- + + function Less_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= + Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= Right; + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left <= Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + ---------------------- + -- Set_Super_String -- + ---------------------- + + procedure Set_Super_String + (Target : out Super_String; + Source : Wide_Wide_String; + Drop : Truncation := Error) + is + Slen : constant Natural := Source'Length; + Max_Length : constant Positive := Target.Max_Length; + + begin + if Slen <= Max_Length then + Target.Current_Length := Slen; + Target.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Target.Current_Length := Max_Length; + Target.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Target.Current_Length := Max_Length; + Target.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Set_Super_String; + + ------------------ + -- Super_Append -- + ------------------ + + -- Case of Super_String and Super_String + + function Super_Append + (Left : Super_String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Result.Data := Right.Data; + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Source.Data := New_Item.Data; + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Super_String and Wide_Wide_String + + function Super_Append + (Left : Super_String; + Right : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right (Right'First .. Right'First - 1 + + Max_Length - Llen); + + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right (Right'Last - (Max_Length - 1) .. Right'Last); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item (New_Item'First .. + New_Item'First - 1 + Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - (Max_Length - 1) .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Wide_Wide_String and Super_String + + function Super_Append + (Left : Wide_Wide_String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then + Result.Data (1 .. Max_Length) := + Left (Left'First .. Left'First + (Max_Length - 1)); + + else + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right.Data (Rlen - (Max_Length - 1) .. Rlen); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + -- Case of Super_String and Wide_Wide_Character + + function Super_Append + (Left : Super_String; + Right : Wide_Wide_Character; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen < Max_Length then + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1) := Right; + return Result; + + else + case Drop is + when Strings.Right => + return Left; + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length - 1) := + Left.Data (2 .. Max_Length); + Result.Data (Max_Length) := Right; + return Result; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Wide_Character; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + + begin + if Llen < Max_Length then + Source.Current_Length := Llen + 1; + Source.Data (Llen + 1) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + null; + + when Strings.Left => + Source.Data (1 .. Max_Length - 1) := + Source.Data (2 .. Max_Length); + Source.Data (Max_Length) := New_Item; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Wide_Wide_Character and Super_String + + function Super_Append + (Left : Wide_Wide_Character; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen < Max_Length then + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); + return Result; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1) := Left; + Result.Data (2 .. Max_Length) := + Right.Data (1 .. Max_Length - 1); + return Result; + + when Strings.Left => + return Right; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + ----------------- + -- Super_Count -- + ----------------- + + function Super_Count + (Source : Super_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + is + begin + return + Wide_Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return + Wide_Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + begin + return Wide_Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Set); + end Super_Count; + + ------------------ + -- Super_Delete -- + ------------------ + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) return Super_String + is + Result : Super_String (Source.Max_Length); + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return Source; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Result.Current_Length := From - 1; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + return Result; + + else + Result.Current_Length := Slen - Num_Delete; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + Result.Data (From .. Result.Current_Length) := + Source.Data (Through + 1 .. Slen); + return Result; + end if; + end Super_Delete; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural) + is + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Source.Current_Length := From - 1; + + else + Source.Current_Length := Slen - Num_Delete; + Source.Data (From .. Source.Current_Length) := + Source.Data (Through + 1 .. Slen); + end if; + end Super_Delete; + + ------------------- + -- Super_Element -- + ------------------- + + function Super_Element + (Source : Super_String; + Index : Positive) return Wide_Wide_Character + is + begin + if Index in 1 .. Source.Current_Length then + return Source.Data (Index); + else + raise Strings.Index_Error; + end if; + end Super_Element; + + ---------------------- + -- Super_Find_Token -- + ---------------------- + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Wide_Search.Find_Token + (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + ---------------- + -- Super_Head -- + ---------------- + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := Source.Data (1 .. Count); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Count) := (others => Pad); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Max_Length - Npad) := + Source.Data (Count - Max_Length + 1 .. Slen); + Result.Data (Max_Length - Npad + 1 .. Max_Length) := + (others => Pad); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Head; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + Temp : Wide_Wide_String (1 .. Max_Length); + + begin + if Npad <= 0 then + Source.Current_Length := Count; + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (Slen + 1 .. Count) := (others => Pad); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad > Max_Length then + Source.Data := (others => Pad); + + else + Temp := Source.Data; + Source.Data (1 .. Max_Length - Npad) := + Temp (Count - Max_Length + 1 .. Slen); + + for J in Max_Length - Npad + 1 .. Max_Length loop + Source.Data (J) := Pad; + end loop; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Head; + + ----------------- + -- Super_Index -- + ----------------- + + function Super_Index + (Source : Super_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 + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Set, Test, Going); + end Super_Index; + + function Super_Index + (Source : Super_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 + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), + Pattern, From, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), + Pattern, From, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going); + end Super_Index; + + --------------------------- + -- Super_Index_Non_Blank -- + --------------------------- + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return + Wide_Wide_Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), Going); + end Super_Index_Non_Blank; + + function Super_Index_Non_Blank + (Source : Super_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + return + Wide_Wide_Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), From, Going); + end Super_Index_Non_Blank; + + ------------------ + -- Super_Insert -- + ------------------ + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Nlen : constant Natural := New_Item'Length; + Tlen : constant Natural := Slen + Nlen; + Blen : constant Natural := Before - 1; + Alen : constant Integer := Slen - Blen; + Droplen : constant Integer := Tlen - Max_Length; + + -- Tlen is the length of the total string before possible truncation. + -- Blen, Alen are the lengths of the before and after pieces of the + -- source string. + + begin + if Alen < 0 then + raise Ada.Strings.Index_Error; + + elsif Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Tlen) := + Source.Data (Before .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Before .. Max_Length) := + New_Item (New_Item'First + .. New_Item'First + Max_Length - Before); + else + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Max_Length) := + Source.Data (Before .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (Before .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + New_Item (New_Item'Last - (Max_Length - Alen) + 1 + .. New_Item'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := + New_Item; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Insert; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Insert (Source, Before, New_Item, Drop); + end Super_Insert; + + ------------------ + -- Super_Length -- + ------------------ + + function Super_Length (Source : Super_String) return Natural is + begin + return Source.Current_Length; + end Super_Length; + + --------------------- + -- Super_Overwrite -- + --------------------- + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Endpos : constant Natural := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif New_Item'Length = 0 then + return Source; + + elsif Endpos <= Slen then + Result.Current_Length := Source.Current_Length; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + elsif Endpos <= Max_Length then + Result.Current_Length := Endpos; + Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + else + Result.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Position - 1) := + Source.Data (1 .. Position - 1); + + Result.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + return Result; + + when Strings.Left => + if New_Item'Length >= Max_Length then + Result.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + return Result; + + else + Result.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + Result.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + return Result; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + Max_Length : constant Positive := Source.Max_Length; + Endpos : constant Positive := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Endpos <= Slen then + Source.Data (Position .. Endpos) := New_Item; + + elsif Endpos <= Max_Length then + Source.Data (Position .. Endpos) := New_Item; + Source.Current_Length := Endpos; + + else + Source.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + + when Strings.Left => + if New_Item'Length > Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + + Source.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + --------------------------- + -- Super_Replace_Element -- + --------------------------- + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Wide_Wide_Character) + is + begin + if Index <= Source.Current_Length then + Source.Data (Index) := By; + else + raise Ada.Strings.Index_Error; + end if; + end Super_Replace_Element; + + ------------------------- + -- Super_Replace_Slice -- + ------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + + begin + if Low > Slen + 1 then + raise Strings.Index_Error; + + elsif High < Low then + return Super_Insert (Source, Low, By, Drop); + + else + declare + Blen : constant Natural := Natural'Max (0, Low - 1); + Alen : constant Natural := Natural'Max (0, Slen - High); + Tlen : constant Natural := Blen + By'Length + Alen; + Droplen : constant Integer := Tlen - Max_Length; + Result : Super_String (Max_Length); + + -- Tlen is the total length of the result string before any + -- truncation. Blen and Alen are the lengths of the pieces + -- of the original string that end up in the result string + -- before and after the replaced slice. + + begin + if Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Tlen) := + Source.Data (High + 1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Low .. Max_Length) := + By (By'First .. By'First + Max_Length - Low); + else + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Max_Length) := + Source.Data (High + 1 .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (High + 1 .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + By (By'Last - (Max_Length - Alen) + 1 .. By'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := By; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end; + end if; + end Super_Replace_Slice; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Replace_Slice (Source, Low, High, By, Drop); + end Super_Replace_Slice; + + --------------------- + -- Super_Replicate -- + --------------------- + + function Super_Replicate + (Count : Natural; + Item : Wide_Wide_Character; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + + begin + if Count <= Max_Length then + Result.Current_Length := Count; + + elsif Drop = Strings.Error then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Max_Length; + end if; + + Result.Data (1 .. Result.Current_Length) := (others => Item); + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Wide_Wide_String; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String + is + Length : constant Integer := Count * Item'Length; + Result : Super_String (Max_Length); + Indx : Positive; + + begin + if Length <= Max_Length then + Result.Current_Length := Length; + + if Length > 0 then + Indx := 1; + + for J in 1 .. Count loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + end if; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Indx := 1; + + while Indx + Item'Length <= Max_Length + 1 loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + + Result.Data (Indx .. Max_Length) := + Item (Item'First .. Item'First + Max_Length - Indx); + + when Strings.Left => + Indx := Max_Length; + + while Indx - Item'Length >= 1 loop + Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; + Indx := Indx - Item'Length; + end loop; + + Result.Data (1 .. Indx) := + Item (Item'Last - Indx + 1 .. Item'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + begin + return + Super_Replicate + (Count, + Item.Data (1 .. Item.Current_Length), + Drop, + Item.Max_Length); + end Super_Replicate; + + ----------------- + -- Super_Slice -- + ----------------- + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + return Source.Data (Low .. High); + end if; + end Super_Slice; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + Result.Current_Length := High - Low + 1; + Result.Data (1 .. Source.Current_Length) := Source.Data (Low .. High); + end if; + + return Result; + end Super_Slice; + + procedure Super_Slice + (Source : Super_String; + Target : out Super_String; + Low : Positive; + High : Natural) + is + begin + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + Target.Current_Length := High - Low + 1; + Target.Data (1 .. Source.Current_Length) := Source.Data (Low .. High); + end if; + end Super_Slice; + + ---------------- + -- Super_Tail -- + ---------------- + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := + Source.Data (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Max_Length) := + Source.Data (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + Result.Data (1 .. Max_Length - Slen) := (others => Pad); + Result.Data (Max_Length - Slen + 1 .. Max_Length) := + Source.Data (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Tail; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + Temp : constant Wide_Wide_String (1 .. Max_Length) := Source.Data; + + begin + if Npad <= 0 then + Source.Current_Length := Count; + Source.Data (1 .. Count) := + Temp (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Source.Data := (others => Pad); + + else + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Max_Length) := + Temp (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + for J in 1 .. Max_Length - Slen loop + Source.Data (J) := Pad; + end loop; + + Source.Data (Max_Length - Slen + 1 .. Max_Length) := + Temp (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Tail; + + --------------------- + -- Super_To_String -- + --------------------- + + function Super_To_String + (Source : Super_String) return Wide_Wide_String + is + begin + return Source.Data (1 .. Source.Current_Length); + end Super_To_String; + + --------------------- + -- Super_Translate -- + --------------------- + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + end Super_Translate; + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Mapping.all (Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Mapping.all (Source.Data (J)); + end loop; + end Super_Translate; + + ---------------- + -- Super_Trim -- + ---------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) return Super_String + is + Result : Super_String (Source.Max_Length); + Last : Natural := Source.Current_Length; + First : Positive := 1; + + begin + if Side = Left or else Side = Both then + while First <= Last and then Source.Data (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Source.Data (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End) + is + Max_Length : constant Positive := Source.Max_Length; + Last : Natural := Source.Current_Length; + First : Positive := 1; + Temp : Wide_Wide_String (1 .. Max_Length); + + begin + Temp (1 .. Last) := Source.Data (1 .. Last); + + if Side = Left or else Side = Both then + while First <= Last and then Temp (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Temp (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Source.Data := (others => Wide_Wide_NUL); + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); + end Super_Trim; + + function Super_Trim + (Source : Super_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := + Source.Data (First .. Last); + return Result; + end if; + end loop; + end if; + end loop; + + Result.Current_Length := 0; + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + is + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + if First = 1 then + Source.Current_Length := Last; + return; + else + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := + Source.Data (First .. Last); + + for J in Source.Current_Length + 1 .. + Source.Max_Length + loop + Source.Data (J) := Wide_Wide_NUL; + end loop; + + return; + end if; + end if; + end loop; + + Source.Current_Length := 0; + return; + end if; + end loop; + + Source.Current_Length := 0; + end Super_Trim; + + ----------- + -- Times -- + ----------- + + function Times + (Left : Natural; + Right : Wide_Wide_Character; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + + begin + if Left > Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Left; + + for J in 1 .. Left loop + Result.Data (J) := Right; + end loop; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Wide_Wide_String; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Max_Length then + raise Ada.Strings.Index_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := Right; + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := + Right.Data (1 .. Rlen); + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + --------------------- + -- To_Super_String -- + --------------------- + + function To_Super_String + (Source : Wide_Wide_String; + Max_Length : Natural; + Drop : Truncation := Error) return Super_String + is + Result : Super_String (Max_Length); + Slen : constant Natural := Source'Length; + + begin + if Slen <= Max_Length then + Result.Current_Length := Slen; + Result.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end To_Super_String; + +end Ada.Strings.Wide_Wide_Superbounded; diff --git a/gcc/ada/a-stzsup.ads b/gcc/ada/a-stzsup.ads new file mode 100644 index 00000000000..55a1db6f1db --- /dev/null +++ b/gcc/ada/a-stzsup.ads @@ -0,0 +1,498 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S U P E R B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This non generic package contains most of the implementation of the +-- generic package Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length. + +-- It defines type Super_String as a discriminated record with the maximum +-- length as the discriminant. Individual instantiations of the package +-- Strings.Wide_Wide_Bounded.Generic_Bounded_Length use this type with +-- an appropriate discriminant value set. + +with Ada.Strings.Wide_Wide_Maps; + +package Ada.Strings.Wide_Wide_Superbounded is +pragma Preelaborate (Wide_Wide_Superbounded); + + Wide_Wide_NUL : constant Wide_Wide_Character := + Wide_Wide_Character'Val (0); + + type Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : Wide_Wide_String (1 .. Max_Length) := + (others => Wide_Wide_NUL); + end record; + -- Wide_Wide_Bounded.Generic_Bounded_Length.Wide_Wide_Bounded_String is + -- derived from this type, with the constraint of the maximum length. + + -- The subprograms defined for Super_String are similar to those defined + -- for Bounded_Wide_Wide_String, except that they have different names, so + -- that they can be renamed in Wide_Wide_Bounded.Generic_Bounded_Length. + + function Super_Length (Source : Super_String) return Natural; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Super_String + (Source : Wide_Wide_String; + Max_Length : Natural; + Drop : Truncation := Error) return Super_String; + -- Note the additional parameter Max_Length, which specifies the maximum + -- length setting of the resulting Super_String value. + + -- The following procedures have declarations (and semantics) that are + -- exactly analogous to those declared in Ada.Strings.Wide_Wide_Bounded. + + function Super_To_String (Source : Super_String) return Wide_Wide_String; + + procedure Set_Super_String + (Target : out Super_String; + Source : Wide_Wide_String; + Drop : Truncation := Error); + + function Super_Append + (Left : Super_String; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Super_String; + Right : Wide_Wide_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Wide_Wide_String; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Super_String; + Right : Wide_Wide_Character; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Wide_Wide_Character; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Wide_Character; + Drop : Truncation := Error); + + function Concat + (Left : Super_String; + Right : Super_String) return Super_String; + + function Concat + (Left : Super_String; + Right : Wide_Wide_String) return Super_String; + + function Concat + (Left : Wide_Wide_String; + Right : Super_String) return Super_String; + + function Concat + (Left : Super_String; + Right : Wide_Wide_Character) return Super_String; + + function Concat + (Left : Wide_Wide_Character; + Right : Super_String) return Super_String; + + function Super_Element + (Source : Super_String; + Index : Positive) return Wide_Wide_Character; + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Wide_Wide_Character); + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String; + + procedure Super_Slice + (Source : Super_String; + Target : out Super_String; + Low : Positive; + High : Natural); + + function "=" + (Left : Super_String; + Right : Super_String) return Boolean; + + function Equal + (Left : Super_String; + Right : Super_String) return Boolean renames "="; + + function Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Less + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Less_Or_Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Greater + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Greater_Or_Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Super_Index + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Super_Index + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Direction := Forward) return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Super_Count + (Source : Super_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Super_Count + (Source : Super_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Super_Count + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error); + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) return Super_String; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End); + + function Super_Trim + (Source : Super_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Super_String; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error); + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Super_String; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + -- Note: in some of the following routines, there is an extra parameter + -- Max_Length which specifies the value of the maximum length for the + -- resulting Super_String value. + + function Times + (Left : Natural; + Right : Wide_Wide_Character; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Wide_Wide_String; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Super_String) return Super_String; + + function Super_Replicate + (Count : Natural; + Item : Wide_Wide_Character; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Wide_Wide_String; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Truncation := Error) return Super_String; + +private + -- Pragma Inline declarations + + pragma Inline ("="); + pragma Inline (Less); + pragma Inline (Less_Or_Equal); + pragma Inline (Greater); + pragma Inline (Greater_Or_Equal); + pragma Inline (Concat); + pragma Inline (Super_Count); + pragma Inline (Super_Element); + pragma Inline (Super_Find_Token); + pragma Inline (Super_Index); + pragma Inline (Super_Index_Non_Blank); + pragma Inline (Super_Length); + pragma Inline (Super_Replace_Element); + pragma Inline (Super_Slice); + pragma Inline (Super_To_String); + +end Ada.Strings.Wide_Wide_Superbounded; diff --git a/gcc/ada/a-stzunb.adb b/gcc/ada/a-stzunb.adb new file mode 100644 index 00000000000..c6c5c4a9bd8 --- /dev/null +++ b/gcc/ada/a-stzunb.adb @@ -0,0 +1,986 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME 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-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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_Fixed; +with Ada.Strings.Wide_Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Unbounded is + + use Ada.Finalization; + + procedure Realloc_For_Chunk + (Source : in out Unbounded_Wide_Wide_String; + Chunk_Size : Natural); + pragma Inline (Realloc_For_Chunk); + -- Adjust the size allocated for the string. Add at least Chunk_Size so it + -- is safe to add a string of this size at the end of the current content. + -- The real size allocated for the string is Chunk_Size + x of the current + -- string size. This buffered handling makes the Append unbounded wide + -- string routines very fast. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + L_Length : constant Natural := Left.Last; + R_Length : constant Natural := Right.Last; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := L_Length + R_Length; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + Result.Reference (1 .. L_Length) := + Left.Reference (1 .. Left.Last); + Result.Reference (L_Length + 1 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + L_Length : constant Natural := Left.Last; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := L_Length + Right'Length; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); + Result.Reference (L_Length + 1 .. Result.Last) := Right; + + return Result; + end "&"; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + R_Length : constant Natural := Right.Last; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left'Length + R_Length; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + Result.Reference (1 .. Left'Length) := Left; + Result.Reference (Left'Length + 1 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left.Last + 1; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + Result.Reference (1 .. Result.Last - 1) := + Left.Reference (1 .. Left.Last); + Result.Reference (Result.Last) := Right; + + return Result; + end "&"; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Right.Last + 1; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + Result.Reference (1) := Left; + Result.Reference (2 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left; + + Result.Reference := new Wide_Wide_String (1 .. Left); + for J in Result.Reference'Range loop + Result.Reference (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + Len : constant Natural := Right'Length; + K : Positive; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left * Len; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + K := 1; + for J in 1 .. Left loop + Result.Reference (K .. K + Len - 1) := Right; + K := K + Len; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + Len : constant Natural := Right.Last; + K : Positive; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left * Len; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + K := 1; + for I in 1 .. Left loop + Result.Reference (K .. K + Len - 1) := + Right.Reference (1 .. Right.Last); + K := K + Len; + end loop; + + return Result; + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) < Right; + end "<"; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left < Right.Reference (1 .. Right.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left <= Right.Reference (1 .. Right.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); + end "="; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) = Right; + end "="; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left = Right.Reference (1 .. Right.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) > Right; + end ">"; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left > Right.Reference (1 .. Right.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left >= Right.Reference (1 .. Right.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is + begin + -- Copy string, except we do not copy the statically allocated null + -- string, since it can never be deallocated. Note that we do not copy + -- extra string room here to avoid dragging unused allocated memory. + + if Object.Reference /= Null_Wide_Wide_String'Access then + Object.Reference := + new Wide_Wide_String'(Object.Reference (1 .. Object.Last)); + end if; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String) + is + begin + Realloc_For_Chunk (Source, New_Item.Last); + Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := + New_Item.Reference (1 .. New_Item.Last); + Source.Last := Source.Last + New_Item.Last; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String) + is + begin + Realloc_For_Chunk (Source, New_Item'Length); + Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := + New_Item; + Source.Last := Source.Last + New_Item'Length; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character) + is + begin + Realloc_For_Chunk (Source, 1); + Source.Reference (Source.Last + 1) := New_Item; + Source.Last := Source.Last + 1; + end Append; + + ----------- + -- 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 + begin + return Wide_Wide_Search.Count + (Source.Reference (1 .. Source.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 + begin + return Wide_Wide_Search.Count + (Source.Reference (1 .. Source.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + begin + return Wide_Wide_Search.Count + (Source.Reference (1 .. Source.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String + is + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Delete + (Source.Reference (1 .. Source.Last), From, Through)); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) + is + begin + if From > Through then + null; + + elsif From < Source.Reference'First or else Through > Source.Last then + raise Index_Error; + + else + declare + Len : constant Natural := Through - From + 1; + + begin + Source.Reference (From .. Source.Last - Len) := + Source.Reference (Through + 1 .. Source.Last); + Source.Last := Source.Last - Len; + end; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + is + begin + if Index <= Source.Last then + return Source.Reference (Index); + else + raise Strings.Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is + procedure Deallocate is + new Ada.Unchecked_Deallocation + (Wide_Wide_String, Wide_Wide_String_Access); + + begin + -- Note: Don't try to free statically allocated null string + + if Object.Reference /= Null_Wide_Wide_String'Access then + Deallocate (Object.Reference); + Object.Reference := Null_Unbounded_Wide_Wide_String.Reference; + end if; + end Finalize; + + ---------------- + -- 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 + begin + Wide_Wide_Search.Find_Token + (Source.Reference (1 .. Source.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 + -- Note: Do not try to free statically allocated null string + + if X /= Null_Unbounded_Wide_Wide_String.Reference then + Deallocate (X); + end if; + 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 + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Head + (Source.Reference (1 .. Source.Last), Count, Pad)); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + Old : Wide_Wide_String_Access := Source.Reference; + + begin + Source.Reference := new Wide_Wide_String' + (Wide_Wide_Fixed.Head + (Source.Reference (1 .. Source.Last), Count, Pad)); + Source.Last := Source.Reference'Length; + Free (Old); + 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 + begin + return Wide_Wide_Search.Index + (Source.Reference (1 .. Source.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 + begin + return Wide_Wide_Search.Index + (Source.Reference (1 .. Source.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 + begin + return Wide_Wide_Search.Index + (Source.Reference (1 .. Source.Last), Set, Test, Going); + end Index; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return Wide_Wide_Search.Index_Non_Blank + (Source.Reference (1 .. Source.Last), Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is + begin + Object.Reference := Null_Unbounded_Wide_Wide_String.Reference; + Object.Last := 0; + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Insert + (Source.Reference (1 .. Source.Last), Before, New_Item)); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) + is + begin + if Before not in Source.Reference'First .. Source.Last + 1 then + raise Index_Error; + end if; + + Realloc_For_Chunk (Source, New_Item'Size); + + Source.Reference + (Before + New_Item'Length .. Source.Last + New_Item'Length) := + Source.Reference (Before .. Source.Last); + + Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; + Source.Last := Source.Last + New_Item'Length; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_Wide_String) return Natural is + begin + return Source.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Overwrite + (Source.Reference (1 .. Source.Last), Position, New_Item)); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) + is + NL : constant Natural := New_Item'Length; + + begin + if Position <= Source.Last - NL + 1 then + Source.Reference (Position .. Position + NL - 1) := New_Item; + + else + declare + Old : Wide_Wide_String_Access := Source.Reference; + + begin + Source.Reference := new Wide_Wide_String' + (Wide_Wide_Fixed.Overwrite + (Source.Reference (1 .. Source.Last), Position, New_Item)); + Source.Last := Source.Reference'Length; + Free (Old); + end; + end if; + end Overwrite; + + ----------------------- + -- Realloc_For_Chunk -- + ----------------------- + + procedure Realloc_For_Chunk + (Source : in out Unbounded_Wide_Wide_String; + Chunk_Size : Natural) + is + Growth_Factor : constant := 50; + S_Length : constant Natural := Source.Reference'Length; + + begin + if Chunk_Size > S_Length - Source.Last then + declare + Alloc_Chunk_Size : constant Positive := + Chunk_Size + (S_Length / Growth_Factor); + Tmp : Wide_Wide_String_Access; + + begin + Tmp := new Wide_Wide_String (1 .. S_Length + Alloc_Chunk_Size); + Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); + Free (Source.Reference); + Source.Reference := Tmp; + end; + end if; + end Realloc_For_Chunk; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + is + begin + if Index <= Source.Last then + Source.Reference (Index) := By; + else + raise Strings.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 + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Replace_Slice + (Source.Reference (1 .. Source.Last), Low, High, By)); + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) + is + Old : Wide_Wide_String_Access := Source.Reference; + + begin + Source.Reference := new Wide_Wide_String' + (Wide_Wide_Fixed.Replace_Slice + (Source.Reference (1 .. Source.Last), Low, High, By)); + Source.Last := Source.Reference'Length; + Free (Old); + end Replace_Slice; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + + else + return Source.Reference (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 + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Tail + (Source.Reference (1 .. Source.Last), Count, Pad)); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + Old : Wide_Wide_String_Access := Source.Reference; + + begin + Source.Reference := new Wide_Wide_String' + (Wide_Wide_Fixed.Tail + (Source.Reference (1 .. Source.Last), Count, Pad)); + Source.Last := Source.Reference'Length; + Free (Old); + end Tail; + + ------------------------------ + -- To_Unbounded_Wide_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + begin + Result.Last := Source'Length; + Result.Reference := new Wide_Wide_String (1 .. Source'Length); + Result.Reference.all := Source; + return Result; + end To_Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + begin + Result.Last := Length; + Result.Reference := new Wide_Wide_String (1 .. Length); + return Result; + end To_Unbounded_Wide_Wide_String; + + -------------------- + -- To_Wide_Wide_String -- + -------------------- + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String + is + begin + return Source.Reference (1 .. Source.Last); + end To_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 + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Translate + (Source.Reference (1 .. Source.Last), Mapping)); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + begin + Wide_Wide_Fixed.Translate + (Source.Reference (1 .. Source.Last), Mapping); + end Translate; + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String + is + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Translate + (Source.Reference (1 .. Source.Last), Mapping)); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + begin + Wide_Wide_Fixed.Translate + (Source.Reference (1 .. Source.Last), Mapping); + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String + is + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End) + is + Old : Wide_Wide_String_Access := Source.Reference; + begin + Source.Reference := + new Wide_Wide_String' + (Wide_Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); + Source.Last := Source.Reference'Length; + Free (Old); + 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 + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Trim + (Source.Reference (1 .. Source.Last), Left, Right)); + 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 + Old : Wide_Wide_String_Access := Source.Reference; + begin + Source.Reference := new Wide_Wide_String' + (Wide_Wide_Fixed.Trim + (Source.Reference (1 .. Source.Last), Left, Right)); + Source.Last := Source.Reference'Length; + Free (Old); + end Trim; + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-stzunb.ads b/gcc/ada/a-stzunb.ads new file mode 100644 index 00000000000..3090b6ee6b2 --- /dev/null +++ b/gcc/ada/a-stzunb.ads @@ -0,0 +1,380 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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_Maps; +with Ada.Finalization; + +package Ada.Strings.Wide_Wide_Unbounded is +pragma Preelaborate (Wide_Wide_Unbounded); + + type Unbounded_Wide_Wide_String is private; + + 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 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, 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 "=" + (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_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + 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; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- Wide_Wide_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); + + --------------------------------------- + -- Wide_Wide_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; + + Null_Wide_Wide_String : aliased Wide_Wide_String := ""; + + function To_Unbounded_Wide + (S : Wide_Wide_String) return Unbounded_Wide_Wide_String + renames To_Unbounded_Wide_Wide_String; + + type Unbounded_Wide_Wide_String is new AF.Controlled with record + Reference : Wide_Wide_String_Access := Null_Wide_Wide_String'Access; + Last : Natural := 0; + end record; + + -- The Unbounded_Wide_Wide_String is using a buffered implementation to + -- increase speed of the Append/Delete/Insert procedures. The Reference + -- string pointer above contains the current string value and extra room + -- at the end to be used by the next Append routine. Last is the index of + -- the string ending character. So the current string value is really + -- Reference (1 .. Last). + + pragma Stream_Convert + (Unbounded_Wide_Wide_String, To_Unbounded_Wide, To_Wide_Wide_String); + + pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String); + procedure Adjust (Object : in out Unbounded_Wide_Wide_String); + procedure Finalize (Object : in out Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := + (AF.Controlled with Reference => Null_Wide_Wide_String'Access, Last => 0); + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-swunau.adb b/gcc/ada/a-swunau.adb new file mode 100644 index 00000000000..2d9a2dd0b1c --- /dev/null +++ b/gcc/ada/a-swunau.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME 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-2005, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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 -- + --------------------- + + function Get_Wide_String + (U : Unbounded_Wide_String) return Wide_String_Access + is + begin + if U.Last = U.Reference'Length then + return U.Reference; + + else + declare + type Unbounded_Wide_String_Access is + access all Unbounded_Wide_String; + + U_Ptr : constant Unbounded_Wide_String_Access := + U'Unrestricted_Access; + -- Unbounded_Wide_String is a controlled type which is always + -- passed by copy it is always safe to take the pointer to such + -- object here. This pointer is used to set the U.Reference value + -- which would not be possible otherwise as U is read-only. + + Old : Wide_String_Access := U.Reference; + + begin + U_Ptr.Reference := new Wide_String'(U.Reference (1 .. U.Last)); + Free (Old); + return U.Reference; + end; + end if; + end Get_Wide_String; + + --------------------- + -- Set_Wide_String -- + --------------------- + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String) + is + begin + if UP.Last = S'Length then + UP.Reference.all := S; + + else + declare + subtype String_1 is Wide_String (1 .. S'Length); + Tmp : Wide_String_Access; + begin + Tmp := new Wide_String'(String_1 (S)); + Finalize (UP); + UP.Reference := Tmp; + UP.Last := UP.Reference'Length; + end; + end if; + end Set_Wide_String; + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access) + is + begin + Finalize (UP); + UP.Reference := S; + UP.Last := UP.Reference'Length; + end Set_Wide_String; + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/a-swunau.ads b/gcc/ada/a-swunau.ads new file mode 100644 index 00000000000..dbecd4f0b11 --- /dev/null +++ b/gcc/ada/a-swunau.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME 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 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Wide_Unbounded provides some specialized +-- access functions which are intended to allow more efficient use of the +-- facilities of Ada.Strings.Wide_Unbounded, particularly by other layered +-- utilities. + +package Ada.Strings.Wide_Unbounded.Aux is +pragma Preelaborate (Aux); + + function Get_Wide_String + (U : Unbounded_Wide_String) return Wide_String_Access; + pragma Inline (Get_Wide_String); + -- This function returns the internal string pointer used in the + -- representation of an unbounded string. There is no copy involved, + -- so the value obtained references the same string as the original + -- unbounded string. The characters of this string may not be modified + -- via the returned pointer, and are valid only as long as the original + -- unbounded string is not modified. Violating either of these two + -- rules results in erroneous execution. + -- + -- This function is much more efficient than the use of To_Wide_String + -- since it avoids the need to copy the string. The lower bound of the + -- referenced string returned by this call is always one. + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String); + pragma Inline (Set_Wide_String); + -- This function sets the string contents of the referenced unbounded + -- string to the given string value. It is significantly more efficient + -- than the use of To_Unbounded_Wide_String with an assignment, since it + -- avoids the necessity of messing with finalization chains. The lower + -- bound of the string S is not required to be one. + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access); + pragma Inline (Set_Wide_String); + -- This version of Set_Wide_String takes a string access value, rather + -- than string. The lower bound of the string value is required to be one, + -- and this requirement is not checked. + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/a-swunha.adb b/gcc/ada/a-swunha.adb new file mode 100644 index 00000000000..8229494e769 --- /dev/null +++ b/gcc/ada/a-swunha.adb @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.HASH -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) + +function Ada.Strings.Wide_Unbounded.Hash + (Key : Unbounded_Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + + function Rotate_Left + (Value : Hash_Type; + Amount : Natural) return Hash_Type; + pragma Import (Intrinsic, Rotate_Left); + + Tmp : Hash_Type; + +begin + Tmp := 0; + for J in 1 .. Key.Last loop + Tmp := Rotate_Left (Tmp, 1) + Wide_Character'Pos (Key.Reference (J)); + end loop; + + return Tmp; +end Ada.Strings.Wide_Unbounded.Hash; diff --git a/gcc/ada/a-swunha.ads b/gcc/ada/a-swunha.ads new file mode 100644 index 00000000000..267392f77f2 --- /dev/null +++ b/gcc/ada/a-swunha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.HASH -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Wide_Unbounded.Hash + (Key : Unbounded_Wide_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Unbounded.Hash); diff --git a/gcc/ada/a-szmzco.ads b/gcc/ada/a-szmzco.ads new file mode 100644 index 00000000000..d82e2ba8e58 --- /dev/null +++ b/gcc/ada/a-szmzco.ads @@ -0,0 +1,453 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_MAPS.WIDE_WIDE_CONSTANTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Wide_Wide_Latin_1; + +package Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants is +pragma Preelaborate (Wide_Wide_Constants); + + Control_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Graphic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Letter_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Lower_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Upper_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Basic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Decimal_Digit_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Hexadecimal_Digit_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Alphanumeric_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Special_Graphic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + ISO_646_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Character_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + + Lower_Case_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; + -- Maps to lower case for letters, else identity + + Upper_Case_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; + -- Maps to upper case for letters, else identity + + Basic_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; + -- Maps to basic letter for letters, else identity + +private + package W renames Ada.Characters.Wide_Wide_Latin_1; + + subtype WC is Wide_Wide_Character; + + Control_Ranges : aliased constant Wide_Wide_Character_Ranges := + ((W.NUL, W.US), + (W.DEL, W.APC)); + + Control_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Control_Ranges'Unrestricted_Access); + + Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges := + ((W.Space, W.Tilde), + (WC'Val (256), WC'Last)); + + Graphic_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Graphic_Ranges'Unrestricted_Access); + + Letter_Ranges : aliased constant Wide_Wide_Character_Ranges := + (('A', 'Z'), + (W.LC_A, W.LC_Z), + (W.UC_A_Grave, W.UC_O_Diaeresis), + (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), + (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Letter_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Letter_Ranges'Unrestricted_Access); + + Lower_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => (W.LC_A, W.LC_Z), + 2 => (W.LC_German_Sharp_S, W.LC_O_Diaeresis), + 3 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Lower_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Lower_Ranges'Unrestricted_Access); + + Upper_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('A', 'Z'), + 2 => (W.UC_A_Grave, W.UC_O_Diaeresis), + 3 => (W.UC_O_Oblique_Stroke, W.UC_Icelandic_Thorn)); + + Upper_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Upper_Ranges'Unrestricted_Access); + + Basic_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('A', 'Z'), + 2 => (W.LC_A, W.LC_Z), + 3 => (W.UC_AE_Diphthong, W.UC_AE_Diphthong), + 4 => (W.LC_AE_Diphthong, W.LC_AE_Diphthong), + 5 => (W.LC_German_Sharp_S, W.LC_German_Sharp_S), + 6 => (W.UC_Icelandic_Thorn, W.UC_Icelandic_Thorn), + 7 => (W.LC_Icelandic_Thorn, W.LC_Icelandic_Thorn), + 8 => (W.UC_Icelandic_Eth, W.UC_Icelandic_Eth), + 9 => (W.LC_Icelandic_Eth, W.LC_Icelandic_Eth)); + + Basic_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Basic_Ranges'Unrestricted_Access); + + Decimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('0', '9')); + + Decimal_Digit_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Decimal_Digit_Ranges'Unrestricted_Access); + + Hexadecimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('0', '9'), + 2 => ('A', 'F'), + 3 => (W.LC_A, W.LC_F)); + + Hexadecimal_Digit_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Hexadecimal_Digit_Ranges'Unrestricted_Access); + + Alphanumeric_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('0', '9'), + 2 => ('A', 'Z'), + 3 => (W.LC_A, W.LC_Z), + 4 => (W.UC_A_Grave, W.UC_O_Diaeresis), + 5 => (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), + 6 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Alphanumeric_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Alphanumeric_Ranges'Unrestricted_Access); + + Special_Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => (Wide_Wide_Space, W.Solidus), + 2 => (W.Colon, W.Commercial_At), + 3 => (W.Left_Square_Bracket, W.Grave), + 4 => (W.Left_Curly_Bracket, W.Tilde), + 5 => (W.No_Break_Space, W.Inverted_Question), + 6 => (W.Multiplication_Sign, W.Multiplication_Sign), + 7 => (W.Division_Sign, W.Division_Sign)); + + Special_Graphic_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Special_Graphic_Ranges'Unrestricted_Access); + + ISO_646_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => (W.NUL, W.DEL)); + + ISO_646_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + ISO_646_Ranges'Unrestricted_Access); + + Character_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => (W.NUL, WC'Val (255))); + + Character_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Character_Ranges'Unrestricted_Access); + + + Lower_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := + (Length => 56, + + Domain => + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_AE_Diphthong & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_Icelandic_Eth & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.UC_Icelandic_Thorn, + + Rangev => + "abcdefghijklmnopqrstuvwxyz" & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_AE_Diphthong & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_Icelandic_Eth & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Icelandic_Thorn); + + Lower_Case_Map : constant Wide_Wide_Character_Mapping := + (AF.Controlled with + Map => Lower_Case_Mapping'Unrestricted_Access); + + Upper_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := + (Length => 56, + + Domain => + "abcdefghijklmnopqrstuvwxyz" & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_AE_Diphthong & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_Icelandic_Eth & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Icelandic_Thorn, + + Rangev => + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_AE_Diphthong & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_Icelandic_Eth & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.UC_Icelandic_Thorn); + + Upper_Case_Map : constant Wide_Wide_Character_Mapping := + (AF.Controlled with + Upper_Case_Mapping'Unrestricted_Access); + + Basic_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := + (Length => 55, + + Domain => + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Y_Diaeresis, + + Rangev => + 'A' & -- UC_A_Grave + 'A' & -- UC_A_Acute + 'A' & -- UC_A_Circumflex + 'A' & -- UC_A_Tilde + 'A' & -- UC_A_Diaeresis + 'A' & -- UC_A_Ring + 'C' & -- UC_C_Cedilla + 'E' & -- UC_E_Grave + 'E' & -- UC_E_Acute + 'E' & -- UC_E_Circumflex + 'E' & -- UC_E_Diaeresis + 'I' & -- UC_I_Grave + 'I' & -- UC_I_Acute + 'I' & -- UC_I_Circumflex + 'I' & -- UC_I_Diaeresis + 'N' & -- UC_N_Tilde + 'O' & -- UC_O_Grave + 'O' & -- UC_O_Acute + 'O' & -- UC_O_Circumflex + 'O' & -- UC_O_Tilde + 'O' & -- UC_O_Diaeresis + 'O' & -- UC_O_Oblique_Stroke + 'U' & -- UC_U_Grave + 'U' & -- UC_U_Acute + 'U' & -- UC_U_Circumflex + 'U' & -- UC_U_Diaeresis + 'Y' & -- UC_Y_Acute + 'a' & -- LC_A_Grave + 'a' & -- LC_A_Acute + 'a' & -- LC_A_Circumflex + 'a' & -- LC_A_Tilde + 'a' & -- LC_A_Diaeresis + 'a' & -- LC_A_Ring + 'c' & -- LC_C_Cedilla + 'e' & -- LC_E_Grave + 'e' & -- LC_E_Acute + 'e' & -- LC_E_Circumflex + 'e' & -- LC_E_Diaeresis + 'i' & -- LC_I_Grave + 'i' & -- LC_I_Acute + 'i' & -- LC_I_Circumflex + 'i' & -- LC_I_Diaeresis + 'n' & -- LC_N_Tilde + 'o' & -- LC_O_Grave + 'o' & -- LC_O_Acute + 'o' & -- LC_O_Circumflex + 'o' & -- LC_O_Tilde + 'o' & -- LC_O_Diaeresis + 'o' & -- LC_O_Oblique_Stroke + 'u' & -- LC_U_Grave + 'u' & -- LC_U_Acute + 'u' & -- LC_U_Circumflex + 'u' & -- LC_U_Diaeresis + 'y' & -- LC_Y_Acute + 'y'); -- LC_Y_Diaeresis + + Basic_Map : constant Wide_Wide_Character_Mapping := + (AF.Controlled with + Basic_Mapping'Unrestricted_Access); + +end Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants; diff --git a/gcc/ada/a-szunau.adb b/gcc/ada/a-szunau.adb new file mode 100644 index 00000000000..e0f1acf50a8 --- /dev/null +++ b/gcc/ada/a-szunau.adb @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME 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-2005, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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 -- + -------------------------- + + function Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String) return Wide_Wide_String_Access + is + begin + if U.Last = U.Reference'Length then + return U.Reference; + + else + declare + type Unbounded_Wide_Wide_String_Access is + access all Unbounded_Wide_Wide_String; + + U_Ptr : constant Unbounded_Wide_Wide_String_Access := + U'Unrestricted_Access; + -- Unbounded_Wide_Wide_String is a controlled type which is always + -- passed by copy it is always safe to take the pointer to such + -- object here. This pointer is used to set the U.Reference value + -- which would not be possible otherwise as U is read-only. + + Old : Wide_Wide_String_Access := U.Reference; + + begin + U_Ptr.Reference := + new Wide_Wide_String'(U.Reference (1 .. U.Last)); + Free (Old); + return U.Reference; + end; + end if; + 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) + is + begin + if UP.Last = S'Length then + UP.Reference.all := S; + + else + declare + subtype String_1 is Wide_Wide_String (1 .. S'Length); + Tmp : Wide_Wide_String_Access; + begin + Tmp := new Wide_Wide_String'(String_1 (S)); + Finalize (UP); + UP.Reference := Tmp; + UP.Last := UP.Reference'Length; + end; + end if; + end Set_Wide_Wide_String; + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access) + is + begin + Finalize (UP); + UP.Reference := S; + UP.Last := UP.Reference'Length; + end Set_Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/a-szunau.ads b/gcc/ada/a-szunau.ads new file mode 100644 index 00000000000..dff8cb8e6c9 --- /dev/null +++ b/gcc/ada/a-szunau.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME 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 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Wide_Wide_Unbounded provides some +-- specialized access functions which are intended to allow more efficient +-- use of the facilities of Ada.Strings.Wide_Wide_Unbounded, particularly by +-- other layered utilities. + +package Ada.Strings.Wide_Wide_Unbounded.Aux is +pragma Preelaborate (Aux); + + function Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String) return Wide_Wide_String_Access; + pragma Inline (Get_Wide_Wide_String); + -- This function returns the internal string pointer used in the + -- representation of an unbounded string. There is no copy involved, + -- so the value obtained references the same string as the original + -- unbounded string. The characters of this string may not be modified + -- via the returned pointer, and are valid only as long as the original + -- unbounded string is not modified. Violating either of these two + -- rules results in erroneous execution. + -- + -- This function is much more efficient than the use of To_Wide_Wide_String + -- since it avoids the need to copy the string. The lower bound of the + -- referenced string returned by this call is always one. + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String); + pragma Inline (Set_Wide_Wide_String); + -- This function sets the string contents of the referenced unbounded + -- string to the given string value. It is significantly more efficient + -- than the use of To_Unbounded_Wide_Wide_String with an assignment, since + -- it avoids the necessity of messing with finalization chains. The lower + -- bound of the string S is not required to be one. + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access); + pragma Inline (Set_Wide_Wide_String); + -- This version of Set_Wide_Wide_String takes a string access value, rather + -- than string. The lower bound of the string value is required to be one, + -- and this requirement is not checked. + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/a-szunha.adb b/gcc/ada/a-szunha.adb new file mode 100644 index 00000000000..68e605674cf --- /dev/null +++ b/gcc/ada/a-szunha.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Note: source of this algorithm: GNAT.HTable.Hash (g-htable.adb) + +function Ada.Strings.Wide_Wide_Unbounded.Hash + (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + + function Rotate_Left + (Value : Hash_Type; + Amount : Natural) return Hash_Type; + pragma Import (Intrinsic, Rotate_Left); + + Tmp : Hash_Type; + +begin + Tmp := 0; + for J in 1 .. Key.Last loop + Tmp := Rotate_Left (Tmp, 1) + + Wide_Wide_Character'Pos (Key.Reference (J)); + end loop; + + return Tmp; +end Ada.Strings.Wide_Wide_Unbounded.Hash; diff --git a/gcc/ada/a-szunha.ads b/gcc/ada/a-szunha.ads new file mode 100644 index 00000000000..e1b872104f2 --- /dev/null +++ b/gcc/ada/a-szunha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Wide_Wide_Unbounded.Hash + (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Hash); diff --git a/gcc/ada/a-szuzti.adb b/gcc/ada/a-szuzti.adb new file mode 100644 index 00000000000..e9af2eb1a88 --- /dev/null +++ b/gcc/ada/a-szuzti.adb @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_UNBOUNDED.WIDE_WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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_Unbounded.Aux; +use Ada.Strings.Wide_Wide_Unbounded.Aux; +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; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Set_Wide_Wide_String (Result, Str1); + 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; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Set_Wide_Wide_String (Result, Str1); + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + + begin + Get_Line (Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Set_Wide_Wide_String (Item, Str1); + 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; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + + begin + Get_Line (File, Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Set_Wide_Wide_String (Item, Str1); + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_Wide_String) is + begin + Put (Get_Wide_Wide_String (U).all); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is + begin + Put (File, Get_Wide_Wide_String (U).all); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_Wide_String) is + begin + Put_Line (Get_Wide_Wide_String (U).all); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is + begin + Put_Line (File, Get_Wide_Wide_String (U).all); + end Put_Line; + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-szuzti.ads b/gcc/ada/a-szuzti.ads new file mode 100644 index 00000000000..bc4278ac983 --- /dev/null +++ b/gcc/ada/a-szuzti.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_UNBOUNDED.WIDE_WIDE_TEXT_IO -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Wide_Wide_Unbounded provides specialized +-- Wide_Wide_Text_IO routines that work directly with unbounded wide wide +-- strings, avoiding the inefficiencies of access via the standard interface, +-- and also taking direct advantage of the variable length semantics of these +-- strings. + +with Ada.Wide_Wide_Text_IO; + +package Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + function Get_Line + return Unbounded_Wide_Wide_String; + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) + return Unbounded_Wide_Wide_String; + -- Reads up to the end of the current line, returning the result + -- as an unbounded string of appropriate length. If no File parameter + -- is present, input is from Current_Input. + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String); + procedure Get_Line (Item : out Unbounded_Wide_Wide_String); + -- Similar to the above, but in procedure form with an out parameter + + procedure Put + (U : Unbounded_Wide_Wide_String); + procedure Put + (File : Ada.Wide_Wide_Text_IO.File_Type; + U : Unbounded_Wide_Wide_String); + procedure Put_Line + (U : Unbounded_Wide_Wide_String); + procedure Put_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + U : Unbounded_Wide_Wide_String); + -- These are equivalent to the standard Wide_Wide_Text_IO routines passed + -- the value To_Wide_Wide_String (U), but operate more efficiently, + -- because the extra copy of the argument is avoided. + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-tiunio.ads b/gcc/ada/a-tiunio.ads new file mode 100644 index 00000000000..43406af1c46 --- /dev/null +++ b/gcc/ada/a-tiunio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . U N B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Unbounded. So we implement this new Ada 2005 package +-- by renaming the subprograms in that child. This is a more straightforward +-- implementation anyway, since we need access to the internal representation +-- of Ada.Strings.Unbounded.Unbounded_String. + + +with Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; + +package Ada.Text_IO.Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put; + + procedure Put + (Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put; + + procedure Put_Line + (File : Text_IO.File_Type; + Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put_Line; + + function Get_Line + (File : File_Type) return Strings.Unbounded.Unbounded_String + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + function Get_Line return Strings.Unbounded.Unbounded_String + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + +end Ada.Text_IO.Unbounded_IO; diff --git a/gcc/ada/a-wwunio.ads b/gcc/ada/a-wwunio.ads new file mode 100644 index 00000000000..665f781a243 --- /dev/null +++ b/gcc/ada/a-wwunio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . W I D E _ U N B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Wide_Unbounded. So we implement this new Ada 2005 +-- package by renaming the subprograms in that child. This is a more +-- straightforward implementation anyway, since we need access to the +-- internal representation of Unbounded_Wide_String. + + +with Ada.Strings.Wide_Unbounded; +with Ada.Strings.Wide_Unbounded.Wide_Text_IO; + +package Ada.Wide_Text_IO.Wide_Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put; + + procedure Put + (Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put; + + procedure Put_Line + (File : Wide_Text_IO.File_Type; + Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line; + + function Get_Line + (File : File_Type) return Strings.Wide_Unbounded.Unbounded_Wide_String + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + function Get_Line return Strings.Wide_Unbounded.Unbounded_Wide_String + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + +end Ada.Wide_Text_IO.Wide_Unbounded_IO; diff --git a/gcc/ada/a-ztcoau.adb b/gcc/ada/a-ztcoau.adb new file mode 100644 index 00000000000..a1b966fb194 --- /dev/null +++ b/gcc/ada/a-ztcoau.adb @@ -0,0 +1,205 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; +with Ada.Wide_Wide_Text_IO.Float_Aux; + +with System.Img_Real; use System.Img_Real; + +package body Ada.Wide_Wide_Text_IO.Complex_Aux is + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer; + Paren : Boolean := False; + + begin + -- General note for following code, exceptions from the calls + -- to Get for components of the complex value are propagated. + + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr); + + for J in Ptr + 1 .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + + -- Case of width = 0 + + else + Load_Skip (File); + Ptr := 0; + Load (File, Buf, Ptr, '(', Paren); + Aux.Get (File, ItemR, 0); + Load_Skip (File); + Load (File, Buf, Ptr, ','); + Aux.Get (File, ItemI, 0); + + if Paren then + Load_Skip (File); + Load (File, Buf, Ptr, ')', Paren); + + if not Paren then + raise Data_Error; + end if; + end if; + end if; + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive) + is + Paren : Boolean; + Pos : Integer; + + begin + String_Skip (From, Pos); + + if From (Pos) = '(' then + Pos := Pos + 1; + Paren := True; + else + Paren := False; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemR, Pos); + + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) = ',' then + Pos := Pos + 1; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemI, Pos); + + if Paren then + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) /= ')' then + raise Data_Error; + end if; + end if; + + Last := Pos; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + begin + Put (File, '('); + Aux.Put (File, ItemR, Fore, Aft, Exp); + Put (File, ','); + Aux.Put (File, ItemI, Fore, Aft, Exp); + Put (File, ')'); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field) + is + I_String : String (1 .. 3 * Field'Last); + R_String : String (1 .. 3 * Field'Last); + + Iptr : Natural; + Rptr : Natural; + + begin + -- Both parts are initially converted with a Fore of 0 + + Rptr := 0; + Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); + Iptr := 0; + Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); + + -- Check room for both parts plus parens plus comma (RM G.1.3(34)) + + if Rptr + Iptr + 3 > To'Length then + raise Layout_Error; + end if; + + -- If there is room, layout result according to (RM G.1.3(31-33)) + + To (To'First) := '('; + To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr); + To (To'First + Rptr + 1) := ','; + + To (To'Last) := ')'; + + + To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr); + + for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop + To (J) := ' '; + end loop; + end Puts; + +end Ada.Wide_Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/a-ztcoau.ads b/gcc/ada/a-ztcoau.ads new file mode 100644 index 00000000000..e29fb4c2747 --- /dev/null +++ b/gcc/ada/a-ztcoau.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Complex_IO +-- that are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Complex_IO itself, +-- except that the generic parameter Complex has been replaced by separate +-- real and imaginary values of type Long_Long_Float, and default parameters +-- have been removed because they are supplied explicitly by the calls from +-- within the generic template. + +package Ada.Wide_Wide_Text_IO.Complex_Aux is + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field); + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive); + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Wide_Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/a-ztcoio.adb b/gcc/ada/a-ztcoio.adb new file mode 100644 index 00000000000..9deceee826e --- /dev/null +++ b/gcc/ada/a-ztcoio.adb @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Complex_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +with Ada.Unchecked_Conversion; + +package body Ada.Wide_Wide_Text_IO.Complex_IO is + + package Aux renames Ada.Wide_Wide_Text_IO.Complex_Aux; + + subtype LLF is Long_Long_Float; + -- Type used for calls to routines in Aux + + function TFT is new + Ada.Unchecked_Conversion (File_Type, Ada.Wide_Wide_Text_IO.File_Type); + -- This unchecked conversion is to get around a visibility bug in + -- GNAT version 2.04w. It should be possible to simply use the + -- subtype declared above and do normal checked conversions. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + begin + Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); + Item := (Real_Item, Imag_Item); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (Item : out Complex; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (From : Wide_Wide_String; + Item : out Complex; + Last : out Positive) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); + Item := (Real_Item, Imag_Item); + + exception + when Data_Error => raise Constraint_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (To : out Wide_Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-ztcoio.ads b/gcc/ada/a-ztcoio.ads new file mode 100644 index 00000000000..69e0371ab87 --- /dev/null +++ b/gcc/ada/a-ztcoio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + +package Ada.Wide_Wide_Text_IO.Complex_IO is + + use Complex_Types; + + Default_Fore : Field := 2; + Default_Aft : Field := Real'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0); + + procedure Get + (Item : out Complex; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Complex; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-ztcstr.adb b/gcc/ada/a-ztcstr.adb new file mode 100644 index 00000000000..036964079c4 --- /dev/null +++ b/gcc/ada/a-ztcstr.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with Unchecked_Conversion; + +package body Ada.Wide_Wide_Text_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : FILEs; + Form : String := ""; + Name : String := "") + is + Dummy_File_Control_Block : Wide_Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => False, + Text => True, + C_Stream => C_Stream); + + end Open; + +end Ada.Wide_Wide_Text_IO.C_Streams; diff --git a/gcc/ada/a-ztcstr.ads b/gcc/ada/a-ztcstr.ads new file mode 100644 index 00000000000..8627cca287a --- /dev/null +++ b/gcc/ada/a-ztcstr.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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 interface between Ada.Wide_Wide_Text_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +package Ada.Wide_Wide_Text_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Wide_Wide_Text_IO.C_Streams; diff --git a/gcc/ada/a-ztdeau.adb b/gcc/ada/a-ztdeau.adb new file mode 100644 index 00000000000..c20d7ad4260 --- /dev/null +++ b/gcc/ada/a-ztdeau.adb @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; +with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux; + +with System.Img_Dec; use System.Img_Dec; +with System.Img_LLD; use System.Img_LLD; +with System.Val_Dec; use System.Val_Dec; +with System.Val_LLD; use System.Val_LLD; + +package body Ada.Wide_Wide_Text_IO.Decimal_Aux is + + ------------- + -- Get_Dec -- + ------------- + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Integer; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get_Dec; + + ------------- + -- Get_LLD -- + ------------- + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Long_Long_Integer; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get_LLD; + + -------------- + -- Gets_Dec -- + -------------- + + function Gets_Dec + (From : String; + Last : access Positive; + Scale : Integer) return Integer + is + Pos : aliased Integer; + Item : Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); + Last.all := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last.all := Pos - 1; + raise Data_Error; + + end Gets_Dec; + + -------------- + -- Gets_LLD -- + -------------- + + function Gets_LLD + (From : String; + Last : access Positive; + Scale : Integer) return Long_Long_Integer + is + Pos : aliased Integer; + Item : Long_Long_Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); + Last.all := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last.all := Pos - 1; + raise Data_Error; + + end Gets_LLD; + + ------------- + -- Put_Dec -- + ------------- + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put_Dec; + + ------------- + -- Put_LLD -- + ------------- + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLD; + + -------------- + -- Puts_Dec -- + -------------- + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Fore : Integer; + Ptr : Natural := 0; + + begin + if Exp = 0 then + Fore := To'Length - 1 - Aft; + else + Fore := To'Length - 2 - Aft - Exp; + end if; + + if Fore < 1 then + raise Layout_Error; + end if; + + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts_Dec; + + -------------- + -- Puts_Dec -- + -------------- + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Fore : Integer; + Ptr : Natural := 0; + + begin + if Exp = 0 then + Fore := To'Length - 1 - Aft; + else + Fore := To'Length - 2 - Aft - Exp; + end if; + + if Fore < 1 then + raise Layout_Error; + end if; + + Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts_LLD; + +end Ada.Wide_Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-ztdeau.ads b/gcc/ada/a-ztdeau.ads new file mode 100644 index 00000000000..e5c8e53d764 --- /dev/null +++ b/gcc/ada/a-ztdeau.ads @@ -0,0 +1,95 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Decimal_IO +-- that are shared among separate instantiations of this package. The +-- routines in the package are identical semantically to those declared +-- in Wide_Wide_Text_IO, except that default values have been supplied by the +-- generic, and the Num parameter has been replaced by Integer or +-- Long_Long_Integer, with an additional Scale parameter giving the +-- value of Num'Scale. In addition the Get routines return the value +-- rather than store it in an Out parameter. + +private package Ada.Wide_Wide_Text_IO.Decimal_Aux is + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer; + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer; + + function Gets_Dec + (From : String; + Last : access Positive; + Scale : Integer) return Integer; + + function Gets_LLD + (From : String; + Last : access Positive; + Scale : Integer) return Long_Long_Integer; + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + +end Ada.Wide_Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-ztdeio.adb b/gcc/ada/a-ztdeio.adb new file mode 100644 index 00000000000..b223cdb4490 --- /dev/null +++ b/gcc/ada/a-ztdeio.adb @@ -0,0 +1,173 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Decimal_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Decimal_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Decimal_Aux; + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Integer'Size then + Item := Num (Aux.Get_LLD (TFT (File), Width, Scale)); + -- Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); + -- above is what we should write, but gets assert error ??? + + else + Item := Num (Aux.Get_Dec (TFT (File), Width, Scale)); + -- Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); + -- above is what we should write, but gets assert error ??? + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Integer'Size then + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); + else + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Num'Size > Integer'Size then + Aux.Put_LLD +-- (TFT (File), Long_Long_Integer'Integer_Value (Item), +-- ??? + (TFT (File), Long_Long_Integer (Item), + Fore, Aft, Exp, Scale); + else + Aux.Put_Dec +-- (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); +-- ??? + (TFT (File), Integer (Item), Fore, Aft, Exp, Scale); + + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + pragma Unreferenced (Fore); + -- ??? how come this is unreferenced, sounds wrong ??? + begin + Put (Current_Output, Item, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + if Num'Size > Integer'Size then +-- Aux.Puts_LLD +-- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); +-- ??? + Aux.Puts_LLD + (S, Long_Long_Integer (Item), Aft, Exp, Scale); + else +-- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale); +-- ??? + Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-ztdeio.ads b/gcc/ada/a-ztdeio.ads new file mode 100644 index 00000000000..694a0bc3c49 --- /dev/null +++ b/gcc/ada/a-ztdeio.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Decimal_IO is a subpackage of +-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading the +-- necessary code if Decimal_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the difference +-- in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <> digits <>; + +package Ada.Wide_Wide_Text_IO.Decimal_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-ztedit.adb b/gcc/ada/a-ztedit.adb new file mode 100644 index 00000000000..14de63c1ab2 --- /dev/null +++ b/gcc/ada/a-ztedit.adb @@ -0,0 +1,2773 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +with Ada.Strings.Wide_Wide_Fixed; + +package body Ada.Wide_Wide_Text_IO.Editing is + + package Strings renames Ada.Strings; + package Strings_Fixed renames Ada.Strings.Fixed; + package Strings_Wide_Wide_Fixed renames Ada.Strings.Wide_Wide_Fixed; + package Wide_Wide_Text_IO renames Ada.Wide_Wide_Text_IO; + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + function To_Wide (C : Character) return Wide_Wide_Character; + pragma Inline (To_Wide); + -- Convert Character to corresponding Wide_Wide_Character + + --------------------- + -- Blank_When_Zero -- + --------------------- + + function Blank_When_Zero (Pic : in Picture) return Boolean is + begin + return Pic.Contents.Original_BWZ; + end Blank_When_Zero; + + -------------------- + -- Decimal_Output -- + -------------------- + + package body Decimal_Output is + + ----------- + -- Image -- + ----------- + + function Image + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + return Wide_Wide_String + is + begin + return Format_Number + (Pic.Contents, Num'Image (Item), + Currency, Fill, Separator, Radix_Mark); + end Image; + + ------------ + -- Length -- + ------------ + + function Length + (Pic : Picture; + Currency : Wide_Wide_String := Default_Currency) return Natural + is + Picstr : constant String := Pic_String (Pic); + V_Adjust : Integer := 0; + Cur_Adjust : Integer := 0; + + begin + -- Check if Picstr has 'V' or '$' + + -- If 'V', then length is 1 less than otherwise + + -- If '$', then length is Currency'Length-1 more than otherwise + + -- This should use the string handling package ??? + + for J in Picstr'Range loop + if Picstr (J) = 'V' then + V_Adjust := -1; + + elsif Picstr (J) = '$' then + Cur_Adjust := Currency'Length - 1; + end if; + end loop; + + return Picstr'Length - V_Adjust + Cur_Adjust; + end Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : Wide_Wide_Text_IO.File_Type; + Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + is + begin + Wide_Wide_Text_IO.Put (File, Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + is + begin + Wide_Wide_Text_IO.Put (Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + is + Result : constant Wide_Wide_String := + Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); + + begin + if Result'Length > To'Length then + raise Wide_Wide_Text_IO.Layout_Error; + else + Strings_Wide_Wide_Fixed.Move (Source => Result, Target => To, + Justify => Strings.Right); + end if; + end Put; + + ----------- + -- Valid -- + ----------- + + function Valid + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency) return Boolean + is + begin + declare + Temp : constant Wide_Wide_String := Image (Item, Pic, Currency); + pragma Warnings (Off, Temp); + begin + return True; + end; + + exception + when Layout_Error => return False; + + end Valid; + end Decimal_Output; + + ------------ + -- Expand -- + ------------ + + function Expand (Picture : in String) return String is + Result : String (1 .. MAX_PICSIZE); + Picture_Index : Integer := Picture'First; + Result_Index : Integer := Result'First; + Count : Natural; + Last : Integer; + + begin + if Picture'Length < 1 then + raise Picture_Error; + end if; + + if Picture (Picture'First) = '(' then + raise Picture_Error; + end if; + + loop + case Picture (Picture_Index) is + + when '(' => + + -- We now need to scan out the count after a left paren. In + -- the non-wide version we used Integer_IO.Get, but that is + -- not convenient here, since we don't want to drag in normal + -- Text_IO just for this purpose. So we do the scan ourselves, + -- with the normal validity checks. + + Last := Picture_Index + 1; + Count := 0; + + if Picture (Last) not in '0' .. '9' then + raise Picture_Error; + end if; + + Count := Character'Pos (Picture (Last)) - Character'Pos ('0'); + Last := Last + 1; + + loop + if Last > Picture'Last then + raise Picture_Error; + end if; + + if Picture (Last) = '_' then + if Picture (Last - 1) = '_' then + raise Picture_Error; + end if; + + elsif Picture (Last) = ')' then + exit; + + elsif Picture (Last) not in '0' .. '9' then + raise Picture_Error; + + else + Count := Count * 10 + + Character'Pos (Picture (Last)) - + Character'Pos ('0'); + end if; + + Last := Last + 1; + end loop; + + -- In what follows note that one copy of the repeated + -- character has already been made, so a count of one is + -- no-op, and a count of zero erases a character. + + for J in 2 .. Count loop + Result (Result_Index + J - 2) := Picture (Picture_Index - 1); + end loop; + + Result_Index := Result_Index + Count - 1; + + -- Last was a ')' throw it away too. + + Picture_Index := Last + 1; + + when ')' => + raise Picture_Error; + + when others => + Result (Result_Index) := Picture (Picture_Index); + Picture_Index := Picture_Index + 1; + Result_Index := Result_Index + 1; + + end case; + + exit when Picture_Index > Picture'Last; + end loop; + + return Result (1 .. Result_Index - 1); + + exception + when others => + raise Picture_Error; + end Expand; + + ------------------- + -- Format_Number -- + ------------------- + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : Wide_Wide_String; + Fill_Character : Wide_Wide_Character; + Separator_Character : Wide_Wide_Character; + Radix_Point : Wide_Wide_Character) return Wide_Wide_String + is + Attrs : Number_Attributes := Parse_Number_String (Number); + Position : Integer; + Rounded : String := Number; + + Sign_Position : Integer := Pic.Sign_Position; -- may float. + + Answer : Wide_Wide_String (1 .. Pic.Picture.Length); + Last : Integer; + Currency_Pos : Integer := Pic.Start_Currency; + + Dollar : Boolean := False; + -- Overridden immediately if necessary. + + Zero : Boolean := True; + -- Set to False when a non-zero digit is output. + + begin + + -- If the picture has fewer decimal places than the number, the image + -- must be rounded according to the usual rules. + + if Attrs.Has_Fraction then + declare + R : constant Integer := + (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1) + - Pic.Max_Trailing_Digits; + R_Pos : Integer; + + begin + if R > 0 then + R_Pos := Rounded'Length - R; + + if Rounded (R_Pos + 1) > '4' then + + if Rounded (R_Pos) = '.' then + R_Pos := R_Pos - 1; + end if; + + if Rounded (R_Pos) /= '9' then + Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); + else + Rounded (R_Pos) := '0'; + R_Pos := R_Pos - 1; + + while R_Pos > 1 loop + if Rounded (R_Pos) = '.' then + R_Pos := R_Pos - 1; + end if; + + if Rounded (R_Pos) /= '9' then + Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); + exit; + else + Rounded (R_Pos) := '0'; + R_Pos := R_Pos - 1; + end if; + end loop; + + -- The rounding may add a digit in front. Either the + -- leading blank or the sign (already captured) can be + -- overwritten. + + if R_Pos = 1 then + Rounded (R_Pos) := '1'; + Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1; + end if; + end if; + end if; + end if; + end; + end if; + + for J in Answer'Range loop + Answer (J) := To_Wide (Pic.Picture.Expanded (J)); + end loop; + + if Pic.Start_Currency /= Invalid_Position then + Dollar := Answer (Pic.Start_Currency) = '$'; + end if; + + -- Fix up "direct inserts" outside the playing field. Set up as one + -- loop to do the beginning, one (reverse) loop to do the end. + + Last := 1; + loop + exit when Last = Pic.Start_Float; + exit when Last = Pic.Radix_Position; + exit when Answer (Last) = '9'; + + case Answer (Last) is + + when '_' => + Answer (Last) := Separator_Character; + + when 'b' => + Answer (Last) := ' '; + + when others => + null; + + end case; + + exit when Last = Answer'Last; + + Last := Last + 1; + end loop; + + -- Now for the end... + + for J in reverse Last .. Answer'Last loop + exit when J = Pic.Radix_Position; + + -- Do this test First, Separator_Character can equal Pic.Floater + + if Answer (J) = Pic.Floater then + exit; + end if; + + case Answer (J) is + + when '_' => + Answer (J) := Separator_Character; + + when 'b' => + Answer (J) := ' '; + + when '9' => + exit; + + when others => + null; + + end case; + end loop; + + -- Non-floating sign + + if Pic.Start_Currency /= -1 + and then Answer (Pic.Start_Currency) = '#' + and then Pic.Floater /= '#' + then + if Currency_Symbol'Length > + Pic.End_Currency - Pic.Start_Currency + 1 + then + raise Picture_Error; + + elsif Currency_Symbol'Length = + Pic.End_Currency - Pic.Start_Currency + 1 + then + Answer (Pic.Start_Currency .. Pic.End_Currency) := + Currency_Symbol; + + elsif Pic.Radix_Position = Invalid_Position + or else Pic.Start_Currency < Pic.Radix_Position + then + Answer (Pic.Start_Currency .. Pic.End_Currency) := + (others => ' '); + Answer (Pic.End_Currency - Currency_Symbol'Length + 1 .. + Pic.End_Currency) := Currency_Symbol; + + else + Answer (Pic.Start_Currency .. Pic.End_Currency) := + (others => ' '); + Answer (Pic.Start_Currency .. + Pic.Start_Currency + Currency_Symbol'Length - 1) := + Currency_Symbol; + end if; + end if; + + -- Fill in leading digits + + if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > + Pic.Max_Leading_Digits + then + raise Layout_Error; + end if; + + if Pic.Radix_Position = Invalid_Position then + Position := Answer'Last; + else + Position := Pic.Radix_Position - 1; + end if; + + for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop + + while Answer (Position) /= '9' + and Answer (Position) /= Pic.Floater + loop + if Answer (Position) = '_' then + Answer (Position) := Separator_Character; + + elsif Answer (Position) = 'b' then + Answer (Position) := ' '; + end if; + + Position := Position - 1; + end loop; + + Answer (Position) := To_Wide (Rounded (J)); + + if Rounded (J) /= '0' then + Zero := False; + end if; + + Position := Position - 1; + end loop; + + -- Do lead float + + if Pic.Start_Float = Invalid_Position then + + -- No leading floats, but need to change '9' to '0', '_' to + -- Separator_Character and 'b' to ' '. + + for J in Last .. Position loop + + -- Last set when fixing the "uninteresting" leaders above. + -- Don't duplicate the work. + + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + + end loop; + + elsif Pic.Floater = '<' + or else + Pic.Floater = '+' + or else + Pic.Floater = '-' + then + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position - 1 loop + Answer (J) := ' '; + end loop; + + Answer (Position) := Pic.Floater; + Sign_Position := Position; + + elsif Pic.Floater = '$' then + + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := ' '; -- no separator before leftmost digit + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position - 1 loop + Answer (J) := ' '; + end loop; + + Answer (Position) := Pic.Floater; + Currency_Pos := Position; + + elsif Pic.Floater = '*' then + + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := '*'; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position loop + Answer (J) := '*'; + end loop; + + else + if Pic.Floater = '#' then + Currency_Pos := Currency_Symbol'Length; + end if; + + for J in reverse Pic.Start_Float .. Position loop + case Answer (J) is + + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'b' | '/' | '0' => + Answer (J) := ' '; + + when '9' => + Answer (J) := '0'; + + when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' => + null; + + when '#' => + if Currency_Pos = 0 then + Answer (J) := ' '; + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + end if; + + when '_' => + + case Pic.Floater is + + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'b' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos = 0 then + Answer (J) := ' '; + + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + end if; + + when others => + null; + + end case; + + when others => + null; + + end case; + end loop; + + if Pic.Floater = '#' and then Currency_Pos /= 0 then + raise Layout_Error; + end if; + end if; + + -- Do sign + + if Sign_Position = Invalid_Position then + if Attrs.Negative then + raise Layout_Error; + end if; + + else + if Attrs.Negative then + case Answer (Sign_Position) is + when 'C' | 'D' | '-' => + null; + + when '+' => + Answer (Sign_Position) := '-'; + + when '<' => + Answer (Sign_Position) := '('; + Answer (Pic.Second_Sign) := ')'; + + when others => + raise Picture_Error; + + end case; + + else -- positive + + case Answer (Sign_Position) is + + when '-' => + Answer (Sign_Position) := ' '; + + when '<' | 'C' | 'D' => + Answer (Sign_Position) := ' '; + Answer (Pic.Second_Sign) := ' '; + + when '+' => + null; + + when others => + raise Picture_Error; + + end case; + end if; + end if; + + -- Fill in trailing digits + + if Pic.Max_Trailing_Digits > 0 then + + if Attrs.Has_Fraction then + Position := Attrs.Start_Of_Fraction; + Last := Pic.Radix_Position + 1; + + for J in Last .. Answer'Last loop + + if Answer (J) = '9' or Answer (J) = Pic.Floater then + Answer (J) := To_Wide (Rounded (Position)); + + if Rounded (Position) /= '0' then + Zero := False; + end if; + + Position := Position + 1; + Last := J + 1; + + -- Used up fraction but remember place in Answer + + exit when Position > Attrs.End_Of_Fraction; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + end if; + + Last := J + 1; + end loop; + + Position := Last; + + else + Position := Pic.Radix_Position + 1; + end if; + + -- Now fill remaining 9's with zeros and _ with separators + + Last := Answer'Last; + + for J in Position .. Last loop + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = Pic.Floater then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + end loop; + + Position := Last + 1; + + else + if Pic.Floater = '#' and then Currency_Pos /= 0 then + raise Layout_Error; + end if; + + -- No trailing digits, but now J may need to stick in a currency + -- symbol or sign. + + if Pic.Start_Currency = Invalid_Position then + Position := Answer'Last + 1; + else + Position := Pic.Start_Currency; + end if; + end if; + + for J in Position .. Answer'Last loop + + if Pic.Start_Currency /= Invalid_Position and then + Answer (Pic.Start_Currency) = '#' then + Currency_Pos := 1; + end if; + + -- Note: There are some weird cases J can imagine with 'b' or '#' + -- in currency strings where the following code will cause + -- glitches. The trick is to tell when the character in the + -- answer should be checked, and when to look at the original + -- string. Some other time. RIE 11/26/96 ??? + + case Answer (J) is + when '*' => + Answer (J) := Fill_Character; + + when 'b' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos > Currency_Symbol'Length then + Answer (J) := ' '; + + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + end if; + + when '_' => + + case Pic.Floater is + + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'z' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos > Currency_Symbol'Length then + Answer (J) := ' '; + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + end if; + + when others => + null; + + end case; + + when others => + exit; + + end case; + end loop; + + -- Now get rid of Blank_when_Zero and complete Star fill. + + if Zero and Pic.Blank_When_Zero then + + -- Value is zero, and blank it. + + Last := Answer'Last; + + if Dollar then + Last := Last - 1 + Currency_Symbol'Length; + end if; + + if Pic.Radix_Position /= Invalid_Position and then + Answer (Pic.Radix_Position) = 'V' then + Last := Last - 1; + end if; + + return Wide_Wide_String'(1 .. Last => ' '); + + elsif Zero and Pic.Star_Fill then + Last := Answer'Last; + + if Dollar then + Last := Last - 1 + Currency_Symbol'Length; + end if; + + if Pic.Radix_Position /= Invalid_Position then + + if Answer (Pic.Radix_Position) = 'V' then + Last := Last - 1; + + elsif Dollar then + if Pic.Radix_Position > Pic.Start_Currency then + return + Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); + + else + return + Wide_Wide_String' + (1 .. + Pic.Radix_Position + Currency_Symbol'Length - 2 + => '*') & + Radix_Point & + Wide_Wide_String' + (Pic.Radix_Position + Currency_Symbol'Length .. Last + => '*'); + end if; + + else + return + Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); + end if; + end if; + + return Wide_Wide_String'(1 .. Last => '*'); + end if; + + -- This was once a simple return statement, now there are nine + -- different return cases. Not to mention the five above to deal + -- with zeros. Why not split things out? + + -- Processing the radix and sign expansion separately + -- would require lots of copying--the string and some of its + -- indicies--without really simplifying the logic. The cases are: + + -- 1) Expand $, replace '.' with Radix_Point + -- 2) No currency expansion, replace '.' with Radix_Point + -- 3) Expand $, radix blanked + -- 4) No currency expansion, radix blanked + -- 5) Elide V + -- 6) Expand $, Elide V + -- 7) Elide V, Expand $ (Two cases depending on order.) + -- 8) No radix, expand $ + -- 9) No radix, no currency expansion + + if Pic.Radix_Position /= Invalid_Position then + + if Answer (Pic.Radix_Position) = '.' then + Answer (Pic.Radix_Position) := Radix_Point; + + if Dollar then + + -- 1) Expand $, replace '.' with Radix_Point + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 2) No currency expansion, replace '.' with Radix_Point + + return Answer; + end if; + + elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. + if Dollar then + + -- 3) Expand $, radix blanked + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 4) No expansion, radix blanked + + return Answer; + end if; + + -- V cases + + else + if not Dollar then + + -- 5) Elide V + + return Answer (1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Answer'Last); + + elsif Currency_Pos < Pic.Radix_Position then + + -- 6) Expand $, Elide V + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Answer'Last); + + else + -- 7) Elide V, Expand $ + + return Answer (1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & + Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + end if; + end if; + + elsif Dollar then + + -- 8) No radix, expand $ + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 9) No radix, no currency expansion + + return Answer; + end if; + end Format_Number; + + ------------------------- + -- Parse_Number_String -- + ------------------------- + + function Parse_Number_String (Str : String) return Number_Attributes is + Answer : Number_Attributes; + + begin + for J in Str'Range loop + case Str (J) is + + when ' ' => + null; -- ignore + + when '1' .. '9' => + + -- Decide if this is the start of a number. + -- If so, figure out which one... + + if Answer.Has_Fraction then + Answer.End_Of_Fraction := J; + else + if Answer.Start_Of_Int = Invalid_Position then + -- start integer + Answer.Start_Of_Int := J; + end if; + Answer.End_Of_Int := J; + end if; + + when '0' => + + -- Only count a zero before the decimal point if it follows a + -- non-zero digit. After the decimal point, zeros will be + -- counted if followed by a non-zero digit. + + if not Answer.Has_Fraction then + if Answer.Start_Of_Int /= Invalid_Position then + Answer.End_Of_Int := J; + end if; + end if; + + when '-' => + + -- Set negative + + Answer.Negative := True; + + when '.' => + + -- Close integer, start fraction + + if Answer.Has_Fraction then + raise Picture_Error; + end if; + + -- Two decimal points is a no-no. + + Answer.Has_Fraction := True; + Answer.End_Of_Fraction := J; + + -- Could leave this at Invalid_Position, but this seems the + -- right way to indicate a null range... + + Answer.Start_Of_Fraction := J + 1; + Answer.End_Of_Int := J - 1; + + when others => + raise Picture_Error; -- can this happen? probably not! + end case; + end loop; + + if Answer.Start_Of_Int = Invalid_Position then + Answer.Start_Of_Int := Answer.End_Of_Int + 1; + end if; + + -- No significant (intger) digits needs a null range. + + return Answer; + end Parse_Number_String; + + ---------------- + -- Pic_String -- + ---------------- + + -- The following ensures that we return B and not b being careful not + -- to break things which expect lower case b for blank. See CXF3A02. + + function Pic_String (Pic : in Picture) return String is + Temp : String (1 .. Pic.Contents.Picture.Length) := + Pic.Contents.Picture.Expanded; + begin + for J in Temp'Range loop + if Temp (J) = 'b' then Temp (J) := 'B'; end if; + end loop; + + return Temp; + end Pic_String; + + ------------------ + -- Precalculate -- + ------------------ + + procedure Precalculate (Pic : in out Format_Record) is + + Computed_BWZ : Boolean := True; + + type Legality is (Okay, Reject); + State : Legality := Reject; + -- Start in reject, which will reject null strings. + + Index : Pic_Index := Pic.Picture.Expanded'First; + + function At_End return Boolean; + pragma Inline (At_End); + + procedure Set_State (L : Legality); + pragma Inline (Set_State); + + function Look return Character; + pragma Inline (Look); + + function Is_Insert return Boolean; + pragma Inline (Is_Insert); + + procedure Skip; + pragma Inline (Skip); + + procedure Trailing_Currency; + procedure Trailing_Bracket; + procedure Number_Fraction; + procedure Number_Completion; + procedure Number_Fraction_Or_Bracket; + procedure Number_Fraction_Or_Z_Fill; + procedure Zero_Suppression; + procedure Floating_Bracket; + procedure Number_Fraction_Or_Star_Fill; + procedure Star_Suppression; + procedure Number_Fraction_Or_Dollar; + procedure Leading_Dollar; + procedure Number_Fraction_Or_Pound; + procedure Leading_Pound; + procedure Picture; + procedure Floating_Plus; + procedure Floating_Minus; + procedure Picture_Plus; + procedure Picture_Minus; + procedure Picture_Bracket; + procedure Number; + procedure Optional_RHS_Sign; + procedure Picture_String; + + ------------ + -- At_End -- + ------------ + + function At_End return Boolean is + begin + return Index > Pic.Picture.Length; + end At_End; + + ---------------------- + -- Floating_Bracket -- + ---------------------- + + -- Note that Floating_Bracket is only called with an acceptable + -- prefix. But we don't set Okay, because we must end with a '>'. + + procedure Floating_Bracket is + begin + Pic.Floater := '<'; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + + -- First bracket wasn't counted... + + Skip; -- known '<' + + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Skip; + + when '9' => + Number_Completion; + + when '$' => + Leading_Dollar; + + when '#' => + Leading_Pound; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Bracket; + return; + + when others => + return; + end case; + end loop; + end Floating_Bracket; + + -------------------- + -- Floating_Minus -- + -------------------- + + procedure Floating_Minus is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '-' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '9' => + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; -- Radix + + while Is_Insert loop + Skip; + end loop; + + if At_End then + return; + end if; + + if Look = '-' then + loop + if At_End then + return; + end if; + + case Look is + + when '-' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + + end case; + end loop; + + else + Number_Completion; + end if; + + return; + + when others => + return; + end case; + end loop; + end Floating_Minus; + + ------------------- + -- Floating_Plus -- + ------------------- + + procedure Floating_Plus is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '+' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '9' => + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; -- Radix + + while Is_Insert loop + Skip; + end loop; + + if At_End then + return; + end if; + + if Look = '+' then + loop + if At_End then + return; + end if; + + case Look is + + when '+' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + + end case; + end loop; + + else + Number_Completion; + end if; + + return; + + when others => + return; + + end case; + end loop; + end Floating_Plus; + + --------------- + -- Is_Insert -- + --------------- + + function Is_Insert return Boolean is + begin + if At_End then + return False; + end if; + + case Pic.Picture.Expanded (Index) is + + when '_' | '0' | '/' => return True; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; -- canonical + return True; + + when others => return False; + end case; + end Is_Insert; + + -------------------- + -- Leading_Dollar -- + -------------------- + + -- Note that Leading_Dollar can be called in either State. + -- It will set state to Okay only if a 9 or (second) $ + -- is encountered. + + -- Also notice the tricky bit with State and Zero_Suppression. + -- Zero_Suppression is Picture_Error if a '$' or a '9' has been + -- encountered, exactly the cases where State has been set. + + procedure Leading_Dollar is + begin + -- Treat as a floating dollar, and unwind otherwise. + + Pic.Floater := '$'; + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- currency place. + + Skip; -- known '$' + + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + -- A trailing insertion character is not part of the + -- floating currency, so need to look ahead. + + if Look /= '$' then + Pic.End_Float := Pic.End_Float - 1; + end if; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + if State = Okay then + raise Picture_Error; + else + -- Will overwrite Floater and Start_Float + + Zero_Suppression; + end if; + + when '*' => + if State = Okay then + raise Picture_Error; + else + -- Will overwrite Floater and Start_Float + + Star_Suppression; + end if; + + when '$' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Pic.End_Currency := Index; + Set_State (Okay); Skip; + + when '9' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- A single dollar does not a floating make. + + Number_Completion; + return; + + when 'V' | 'v' | '.' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Only one dollar before the sign is okay, + -- but doesn't float. + + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Dollar; + return; + + when others => + return; + + end case; + end loop; + end Leading_Dollar; + + ------------------- + -- Leading_Pound -- + ------------------- + + -- This one is complex! A Leading_Pound can be fixed or floating, + -- but in some cases the decision has to be deferred until we leave + -- this procedure. Also note that Leading_Pound can be called in + -- either State. + + -- It will set state to Okay only if a 9 or (second) # is + -- encountered. + + -- One Last note: In ambiguous cases, the currency is treated as + -- floating unless there is only one '#'. + + procedure Leading_Pound is + + Inserts : Boolean := False; + -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered + + Must_Float : Boolean := False; + -- Set to true if a '#' occurs after an insert. + + begin + -- Treat as a floating currency. If it isn't, this will be + -- overwritten later. + + Pic.Floater := '#'; + + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- currency place. + + Pic.Max_Currency_Digits := 1; -- we've seen one. + + Skip; -- known '#' + + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Pic.End_Float := Index; + Inserts := True; + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Pic.End_Float := Index; + Inserts := True; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + if Must_Float then + raise Picture_Error; + else + Pic.Max_Leading_Digits := 0; + + -- Will overwrite Floater and Start_Float + + Zero_Suppression; + end if; + + when '*' => + if Must_Float then + raise Picture_Error; + else + Pic.Max_Leading_Digits := 0; + + -- Will overwrite Floater and Start_Float + + Star_Suppression; + end if; + + when '#' => + if Inserts then + Must_Float := True; + end if; + + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Pic.End_Currency := Index; + Set_State (Okay); + Skip; + + when '9' => + if State /= Okay then + + -- A single '#' doesn't float. + + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Number_Completion; + return; + + when 'V' | 'v' | '.' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Only one pound before the sign is okay, + -- but doesn't float. + + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Pound; + return; + + when others => + return; + end case; + end loop; + end Leading_Pound; + + ---------- + -- Look -- + ---------- + + function Look return Character is + begin + if At_End then + raise Picture_Error; + end if; + + return Pic.Picture.Expanded (Index); + end Look; + + ------------ + -- Number -- + ------------ + + procedure Number is + begin + loop + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + Skip; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + return; + + when others => + return; + + end case; + + if At_End then + return; + end if; + + -- Will return in Okay state if a '9' was seen. + + end loop; + end Number; + + ----------------------- + -- Number_Completion -- + ----------------------- + + procedure Number_Completion is + begin + while not At_End loop + case Look is + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + Skip; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + return; + + when others => + return; + end case; + end loop; + end Number_Completion; + + --------------------- + -- Number_Fraction -- + --------------------- + + procedure Number_Fraction is + begin + -- Note that number fraction can be called in either State. + -- It will set state to Valid only if a 9 is encountered. + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Set_State (Okay); Skip; + + when others => + return; + end case; + end loop; + end Number_Fraction; + + -------------------------------- + -- Number_Fraction_Or_Bracket -- + -------------------------------- + + procedure Number_Fraction_Or_Bracket is + begin + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Bracket; + + ------------------------------- + -- Number_Fraction_Or_Dollar -- + ------------------------------- + + procedure Number_Fraction_Or_Dollar is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Dollar; + + ------------------------------ + -- Number_Fraction_Or_Pound -- + ------------------------------ + + procedure Number_Fraction_Or_Pound is + begin + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '#' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '#' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + + end case; + end loop; + + when others => + Number_Fraction; + return; + + end case; + end loop; + end Number_Fraction_Or_Pound; + + ---------------------------------- + -- Number_Fraction_Or_Star_Fill -- + ---------------------------------- + + procedure Number_Fraction_Or_Star_Fill is + begin + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.Star_Fill := True; + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.Star_Fill := True; + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + + end case; + end loop; + end Number_Fraction_Or_Star_Fill; + + ------------------------------- + -- Number_Fraction_Or_Z_Fill -- + ------------------------------- + + procedure Number_Fraction_Or_Z_Fill is + begin + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Skip; + + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Z_Fill; + + ----------------------- + -- Optional_RHS_Sign -- + ----------------------- + + procedure Optional_RHS_Sign is + begin + if At_End then + return; + end if; + + case Look is + + when '+' | '-' => + Pic.Sign_Position := Index; + Skip; + return; + + when 'C' | 'c' => + Pic.Sign_Position := Index; + Pic.Picture.Expanded (Index) := 'C'; + Skip; + + if Look = 'R' or Look = 'r' then + Pic.Second_Sign := Index; + Pic.Picture.Expanded (Index) := 'R'; + Skip; + + else + raise Picture_Error; + end if; + + return; + + when 'D' | 'd' => + Pic.Sign_Position := Index; + Pic.Picture.Expanded (Index) := 'D'; + Skip; + + if Look = 'B' or Look = 'b' then + Pic.Second_Sign := Index; + Pic.Picture.Expanded (Index) := 'B'; + Skip; + + else + raise Picture_Error; + end if; + + return; + + when '>' => + if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then + Pic.Second_Sign := Index; + Skip; + + else + raise Picture_Error; + end if; + + when others => + return; + + end case; + end Optional_RHS_Sign; + + ------------- + -- Picture -- + ------------- + + -- Note that Picture can be called in either State. + + -- It will set state to Valid only if a 9 is encountered or floating + -- currency is called. + + procedure Picture is + begin + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Leading_Dollar; + return; + + when '#' => + Leading_Pound; + return; + + when '9' => + Computed_BWZ := False; + Set_State (Okay); + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Skip; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + Trailing_Currency; + return; + + when others => + return; + + end case; + end loop; + end Picture; + + --------------------- + -- Picture_Bracket -- + --------------------- + + procedure Picture_Bracket is + begin + Pic.Sign_Position := Index; + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise. + + Pic.Floater := '<'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Bracket + + loop + case Look is + + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Set_State (Okay); -- "<<>" is enough. + Floating_Bracket; + Trailing_Currency; + Trailing_Bracket; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Trailing_Bracket; + Set_State (Okay); + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + Trailing_Bracket; + return; + + when others => + raise Picture_Error; + + end case; + end loop; + end Picture_Bracket; + + ------------------- + -- Picture_Minus -- + ------------------- + + procedure Picture_Minus is + begin + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise. + + Pic.Floater := '-'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Minus + + loop + case Look is + + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '-' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + Set_State (Okay); -- "-- " is enough. + Floating_Minus; + Trailing_Currency; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Set_State (Okay); + return; + + when 'Z' | 'z' => + + -- Can't have Z and a floating sign. + + if State = Okay then + Set_State (Reject); + end if; + + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit. + + Picture; + return; + + when others => + return; + + end case; + end loop; + end Picture_Minus; + + ------------------ + -- Picture_Plus -- + ------------------ + + procedure Picture_Plus is + begin + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise. + + Pic.Floater := '+'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Plus + + loop + case Look is + + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '+' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + Set_State (Okay); -- "++" is enough. + Floating_Plus; + Trailing_Currency; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Set_State (Okay); + return; + + when 'Z' | 'z' => + if State = Okay then + Set_State (Reject); + end if; + + -- Can't have Z and a floating sign. + + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + -- '+Z' is acceptable + + Set_State (Okay); + + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit. + + Picture; + return; + + when others => + return; + + end case; + end loop; + end Picture_Plus; + + -------------------- + -- Picture_String -- + -------------------- + + procedure Picture_String is + begin + while Is_Insert loop + Skip; + end loop; + + case Look is + + when '$' | '#' => + Picture; + Optional_RHS_Sign; + + when '+' => + Picture_Plus; + + when '-' => + Picture_Minus; + + when '<' => + Picture_Bracket; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + + when '*' => + Star_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + + when '9' | '.' | 'V' | 'v' => + Number; + Trailing_Currency; + Optional_RHS_Sign; + + when others => + raise Picture_Error; + + end case; + + -- Blank when zero either if the PIC does not contain a '9' or if + -- requested by the user and no '*' + + Pic.Blank_When_Zero := + (Computed_BWZ or Pic.Blank_When_Zero) and not Pic.Star_Fill; + + -- Star fill if '*' and no '9'. + + Pic.Star_Fill := Pic.Star_Fill and Computed_BWZ; + + if not At_End then + Set_State (Reject); + end if; + + end Picture_String; + + --------------- + -- Set_State -- + --------------- + + procedure Set_State (L : Legality) is + begin + State := L; + end Set_State; + + ---------- + -- Skip -- + ---------- + + procedure Skip is + begin + Index := Index + 1; + end Skip; + + ---------------------- + -- Star_Suppression -- + ---------------------- + + procedure Star_Suppression is + begin + Pic.Floater := '*'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + + -- Even a single * is a valid picture + + Pic.Star_Fill := True; + Skip; -- Known * + + loop + if At_End then + return; + end if; + + case Look is + + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); Skip; + + when '9' => + Set_State (Okay); + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Star_Fill; + return; + + when '#' | '$' => + Trailing_Currency; + Set_State (Okay); + return; + + when others => raise Picture_Error; + end case; + end loop; + end Star_Suppression; + + ---------------------- + -- Trailing_Bracket -- + ---------------------- + + procedure Trailing_Bracket is + begin + if Look = '>' then + Pic.Second_Sign := Index; + Skip; + else + raise Picture_Error; + end if; + end Trailing_Bracket; + + ----------------------- + -- Trailing_Currency -- + ----------------------- + + procedure Trailing_Currency is + begin + if At_End then + return; + end if; + + if Look = '$' then + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Skip; + + else + while not At_End and then Look = '#' loop + if Pic.Start_Currency = Invalid_Position then + Pic.Start_Currency := Index; + end if; + + Pic.End_Currency := Index; + Skip; + end loop; + end if; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => return; + end case; + end loop; + end Trailing_Currency; + + ---------------------- + -- Zero_Suppression -- + ---------------------- + + procedure Zero_Suppression is + begin + Pic.Floater := 'Z'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Skip; -- Known Z + + loop + -- Even a single Z is a valid picture + + if At_End then + Set_State (Okay); + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Set_State (Okay); + Skip; + + when '9' => + Set_State (Okay); + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Z_Fill; + return; + + when '#' | '$' => + Trailing_Currency; + Set_State (Okay); + return; + + when others => + return; + end case; + end loop; + end Zero_Suppression; + + -- Start of processing for Precalculate + + begin + Picture_String; + + if State = Reject then + raise Picture_Error; + end if; + + exception + + when Constraint_Error => + + -- To deal with special cases like null strings. + + raise Picture_Error; + + end Precalculate; + + ---------------- + -- To_Picture -- + ---------------- + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture + is + Result : Picture; + + begin + declare + Item : constant String := Expand (Pic_String); + + begin + Result.Contents.Picture := (Item'Length, Item); + Result.Contents.Original_BWZ := Blank_When_Zero; + Result.Contents.Blank_When_Zero := Blank_When_Zero; + Precalculate (Result.Contents); + return Result; + end; + + exception + when others => + raise Picture_Error; + + end To_Picture; + + ------------- + -- To_Wide -- + ------------- + + function To_Wide (C : Character) return Wide_Wide_Character is + begin + return Wide_Wide_Character'Val (Character'Pos (C)); + end To_Wide; + + ----------- + -- Valid -- + ----------- + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean + is + begin + declare + Expanded_Pic : constant String := Expand (Pic_String); + -- Raises Picture_Error if Item not well-formed + + Format_Rec : Format_Record; + + begin + Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); + Format_Rec.Blank_When_Zero := Blank_When_Zero; + Format_Rec.Original_BWZ := Blank_When_Zero; + Precalculate (Format_Rec); + + -- False only if Blank_When_0 is True but the pic string + -- has a '*' + + return not Blank_When_Zero or + Strings_Fixed.Index (Expanded_Pic, "*") = 0; + end; + + exception + when others => return False; + end Valid; + +end Ada.Wide_Wide_Text_IO.Editing; diff --git a/gcc/ada/a-ztedit.ads b/gcc/ada/a-ztedit.ads new file mode 100644 index 00000000000..081b99b24dd --- /dev/null +++ b/gcc/ada/a-ztedit.ads @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Wide_Text_IO.Editing is + + type Picture is private; + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean; + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture; + + function Pic_String (Pic : in Picture) return String; + function Blank_When_Zero (Pic : in Picture) return Boolean; + + Max_Picture_Length : constant := 64; + + Picture_Error : exception; + + Default_Currency : constant Wide_Wide_String := "$"; + Default_Fill : constant Wide_Wide_Character := ' '; + Default_Separator : constant Wide_Wide_Character := ','; + Default_Radix_Mark : constant Wide_Wide_Character := '.'; + + generic + type Num is delta <> digits <>; + Default_Currency : Wide_Wide_String := + Wide_Wide_Text_IO.Editing.Default_Currency; + Default_Fill : Wide_Wide_Character := + Wide_Wide_Text_IO.Editing.Default_Fill; + Default_Separator : Wide_Wide_Character := + Wide_Wide_Text_IO.Editing.Default_Separator; + Default_Radix_Mark : Wide_Wide_Character := + Wide_Wide_Text_IO.Editing.Default_Radix_Mark; + + package Decimal_Output is + + function Length + (Pic : Picture; + Currency : Wide_Wide_String := Default_Currency) return Natural; + + function Valid + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency) return Boolean; + + function Image + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + return Wide_Wide_String; + + procedure Put + (File : File_Type; + Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); + + procedure Put + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); + + end Decimal_Output; + +private + MAX_PICSIZE : constant := 50; + MAX_MONEYSIZE : constant := 10; + Invalid_Position : constant := -1; + + subtype Pic_Index is Natural range 0 .. MAX_PICSIZE; + + type Picture_Record (Length : Pic_Index := 0) is record + Expanded : String (1 .. Length); + end record; + + type Format_Record is record + Picture : Picture_Record; + -- Read only + + Blank_When_Zero : Boolean; + -- Read/write + + Original_BWZ : Boolean; + + -- The following components get written + + Star_Fill : Boolean := False; + + Radix_Position : Integer := Invalid_Position; + + Sign_Position, + Second_Sign : Integer := Invalid_Position; + + Start_Float, + End_Float : Integer := Invalid_Position; + + Start_Currency, + End_Currency : Integer := Invalid_Position; + + Max_Leading_Digits : Integer := 0; + + Max_Trailing_Digits : Integer := 0; + + Max_Currency_Digits : Integer := 0; + + Floater : Wide_Wide_Character := '!'; + -- Initialized to illegal value + + end record; + + type Picture is record + Contents : Format_Record; + end record; + + type Number_Attributes is record + Negative : Boolean := False; + + Has_Fraction : Boolean := False; + + Start_Of_Int, + End_Of_Int, + Start_Of_Fraction, + End_Of_Fraction : Integer := Invalid_Position; -- invalid value + end record; + + function Parse_Number_String (Str : String) return Number_Attributes; + -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no + -- trailing blanks...) + + procedure Precalculate (Pic : in out Format_Record); + -- Precalculates fields from the user supplied data + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : Wide_Wide_String; + Fill_Character : Wide_Wide_Character; + Separator_Character : Wide_Wide_Character; + Radix_Point : Wide_Wide_Character) return Wide_Wide_String; + -- Formats number according to Pic + + function Expand (Picture : in String) return String; + +end Ada.Wide_Wide_Text_IO.Editing; diff --git a/gcc/ada/a-ztenau.adb b/gcc/ada/a-ztenau.adb new file mode 100644 index 00000000000..d9ece2b6169 --- /dev/null +++ b/gcc/ada/a-ztenau.adb @@ -0,0 +1,354 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X-- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.WCh_Con; use System.WCh_Con; + +package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Store_Char + (WC : Wide_Wide_Character; + Buf : out Wide_Wide_String; + Ptr : in out Integer); + -- Store a single character in buffer, checking for overflow. + + -- These definitions replace the ones in Ada.Characters.Handling, which + -- do not seem to work for some strange not understood reason ??? at + -- least in the OS/2 version. + + function To_Lower (C : Character) return Character; + + ------------------ + -- Get_Enum_Lit -- + ------------------ + + procedure Get_Enum_Lit + (File : File_Type; + Buf : out Wide_Wide_String; + Buflen : out Natural) + is + ch : int; + WC : Wide_Wide_Character; + + begin + Buflen := 0; + Load_Skip (TFT (File)); + ch := Nextc (TFT (File)); + + -- Character literal case. If the initial character is a quote, then + -- we read as far as we can without backup (see ACVC test CE3905L) + + if ch = Character'Pos (''') then + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + if ch = LM or else ch = EOF then + return; + end if; + + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + if ch /= Character'Pos (''') then + return; + end if; + + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + -- Similarly for identifiers, read as far as we can, in particular, + -- do read a trailing underscore (again see ACVC test CE3905L to + -- understand why we do this, although it seems somewhat peculiar). + + else + -- Identifier must start with a letter. Any wide character value + -- outside the normal Latin-1 range counts as a letter for this. + + if ch < 255 and then not Is_Letter (Character'Val (ch)) then + return; + end if; + + -- If we do have a letter, loop through the characters quitting on + -- the first non-identifier character (note that this includes the + -- cases of hitting a line mark or page mark). + + loop + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + exit when ch = EOF; + + if ch = Character'Pos ('_') then + exit when Buf (Buflen) = '_'; + + elsif ch = Character'Pos (ASCII.ESC) then + null; + + elsif File.WC_Method in WC_Upper_Half_Encoding_Method + and then ch > 127 + then + null; + + else + exit when not Is_Letter (Character'Val (ch)) + and then + not Is_Digit (Character'Val (ch)); + end if; + end loop; + end if; + end Get_Enum_Lit; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_String; + Width : Field; + Set : Type_Set) + is + Actual_Width : constant Integer := + Integer'Max (Integer (Width), Item'Length); + + begin + Check_On_One_Line (TFT (File), Actual_Width); + + if Set = Lower_Case and then Item (1) /= ''' then + declare + Iteml : Wide_Wide_String (Item'First .. Item'Last); + + begin + for J in Item'Range loop + if Is_Character (Item (J)) then + Iteml (J) := + To_Wide_Wide_Character + (To_Lower (To_Character (Item (J)))); + else + Iteml (J) := Item (J); + end if; + end loop; + + Put (File, Iteml); + end; + + else + Put (File, Item); + end if; + + for J in 1 .. Actual_Width - Item'Length loop + Put (File, ' '); + end loop; + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out Wide_Wide_String; + Item : Wide_Wide_String; + Set : Type_Set) + is + Ptr : Natural; + + begin + if Item'Length > To'Length then + raise Layout_Error; + + else + Ptr := To'First; + for J in Item'Range loop + if Set = Lower_Case + and then Item (1) /= ''' + and then Is_Character (Item (J)) + then + To (Ptr) := + To_Wide_Wide_Character (To_Lower (To_Character (Item (J)))); + else + To (Ptr) := Item (J); + end if; + + Ptr := Ptr + 1; + end loop; + + while Ptr <= To'Last loop + To (Ptr) := ' '; + Ptr := Ptr + 1; + end loop; + end if; + end Puts; + + ------------------- + -- Scan_Enum_Lit -- + ------------------- + + procedure Scan_Enum_Lit + (From : Wide_Wide_String; + Start : out Natural; + Stop : out Natural) + is + WC : Wide_Wide_Character; + + -- Processing for Scan_Enum_Lit + + begin + Start := From'First; + + loop + if Start > From'Last then + raise End_Error; + + elsif Is_Character (From (Start)) + and then not Is_Blank (To_Character (From (Start))) + then + exit; + + else + Start := Start + 1; + end if; + end loop; + + -- Character literal case. If the initial character is a quote, then + -- we read as far as we can without backup (see ACVC test CE3905L + -- which is for the analogous case for reading from a file). + + if From (Start) = ''' then + Stop := Start; + + if Stop = From'Last then + raise Data_Error; + else + Stop := Stop + 1; + end if; + + if From (Stop) in ' ' .. '~' + or else From (Stop) >= Wide_Wide_Character'Val (16#80#) + then + if Stop = From'Last then + raise Data_Error; + else + Stop := Stop + 1; + + if From (Stop) = ''' then + return; + end if; + end if; + end if; + + raise Data_Error; + + -- Similarly for identifiers, read as far as we can, in particular, + -- do read a trailing underscore (again see ACVC test CE3905L to + -- understand why we do this, although it seems somewhat peculiar). + + else + -- Identifier must start with a letter, any wide character outside + -- the normal Latin-1 range is considered a letter for this test. + + if Is_Character (From (Start)) + and then not Is_Letter (To_Character (From (Start))) + then + raise Data_Error; + end if; + + -- If we do have a letter, loop through the characters quitting on + -- the first non-identifier character (note that this includes the + -- cases of hitting a line mark or page mark). + + Stop := Start + 1; + while Stop < From'Last loop + WC := From (Stop + 1); + + exit when + Is_Character (WC) + and then + not Is_Letter (To_Character (WC)) + and then + not Is_Letter (To_Character (WC)) + and then + (WC /= '_' or else From (Stop - 1) = '_'); + + Stop := Stop + 1; + end loop; + end if; + + end Scan_Enum_Lit; + + ---------------- + -- Store_Char -- + ---------------- + + procedure Store_Char + (WC : Wide_Wide_Character; + Buf : out Wide_Wide_String; + Ptr : in out Integer) + is + begin + if Ptr = Buf'Last then + raise Data_Error; + else + Ptr := Ptr + 1; + Buf (Ptr) := WC; + end if; + end Store_Char; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (C : Character) return Character is + begin + if C in 'A' .. 'Z' then + return Character'Val (Character'Pos (C) + 32); + else + return C; + end if; + end To_Lower; + +end Ada.Wide_Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-ztenau.ads b/gcc/ada/a-ztenau.ads new file mode 100644 index 00000000000..0b3f4b49ba2 --- /dev/null +++ b/gcc/ada/a-ztenau.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X-- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Enumeration_IO +-- that are shared among separate instantiations. + +private package Ada.Wide_Wide_Text_IO.Enumeration_Aux is + + procedure Get_Enum_Lit + (File : File_Type; + Buf : out Wide_Wide_String; + Buflen : out Natural); + -- Reads an enumeration literal value from the file, folds to upper case, + -- and stores the result in Buf, setting Buflen to the number of stored + -- characters (Buf has a lower bound of 1). If more than Buflen characters + -- are present in the literal, Data_Error is raised. + + procedure Scan_Enum_Lit + (From : Wide_Wide_String; + Start : out Natural; + Stop : out Natural); + -- Scans an enumeration literal at the start of From, skipping any leading + -- spaces. Sets Start to the first character, Stop to the last character. + -- Raises End_Error if no enumeration literal is found. + + procedure Put + (File : File_Type; + Item : Wide_Wide_String; + Width : Field; + Set : Type_Set); + -- Outputs the enumeration literal image stored in Item to the given File, + -- using the given Width and Set parameters (Item is always in upper case). + + procedure Puts + (To : out Wide_Wide_String; + Item : Wide_Wide_String; + Set : Type_Set); + -- Stores the enumeration literal image stored in Item to the string To, + -- padding with trailing spaces if necessary to fill To. Set is used to + +end Ada.Wide_Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-ztenio.adb b/gcc/ada/a-ztenio.adb new file mode 100644 index 00000000000..6ab2a192490 --- /dev/null +++ b/gcc/ada/a-ztenio.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005, 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Enumeration_Aux; + +package body Ada.Wide_Wide_Text_IO.Enumeration_IO is + + package Aux renames Ada.Wide_Wide_Text_IO.Enumeration_Aux; + + --------- + -- Get -- + --------- + + procedure Get (File : File_Type; Item : out Enum) is + Buf : Wide_Wide_String (1 .. Enum'Width); + Buflen : Natural; + + begin + Aux.Get_Enum_Lit (File, Buf, Buflen); + Item := Enum'Wide_Wide_Value (Buf (1 .. Buflen)); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get (Item : out Enum) is + begin + Get (Current_Input, Item); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Enum; + Last : out Positive) + is + Start : Natural; + + begin + Aux.Scan_Enum_Lit (From, Start, Last); + Item := Enum'Wide_Wide_Value (From (Start .. Last)); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); + + begin + Aux.Put (File, Image, Width, Set); + end Put; + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + begin + Put (Current_Output, Item, Width, Set); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); + + begin + Aux.Puts (To, Image, Set); + end Put; + +end Ada.Wide_Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-ztenio.ads b/gcc/ada/a-ztenio.ads new file mode 100644 index 00000000000..7c06401b195 --- /dev/null +++ b/gcc/ada/a-ztenio.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Enumeration_IO is a +-- subpackage of Wide_Wide_Text_IO. In GNAT we make it a child package to +-- avoid loading the necessary code if Enumeration_IO is not instantiated. +-- See the routine Rtsfind.Text_IO_Kludge for a description of how we patch +-- up the difference in semantics so that it is invisible to the Ada +-- programmer. + +private generic + type Enum is (<>); + +package Ada.Wide_Wide_Text_IO.Enumeration_IO is + + Default_Width : Field := 0; + Default_Setting : Type_Set := Upper_Case; + + procedure Get (File : File_Type; Item : out Enum); + procedure Get (Item : out Enum); + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Get + (From : Wide_Wide_String; + Item : out Enum; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting); + +end Ada.Wide_Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb new file mode 100644 index 00000000000..25a7cead096 --- /dev/null +++ b/gcc/ada/a-ztexio.adb @@ -0,0 +1,1898 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Streams; use Ada.Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System; +with System.CRTL; +with System.File_IO; +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +with Unchecked_Conversion; +with Unchecked_Deallocation; + +pragma Elaborate_All (System.File_IO); +-- Needed because of calls to Chain_File in package body elaboration + +package body Ada.Wide_Wide_Text_IO is + + package FIO renames System.File_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_TIO is new Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type FCB.File_Mode; + + use type System.CRTL.size_t; + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + function Get_Wide_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Wide_Character; + -- This routine is identical to Get_Wide_Wide_Char, except that the reads + -- are done in Get_Immediate mode (i.e. without waiting for a line return). + + procedure Set_WCEM (File : in out File_Type); + -- Called by Open and Create to set the wide character encoding method + -- for the file, processing a WCEM form parameter if one is present. + -- File is IN OUT because it may be closed in case of an error. + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate + (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr + is + pragma Unreferenced (Control_Block); + begin + return new Wide_Wide_Text_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + procedure AFCB_Close (File : access Wide_Wide_Text_AFCB) is + begin + -- If the file being closed is one of the current files, then close + -- the corresponding current file. It is not clear that this action + -- is required (RM A.10.3(23)) but it seems reasonable, and besides + -- ACVC test CE3208A expects this behavior. + + if File_Type (File) = Current_In then + Current_In := null; + elsif File_Type (File) = Current_Out then + Current_Out := null; + elsif File_Type (File) = Current_Err then + Current_Err := null; + end if; + + Terminate_Line (File_Type (File)); + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : access Wide_Wide_Text_AFCB) is + type FCB_Ptr is access all Wide_Wide_Text_AFCB; + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new + Unchecked_Deallocation (Wide_Wide_Text_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)); + end Close; + + --------- + -- Col -- + --------- + + -- Note: we assume that it is impossible in practice for the column + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Col (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Col; + end Col; + + function Col return Positive_Count is + begin + return Col (Current_Out); + end Col; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => True, + Text => True); + Set_WCEM (File); + end Create; + + ------------------- + -- Current_Error -- + ------------------- + + function Current_Error return File_Type is + begin + return Current_Err; + end Current_Error; + + function Current_Error return File_Access is + begin + return Current_Err'Access; + end Current_Error; + + ------------------- + -- Current_Input -- + ------------------- + + function Current_Input return File_Type is + begin + return Current_In; + end Current_Input; + + function Current_Input return File_Access is + begin + return Current_In'Access; + end Current_Input; + + -------------------- + -- Current_Output -- + -------------------- + + function Current_Output return File_Type is + begin + return Current_Out; + end Current_Output; + + function Current_Output return File_Access is + begin + return Current_Out'Access; + end Current_Output; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + + if File.Before_LM_PM then + return Nextc (File) = EOF; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch = PM and then File.Is_Regular_File then + File.Before_LM_PM := True; + return Nextc (File) = EOF; + + -- Here if neither EOF nor PM followed end of line + + else + Ungetc (ch, File); + return False; + end if; + + end End_Of_File; + + function End_Of_File return Boolean is + begin + return End_Of_File (Current_In); + end End_Of_File; + + ----------------- + -- End_Of_Line -- + ----------------- + + function End_Of_Line (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + return True; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + else + Ungetc (ch, File); + return (ch = LM); + end if; + end if; + end End_Of_Line; + + function End_Of_Line return Boolean is + begin + return End_Of_Line (Current_In); + end End_Of_Line; + + ----------------- + -- End_Of_Page -- + ----------------- + + function End_Of_Page (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if not File.Is_Regular_File then + return False; + + elsif File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return True; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Nextc (File); + + return ch = PM or else ch = EOF; + end End_Of_Page; + + function End_Of_Page return Boolean is + begin + return End_Of_Page (Current_In); + end End_Of_Page; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + procedure Flush is + begin + Flush (Current_Out); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Wide_Wide_Character) + is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + else + Get_Character (File, C); + Item := Get_Wide_Wide_Char (C, File); + end if; + end Get; + + procedure Get (Item : out Wide_Wide_Character) is + begin + Get (Current_In, Item); + end Get; + + procedure Get + (File : File_Type; + Item : out Wide_Wide_String) + is + begin + for J in Item'Range loop + Get (File, Item (J)); + end loop; + end Get; + + procedure Get (Item : out Wide_Wide_String) is + begin + Get (Current_In, Item); + end Get; + + ------------------- + -- Get_Character -- + ------------------- + + procedure Get_Character + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + + else + File.Line := File.Line + 1; + end if; + end if; + + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item := Character'Val (ch); + File.Col := File.Col + 1; + return; + end if; + end loop; + end Get_Character; + + ------------------- + -- Get_Immediate -- + ------------------- + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Wide_Character'Val (LM); + + else + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Wide_Character) + is + begin + Get_Immediate (Current_In, Item); + end Get_Immediate; + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character; + Available : out Boolean) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + Available := True; + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Wide_Character'Val (LM); + + else + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Wide_Character; + Available : out Boolean) + is + begin + Get_Immediate (Current_In, Item, Available); + end Get_Immediate; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_String; + Last : out Natural) + is + begin + FIO.Check_Read_Status (AP (File)); + Last := Item'First - 1; + + -- Immediate exit for null string, this is a case in which we do not + -- need to test for end of file and we do not skip a line mark under + -- any circumstances. + + if Last >= Item'Last then + return; + end if; + + -- Here we have at least one character, if we are immediately before + -- a line mark, then we will just skip past it storing no characters. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + -- Otherwise we need to read some characters + + else + -- If we are at the end of file now, it means we are trying to + -- skip a file terminator and we raise End_Error (RM A.10.7(20)) + + if Nextc (File) = EOF then + raise End_Error; + end if; + + -- Loop through characters in string + + loop + -- Exit the loop if read is terminated by encountering line mark + -- Note that the use of Skip_Line here ensures we properly deal + -- with setting the page and line numbers. + + if End_Of_Line (File) then + Skip_Line (File); + return; + end if; + + -- Otherwise store the character, note that we know that ch is + -- something other than LM or EOF. It could possibly be a page + -- mark if there is a stray page mark in the middle of a line, + -- but this is not an official page mark in any case, since + -- official page marks can only follow a line mark. The whole + -- page business is pretty much nonsense anyway, so we do not + -- want to waste time trying to make sense out of non-standard + -- page marks in the file! This means that the behavior of + -- Get_Line is different from repeated Get of a character, but + -- that's too bad. We only promise that page numbers etc make + -- sense if the file is formatted in a standard manner. + + -- Note: we do not adjust the column number because it is quicker + -- to adjust it once at the end of the operation than incrementing + -- it each time around the loop. + + Last := Last + 1; + Get (File, Item (Last)); + + -- All done if the string is full, this is the case in which + -- we do not skip the following line mark. We need to adjust + -- the column number in this case. + + if Last = Item'Last then + File.Col := File.Col + Count (Item'Length); + return; + end if; + + -- Exit from the loop if we are at the end of file. This happens + -- if we have a last line that is not terminated with a line mark. + -- In this case we consider that there is an implied line mark; + -- this is a non-standard file, but we will treat it nicely. + + exit when Nextc (File) = EOF; + end loop; + end if; + end Get_Line; + + procedure Get_Line + (Item : out Wide_Wide_String; + Last : out Natural) + is + begin + Get_Line (Current_In, Item, Last); + end Get_Line; + + function Get_Line (File : File_Type) return Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 500); + Last : Natural; + + function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String; + -- This is a recursive function that reads the rest of the line and + -- returns it. S is the part read so far. + + -------------- + -- Get_Rest -- + -------------- + + function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String is + + -- Each time we allocate a buffer the same size as what we have + -- read so far. This limits us to a logarithmic number of calls + -- to Get_Rest and also ensures only a linear use of stack space. + + Buffer : Wide_Wide_String (1 .. S'Length); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + + declare + R : constant Wide_Wide_String := S & Buffer (1 .. Last); + begin + if Last < Buffer'Last then + return R; + else + return Get_Rest (R); + end if; + end; + end Get_Rest; + + -- Start of processing for Get_Line + + begin + Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Get_Rest (Buffer (1 .. Last)); + end if; + end Get_Line; + + function Get_Line return Wide_Wide_String is + begin + return Get_Line (Current_In); + end Get_Line; + + ------------------------ + -- Get_Wide_Wide_Char -- + ------------------------ + + function Get_Wide_Wide_Char + (C : Character; + File : File_Type) return Wide_Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_UTF_32 (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Wide_Char + + begin + return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); + end Get_Wide_Wide_Char; + + ------------------------------ + -- Get_Wide_Wide_Char_Immed -- + ------------------------------ + + function Get_Wide_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_UTF_32 (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc_Immed (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Wide_Char_Immed + + begin + return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); + end Get_Wide_Wide_Char_Immed; + + ---------- + -- Getc -- + ---------- + + function Getc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF and then ferror (File.Stream) /= 0 then + raise Device_Error; + else + return ch; + end if; + end Getc; + + ---------------- + -- Getc_Immed -- + ---------------- + + function Getc_Immed (File : File_Type) return int is + ch : int; + end_of_file : int; + + procedure getc_immediate + (stream : FILEs; ch : out int; end_of_file : out int); + pragma Import (C, getc_immediate, "getc_immediate"); + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := LM; + + else + getc_immediate (File.Stream, ch, end_of_file); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + elsif end_of_file /= 0 then + return EOF; + end if; + end if; + + return ch; + end Getc_Immed; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Line -- + ---------- + + -- Note: we assume that it is impossible in practice for the line + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Line (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Line; + end Line; + + function Line return Positive_Count is + begin + return Line (Current_Out); + end Line; + + ----------------- + -- Line_Length -- + ----------------- + + function Line_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Line_Length; + end Line_Length; + + function Line_Length return Count is + begin + return Line_Length (Current_Out); + end Line_Length; + + ---------------- + -- Look_Ahead -- + ---------------- + + procedure Look_Ahead + (File : File_Type; + Item : out Wide_Wide_Character; + End_Of_Line : out Boolean) + is + ch : int; + + -- Start of processing for Look_Ahead + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are logically before a line mark, we can return immediately + + if File.Before_LM then + End_Of_Line := True; + Item := Wide_Wide_Character'Val (0); + + -- If we are before a wide character, just return it (this happens + -- if there are two calls to Look_Ahead in a row). + + elsif File.Before_Wide_Wide_Character then + End_Of_Line := False; + Item := File.Saved_Wide_Wide_Character; + + -- otherwise we must read a character from the input stream + + else + ch := Getc (File); + + if ch = LM + or else ch = EOF + or else (ch = EOF and then File.Is_Regular_File) + then + End_Of_Line := True; + Ungetc (ch, File); + Item := Wide_Wide_Character'Val (0); + + -- If the character is in the range 16#0000# to 16#007F# it stands + -- for itself and occupies a single byte, so we can unget it with + -- no difficulty. + + elsif ch <= 16#0080# then + End_Of_Line := False; + Ungetc (ch, File); + Item := Wide_Wide_Character'Val (ch); + + -- For a character above this range, we read the character, using + -- the Get_Wide_Wide_Char routine. It may well occupy more than one + -- byte so we can't put it back with ungetc. Instead we save it in + -- the control block, setting a flag that everyone interested in + -- reading characters must test before reading the stream. + + else + Item := Get_Wide_Wide_Char (Character'Val (ch), File); + End_Of_Line := False; + File.Saved_Wide_Wide_Character := Item; + File.Before_Wide_Wide_Character := True; + end if; + end if; + end Look_Ahead; + + procedure Look_Ahead + (Item : out Wide_Wide_Character; + End_Of_Line : out Boolean) + is + begin + Look_Ahead (Current_In, Item, End_Of_Line); + end Look_Ahead; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_TIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if Spacing not in Positive_Count then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + + for K in 1 .. Spacing loop + Putc (LM, File); + File.Line := File.Line + 1; + + if File.Page_Length /= 0 + and then File.Line > File.Page_Length + then + Putc (PM, File); + File.Line := 1; + File.Page := File.Page + 1; + end if; + end loop; + + File.Col := 1; + end New_Line; + + procedure New_Line (Spacing : Positive_Count := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + -------------- + -- New_Page -- + -------------- + + procedure New_Page (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Col /= 1 or else File.Line = 1 then + Putc (LM, File); + end if; + + Putc (PM, File); + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + end New_Page; + + procedure New_Page is + begin + New_Page (Current_Out); + end New_Page; + + ----------- + -- Nextc -- + ----------- + + function Nextc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + + else + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + + return ch; + end Nextc; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => False, + Text => True); + Set_WCEM (File); + end Open; + + ---------- + -- Page -- + ---------- + + -- Note: we assume that it is impossible in practice for the page + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Page (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Page; + end Page; + + function Page return Positive_Count is + begin + return Page (Current_Out); + end Page; + + ----------------- + -- Page_Length -- + ----------------- + + function Page_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Page_Length; + end Page_Length; + + function Page_Length return Count is + begin + return Page_Length (Current_Out); + end Page_Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_Character) + is + procedure Out_Char (C : Character); + -- Procedure to output one character of a wide character sequence + + procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char); + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + Putc (Character'Pos (C), File); + end Out_Char; + + -- Start of processing for Put + + begin + WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method); + File.Col := File.Col + 1; + end Put; + + procedure Put (Item : Wide_Wide_Character) is + begin + Put (Current_Out, Item); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_String) + is + begin + for J in Item'Range loop + Put (File, Item (J)); + end loop; + end Put; + + procedure Put (Item : Wide_Wide_String) is + begin + Put (Current_Out, Item); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_String) + is + begin + Put (File, Item); + New_Line (File); + end Put_Line; + + procedure Put_Line (Item : Wide_Wide_String) is + begin + Put (Current_Out, Item); + New_Line (Current_Out); + end Put_Line; + + ---------- + -- Putc -- + ---------- + + procedure Putc (ch : int; File : File_Type) is + begin + if fputc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end Putc; + + ---------- + -- Read -- + ---------- + + -- This is the primitive Stream Read routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Read + (File : in out Wide_Wide_Text_AFCB; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Discard_ch : int; + pragma Unreferenced (Discard_ch); + + begin + -- Need to deal with Before_Wide_Wide_Character ??? + + if File.Mode /= FCB.In_File then + raise Mode_Error; + end if; + + -- Deal with case where our logical and physical position do not match + -- because of being after an LM or LM-PM sequence when in fact we are + -- logically positioned before it. + + if File.Before_LM then + + -- If we are before a PM, then it is possible for a stream read + -- to leave us after the LM and before the PM, which is a bit + -- odd. The easiest way to deal with this is to unget the PM, + -- so we are indeed positioned between the characters. This way + -- further stream read operations will work correctly, and the + -- effect on text processing is a little weird, but what can + -- be expected if stream and text input are mixed this way? + + if File.Before_LM_PM then + Discard_ch := ungetc (PM, File.Stream); + File.Before_LM_PM := False; + end if; + + File.Before_LM := False; + + Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); + + if Item'Length = 1 then + Last := Item'Last; + + else + Last := + Item'First + + Stream_Element_Offset + (fread (buffer => Item'Address, + index => size_t (Item'First + 1), + size => 1, + count => Item'Length - 1, + stream => File.Stream)); + end if; + + return; + end if; + + -- Now we do the read. Since this is a text file, it is normally in + -- text mode, but stream data must be read in binary mode, so we + -- temporarily set binary mode for the read, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + Last := + Item'First + + Stream_Element_Offset + (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; + + if Last < Item'Last then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + end if; + + set_text_mode (fileno (File.Stream)); + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset + (File : in out File_Type; + Mode : File_Mode) + is + begin + -- Don't allow change of mode for current file (RM A.10.2(5)) + + if (File = Current_In or else + File = Current_Out or else + File = Current_Error) + and then To_FCB (Mode) /= File.Mode + then + raise Mode_Error; + end if; + + Terminate_Line (File); + FIO.Reset (AP (File), To_FCB (Mode)); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Terminate_Line (File); + FIO.Reset (AP (File)); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + ------------- + -- Set_Col -- + ------------- + + procedure Set_Col + (File : File_Type; + To : Positive_Count) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if To not in Positive_Count then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Col then + return; + end if; + + if Mode (File) >= Out_File then + if File.Line_Length /= 0 and then To > File.Line_Length then + raise Layout_Error; + end if; + + if To < File.Col then + New_Line (File); + end if; + + while File.Col < To loop + Put (File, ' '); + end loop; + + else + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + + elsif To = File.Col then + Ungetc (ch, File); + return; + + else + File.Col := File.Col + 1; + end if; + end loop; + end if; + end Set_Col; + + procedure Set_Col (To : Positive_Count) is + begin + Set_Col (Current_Out, To); + end Set_Col; + + --------------- + -- Set_Error -- + --------------- + + procedure Set_Error (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Err := File; + end Set_Error; + + --------------- + -- Set_Input -- + --------------- + + procedure Set_Input (File : File_Type) is + begin + FIO.Check_Read_Status (AP (File)); + Current_In := File; + end Set_Input; + + -------------- + -- Set_Line -- + -------------- + + procedure Set_Line + (File : File_Type; + To : Positive_Count) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if To not in Positive_Count then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Line then + return; + end if; + + if Mode (File) >= Out_File then + if File.Page_Length /= 0 and then To > File.Page_Length then + raise Layout_Error; + end if; + + if To < File.Line then + New_Page (File); + end if; + + while File.Line < To loop + New_Line (File); + end loop; + + else + while To /= File.Line loop + Skip_Line (File); + end loop; + end if; + end Set_Line; + + procedure Set_Line (To : Positive_Count) is + begin + Set_Line (Current_Out, To); + end Set_Line; + + --------------------- + -- Set_Line_Length -- + --------------------- + + procedure Set_Line_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if To not in Count then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Line_Length := To; + end Set_Line_Length; + + procedure Set_Line_Length (To : Count) is + begin + Set_Line_Length (Current_Out, To); + end Set_Line_Length; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Out := File; + end Set_Output; + + --------------------- + -- Set_Page_Length -- + --------------------- + + procedure Set_Page_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if To not in Count then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Page_Length := To; + end Set_Page_Length; + + procedure Set_Page_Length (To : Count) is + begin + Set_Page_Length (Current_Out, To); + end Set_Page_Length; + + -------------- + -- Set_WCEM -- + -------------- + + procedure Set_WCEM (File : in out File_Type) is + Start : Natural; + Stop : Natural; + + begin + File.WC_Method := WCEM_Brackets; + FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); + + if Start = 0 then + File.WC_Method := WCEM_Brackets; + + elsif Start /= 0 then + if Stop = Start then + for J in WC_Encoding_Letters'Range loop + if File.Form (Start) = WC_Encoding_Letters (J) then + File.WC_Method := J; + return; + end if; + end loop; + end if; + + Close (File); + Raise_Exception (Use_Error'Identity, "invalid WCEM form parameter"); + end if; + end Set_WCEM; + + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if Spacing not in Positive_Count then + raise Constraint_Error; + end if; + + FIO.Check_Read_Status (AP (File)); + + for L in 1 .. Spacing loop + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + else + ch := Getc (File); + + -- If at end of file now, then immediately raise End_Error. Note + -- that we can never be positioned between a line mark and a page + -- mark, so if we are at the end of file, we cannot logically be + -- before the implicit page mark that is at the end of the file. + + -- For the same reason, we do not need an explicit check for a + -- page mark. If there is a FF in the middle of a line, the file + -- is not in canonical format and we do not care about the page + -- numbers for files other than ones in canonical format. + + if ch = EOF then + raise End_Error; + end if; + + -- If not at end of file, then loop till we get to an LM or EOF. + -- The latter case happens only in non-canonical files where the + -- last line is not terminated by LM, but we don't want to blow + -- up for such files, so we assume an implicit LM in this case. + + loop + exit when ch = LM or ch = EOF; + ch := Getc (File); + end loop; + end if; + + -- We have got past a line mark, now, for a regular file only, + -- see if a page mark immediately follows this line mark and + -- if so, skip past the page mark as well. We do not do this + -- for non-regular files, since it would cause an undesirable + -- wait for an additional character. + + File.Col := 1; + File.Line := File.Line + 1; + + if File.Before_LM_PM then + File.Page := File.Page + 1; + File.Line := 1; + File.Before_LM_PM := False; + + elsif File.Is_Regular_File then + ch := Getc (File); + + -- Page mark can be explicit, or implied at the end of the file + + if (ch = PM or else ch = EOF) + and then File.Is_Regular_File + then + File.Page := File.Page + 1; + File.Line := 1; + else + Ungetc (ch, File); + end if; + end if; + + end loop; + + File.Before_Wide_Wide_Character := False; + end Skip_Line; + + procedure Skip_Line (Spacing : Positive_Count := 1) is + begin + Skip_Line (Current_In, Spacing); + end Skip_Line; + + --------------- + -- Skip_Page -- + --------------- + + procedure Skip_Page (File : File_Type) is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If at page mark already, just skip it + + if File.Before_LM_PM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + return; + end if; + + -- This is a bit tricky, if we are logically before an LM then + -- it is not an error if we are at an end of file now, since we + -- are not really at it. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := Getc (File); + + -- Otherwise we do raise End_Error if we are at the end of file now + + else + ch := Getc (File); + + if ch = EOF then + raise End_Error; + end if; + end if; + + -- Now we can just rumble along to the next page mark, or to the + -- end of file, if that comes first. The latter case happens when + -- the page mark is implied at the end of file. + + loop + exit when ch = EOF + or else (ch = PM and then File.Is_Regular_File); + ch := Getc (File); + end loop; + + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + File.Before_Wide_Wide_Character := False; + end Skip_Page; + + procedure Skip_Page is + begin + Skip_Page (Current_In); + end Skip_Page; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Standard_Err; + end Standard_Error; + + function Standard_Error return File_Access is + begin + return Standard_Err'Access; + end Standard_Error; + + -------------------- + -- Standard_Input -- + -------------------- + + function Standard_Input return File_Type is + begin + return Standard_In; + end Standard_Input; + + function Standard_Input return File_Access is + begin + return Standard_In'Access; + end Standard_Input; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Standard_Out; + end Standard_Output; + + function Standard_Output return File_Access is + begin + return Standard_Out'Access; + end Standard_Output; + + -------------------- + -- Terminate_Line -- + -------------------- + + procedure Terminate_Line (File : File_Type) is + begin + FIO.Check_File_Open (AP (File)); + + -- For file other than In_File, test for needing to terminate last line + + if Mode (File) /= In_File then + + -- If not at start of line definition need new line + + if File.Col /= 1 then + New_Line (File); + + -- For files other than standard error and standard output, we + -- make sure that an empty file has a single line feed, so that + -- it is properly formatted. We avoid this for the standard files + -- because it is too much of a nuisance to have these odd line + -- feeds when nothing has been written to the file. + + elsif (File /= Standard_Err and then File /= Standard_Out) + and then (File.Line = 1 and then File.Page = 1) + then + New_Line (File); + end if; + end if; + end Terminate_Line; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + + ----------- + -- Write -- + ----------- + + -- This is the primitive Stream Write routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Write + (File : in out Wide_Wide_Text_AFCB; + Item : Stream_Element_Array) + is + Siz : constant size_t := Item'Length; + + begin + if File.Mode = FCB.In_File then + raise Mode_Error; + end if; + + -- Now we do the write. Since this is a text file, it is normally in + -- text mode, but stream data must be written in binary mode, so we + -- temporarily set binary mode for the write, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then + raise Device_Error; + end if; + + set_text_mode (fileno (File.Stream)); + end Write; + + -- Use "preallocated" strings to avoid calling "new" during the + -- elaboration of the run time. This is needed in the tasking case to + -- avoid calling Task_Lock too early. A filename is expected to end with + -- a null character in the runtime, here the null characters are added + -- just to have a correct filename length. + + Err_Name : aliased String := "*stderr" & ASCII.Nul; + In_Name : aliased String := "*stdin" & ASCII.Nul; + Out_Name : aliased String := "*stdout" & ASCII.Nul; + +begin + ------------------------------- + -- Initialize Standard Files -- + ------------------------------- + + for J in WC_Encoding_Method loop + if WC_Encoding = WC_Encoding_Letters (J) then + Default_WCEM := J; + end if; + end loop; + + -- Note: the names in these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC test insist! + -- We use names that are bound to fail in open etc. + + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Is_Text_File := True; + Standard_Err.Access_Method := 'T'; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Is_Text_File := True; + Standard_In.Access_Method := 'T'; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Is_Text_File := True; + Standard_Out.Access_Method := 'T'; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Chain_File (AP (Standard_In)); + FIO.Chain_File (AP (Standard_Out)); + FIO.Chain_File (AP (Standard_Err)); + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + +end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-ztexio.ads b/gcc/ada/a-ztexio.ads new file mode 100644 index 00000000000..d6240674b2c --- /dev/null +++ b/gcc/ada/a-ztexio.ads @@ -0,0 +1,488 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the generic subpackages of Wide_Wide_Text_IO (Integer_IO, Float_IO, +-- Fixed_IO, Modular_IO, Decimal_IO and Enumeration_IO) appear as private +-- children in GNAT. These children are with'ed automatically if they are +-- referenced, so this rearrangement is invisible to user programs, but has +-- the advantage that only the needed parts of Wide_Wide_Text_IO are processed +-- and loaded. + +with Ada.IO_Exceptions; +with Ada.Streams; +with System; +with System.File_Control_Block; +with System.WCh_Con; + +package Ada.Wide_Wide_Text_IO is + + package WCh_Con renames System.WCh_Con; + + type File_Type is limited private; + type File_Mode is (In_File, Out_File, Append_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) + Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) + Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) + + type Count is range 0 .. Natural'Last; + -- The value of Count'Last must be large enough so that the assumption + -- enough so that the assumption that the Line, Column and Page + -- counts can never exceed this value is a valid assumption. + + subtype Positive_Count is Count range 1 .. Count'Last; + + Unbounded : constant Count := 0; + -- Line and page length + + subtype Field is Integer range 0 .. 255; + -- Note: if for any reason, there is a need to increase this value, + -- then it will be necessary to change the corresponding value in + -- System.Img_Real in file s-imgrea.adb. + + subtype Number_Base is Integer range 2 .. 16; + + type Type_Set is (Lower_Case, Upper_Case); + + --------------------- + -- File Management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := ""); + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : File_Type) return File_Mode; + function Name (File : File_Type) return String; + function Form (File : File_Type) return String; + + function Is_Open (File : File_Type) return Boolean; + + ------------------------------------------------------ + -- Control of default input, output and error files -- + ------------------------------------------------------ + + procedure Set_Input (File : File_Type); + procedure Set_Output (File : File_Type); + procedure Set_Error (File : File_Type); + + function Standard_Input return File_Type; + function Standard_Output return File_Type; + function Standard_Error return File_Type; + + function Current_Input return File_Type; + function Current_Output return File_Type; + function Current_Error return File_Type; + + type File_Access is access constant File_Type; + + function Standard_Input return File_Access; + function Standard_Output return File_Access; + function Standard_Error return File_Access; + + function Current_Input return File_Access; + function Current_Output return File_Access; + function Current_Error return File_Access; + + -------------------- + -- Buffer control -- + -------------------- + + -- Note: The paramter file is in out in the RM, but as pointed out + -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. + + procedure Flush (File : File_Type); + procedure Flush; + + -------------------------------------------- + -- Specification of line and page lengths -- + -------------------------------------------- + + procedure Set_Line_Length (File : File_Type; To : Count); + procedure Set_Line_Length (To : Count); + + procedure Set_Page_Length (File : File_Type; To : Count); + procedure Set_Page_Length (To : Count); + + function Line_Length (File : File_Type) return Count; + function Line_Length return Count; + + function Page_Length (File : File_Type) return Count; + function Page_Length return Count; + + ------------------------------------ + -- Column, Line, and Page Control -- + ------------------------------------ + + procedure New_Line (File : File_Type; Spacing : Positive_Count := 1); + procedure New_Line (Spacing : Positive_Count := 1); + + procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1); + procedure Skip_Line (Spacing : Positive_Count := 1); + + function End_Of_Line (File : File_Type) return Boolean; + function End_Of_Line return Boolean; + + procedure New_Page (File : File_Type); + procedure New_Page; + + procedure Skip_Page (File : File_Type); + procedure Skip_Page; + + function End_Of_Page (File : File_Type) return Boolean; + function End_Of_Page return Boolean; + + function End_Of_File (File : File_Type) return Boolean; + function End_Of_File return Boolean; + + procedure Set_Col (File : File_Type; To : Positive_Count); + procedure Set_Col (To : Positive_Count); + + procedure Set_Line (File : File_Type; To : Positive_Count); + procedure Set_Line (To : Positive_Count); + + function Col (File : File_Type) return Positive_Count; + function Col return Positive_Count; + + function Line (File : File_Type) return Positive_Count; + function Line return Positive_Count; + + function Page (File : File_Type) return Positive_Count; + function Page return Positive_Count; + + ---------------------------- + -- Character Input-Output -- + ---------------------------- + + procedure Get (File : File_Type; Item : out Wide_Wide_Character); + procedure Get (Item : out Wide_Wide_Character); + procedure Put (File : File_Type; Item : Wide_Wide_Character); + procedure Put (Item : Wide_Wide_Character); + + procedure Look_Ahead + (File : File_Type; + Item : out Wide_Wide_Character; + End_Of_Line : out Boolean); + + procedure Look_Ahead + (Item : out Wide_Wide_Character; + End_Of_Line : out Boolean); + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character); + + procedure Get_Immediate + (Item : out Wide_Wide_Character); + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character; + Available : out Boolean); + + procedure Get_Immediate + (Item : out Wide_Wide_Character; + Available : out Boolean); + + ------------------------- + -- String Input-Output -- + ------------------------- + + procedure Get (File : File_Type; Item : out Wide_Wide_String); + procedure Get (Item : out Wide_Wide_String); + procedure Put (File : File_Type; Item : Wide_Wide_String); + procedure Put (Item : Wide_Wide_String); + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_String; + Last : out Natural); + + function Get_Line (File : File_Type) return Wide_Wide_String; + pragma Ada_05 (Get_Line); + + function Get_Line return Wide_Wide_String; + pragma Ada_05 (Get_Line); + + procedure Get_Line + (Item : out Wide_Wide_String; + Last : out Natural); + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_String); + + procedure Put_Line + (Item : Wide_Wide_String); + + --------------------------------------- + -- Generic packages for Input-Output -- + --------------------------------------- + + -- The generic packages: + + -- Ada.Wide_Wide_Text_IO.Integer_IO + -- Ada.Wide_Wide_Text_IO.Modular_IO + -- Ada.Wide_Wide_Text_IO.Float_IO + -- Ada.Wide_Wide_Text_IO.Fixed_IO + -- Ada.Wide_Wide_Text_IO.Decimal_IO + -- Ada.Wide_Wide_Text_IO.Enumeration_IO + + -- are implemented as separate child packages in GNAT, so the + -- spec and body of these packages are to be found in separate + -- child units. This implementation detail is hidden from the + -- Ada programmer by special circuitry in the compiler that + -- treats these child packages as though they were nested in + -- Text_IO. The advantage of this special processing is that + -- the subsidiary routines needed if these generics are used + -- are not loaded when they are not used. + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + Layout_Error : exception renames IO_Exceptions.Layout_Error; + +private + ----------------------------------- + -- Handling of Format Characters -- + ----------------------------------- + + -- Line marks are represented by the single character ASCII.LF (16#0A#). + -- In DOS and similar systems, underlying file translation takes care + -- of translating this to and from the standard CR/LF sequences used in + -- these operating systems to mark the end of a line. On output there is + -- always a line mark at the end of the last line, but on input, this + -- line mark can be omitted, and is implied by the end of file. + + -- Page marks are represented by the single character ASCII.FF (16#0C#), + -- The page mark at the end of the file may be omitted, and is normally + -- omitted on output unless an explicit New_Page call is made before + -- closing the file. No page mark is added when a file is appended to, + -- so, in accordance with the permission in (RM A.10.2(4)), there may + -- or may not be a page mark separating preexising text in the file + -- from the new text to be written. + + -- A file mark is marked by the physical end of file. In DOS translation + -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the + -- physical end of file, so in effect this character is recognized as + -- marking the end of file in DOS and similar systems. + + LM : constant := Character'Pos (ASCII.LF); + -- Used as line mark + + PM : constant := Character'Pos (ASCII.FF); + -- Used as page mark, except at end of file where it is implied + + ------------------------------------- + -- Wide_Wide_Text_IO File Control Block -- + ------------------------------------- + + Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8; + -- This gets modified during initialization (see body) using + -- the default value established in the call to Set_Globals. + + package FCB renames System.File_Control_Block; + + type Wide_Wide_Text_AFCB is new FCB.AFCB with record + Page : Count := 1; + Line : Count := 1; + Col : Count := 1; + Line_Length : Count := 0; + Page_Length : Count := 0; + + Before_LM : Boolean := False; + -- This flag is used to deal with the anomolies introduced by the + -- peculiar definition of End_Of_File and End_Of_Page in Ada. These + -- functions require looking ahead more than one character. Since + -- there is no convenient way of backing up more than one character, + -- what we do is to leave ourselves positioned past the LM, but set + -- this flag, so that we know that from an Ada point of view we are + -- in front of the LM, not after it. A bit of a kludge, but it works! + + Before_LM_PM : Boolean := False; + -- This flag similarly handles the case of being physically positioned + -- after a LM-PM sequence when logically we are before the LM-PM. This + -- flag can only be set if Before_LM is also set. + + WC_Method : WCh_Con.WC_Encoding_Method := Default_WCEM; + -- Encoding method to be used for this file + + Before_Wide_Wide_Character : Boolean := False; + -- This flag is set to indicate that a wide character in the input has + -- been read by Wide_Wide_Text_IO.Look_Ahead. If it is set to True, + -- then it means that the stream is logically positioned before the + -- character but is physically positioned after it. The character + -- involved must not be in the range 16#00#-16#7F#, i.e. if the flag is + -- set, then we know the next character has a code greater than 16#7F#, + -- and the value of this character is saved in + -- Saved_Wide_Wide_Character. + + Saved_Wide_Wide_Character : Wide_Wide_Character; + -- This field is valid only if Before_Wide_Wide_Character is set. It + -- contains a wide character read by Look_Ahead. If Look_Ahead + -- reads a character in the range 16#0000# to 16#007F#, then it + -- can use ungetc to put it back, but ungetc cannot be called + -- more than once, so for characters above this range, we don't + -- try to back up the file. Instead we save the character in this + -- field and set the flag Before_Wide_Wide_Character to indicate that + -- we are logically positioned before this character even though + -- the stream is physically positioned after it. + + end record; + + type File_Type is access all Wide_Wide_Text_AFCB; + + function AFCB_Allocate + (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : access Wide_Wide_Text_AFCB); + procedure AFCB_Free (File : access Wide_Wide_Text_AFCB); + + procedure Read + (File : in out Wide_Wide_Text_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read operation used when Wide_Wide_Text_IO file is treated as a Stream + + procedure Write + (File : in out Wide_Wide_Text_AFCB; + Item : Ada.Streams.Stream_Element_Array); + -- Write operation used when Wide_Wide_Text_IO file is treated as a Stream + + ------------------------ + -- The Standard Files -- + ------------------------ + + Null_Str : aliased constant String := ""; + -- Used as name and form of standard files + + Standard_Err_AFCB : aliased Wide_Wide_Text_AFCB; + Standard_In_AFCB : aliased Wide_Wide_Text_AFCB; + Standard_Out_AFCB : aliased Wide_Wide_Text_AFCB; + + Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; + Standard_In : aliased File_Type := Standard_In_AFCB'Access; + Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; + -- Standard files + + Current_In : aliased File_Type := Standard_In; + Current_Out : aliased File_Type := Standard_Out; + Current_Err : aliased File_Type := Standard_Err; + -- Current files + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- These subprograms are in the private part of the spec so that they can + -- be shared by the routines in the body of Ada.Text_IO.Wide_Wide_Text_IO. + + -- Note: we use Integer in these declarations instead of the more accurate + -- Interfaces.C_Streams.int, because we do not want to drag in the spec of + -- this interfaces package with the spec of Ada.Text_IO, and we know that + -- in fact these types are identical + + function Getc (File : File_Type) return Integer; + -- Gets next character from file, which has already been checked for + -- being in read status, and returns the character read if no error + -- occurs. The result is EOF if the end of file was read. + + procedure Get_Character + (File : File_Type; + Item : out Character); + -- This is essentially a copy of the normal Get routine from Text_IO. It + -- obtains a single character from the input file File, and places it in + -- Item. This character may be the leading character of a + -- Wide_Wide_Character sequence, but that is up to the caller to deal + -- with. + + function Get_Wide_Wide_Char + (C : Character; + File : File_Type) return Wide_Wide_Character; + -- This function is shared by Get and Get_Immediate to extract a wide + -- character value from the given File. The first byte has already been + -- read and is passed in C. The wide character value is returned as the + -- result, and the file pointer is bumped past the character. + + function Nextc (File : File_Type) return Integer; + -- Returns next character from file without skipping past it (i.e. it + -- is a combination of Getc followed by an Ungetc). + + procedure Putc (ch : Integer; File : File_Type); + -- Outputs the given character to the file, which has already been + -- checked for being in output status. Device_Error is raised if the + -- character cannot be written. + + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current + -- line is not terminated, then a line terminator is written using + -- New_Line. Note that there is no Terminate_Page routine, because + -- the page mark at the end of the file is implied if necessary. + + procedure Ungetc (ch : Integer; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has + -- checked that the file is in read status. Device_Error is raised + -- if the character cannot be pushed back. An attempt to push back + -- and end of file character (EOF) is ignored. + +end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-ztfiio.adb b/gcc/ada/a-ztfiio.adb new file mode 100644 index 00000000000..855e15a7e73 --- /dev/null +++ b/gcc/ada/a-ztfiio.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Float_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Fixed_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-ztfiio.ads b/gcc/ada/a-ztfiio.ads new file mode 100644 index 00000000000..ada870c5f77 --- /dev/null +++ b/gcc/ada/a-ztfiio.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Fixed_IO is a subpackage of +-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Fixed_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <>; + +package Ada.Wide_Wide_Text_IO.Fixed_IO is + + Default_Fore : Field := Num'Fore; + Default_Aft : Field := Num'Aft; + Default_Exp : Field := 0; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-ztflau.adb b/gcc/ada/a-ztflau.adb new file mode 100644 index 00000000000..b9480521a3d --- /dev/null +++ b/gcc/ada/a-ztflau.adb @@ -0,0 +1,228 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; + +with System.Img_Real; use System.Img_Real; +with System.Val_Real; use System.Val_Real; + +package body Ada.Wide_Wide_Text_IO.Float_Aux is + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + end if; + + Item := Scan_Real (Buf, Ptr'Access, Stop); + + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + Item : out Long_Long_Float; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Real (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets; + + --------------- + -- Load_Real -- + --------------- + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Loaded : Boolean; + + begin + -- Skip initial blanks and load possible sign + + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + -- Case of .nnnn + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Otherwise must have digits to start + + else + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Based cases + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + + -- Case of nnn#.xxx# + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + + -- Case of nnn#xxx.[xxx]# or nnn#xxx# + + else + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + end if; + + -- As usual, it seems strange to allow mixed base characters, + -- but that is what ACVC tests expect, see CE3804M, case (3). + + Load (File, Buf, Ptr, '#', ':'); + end if; + + -- Case of nnn.[nnn] or nnn + + else + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr); + end if; + end if; + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end Load_Real; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : Long_Long_Float; + Aft : Field; + Exp : Field) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); + + if Ptr > To'Length then + raise Layout_Error; + + else + for J in 1 .. Ptr loop + To (To'Last - Ptr + J) := Buf (J); + end loop; + + for J in To'First .. To'Last - Ptr loop + To (J) := ' '; + end loop; + end if; + end Puts; + +end Ada.Wide_Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/a-ztflau.ads b/gcc/ada/a-ztflau.ads new file mode 100644 index 00000000000..b69d8d4a94f --- /dev/null +++ b/gcc/ada/a-ztflau.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Float_IO that +-- are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Float_IO itself, +-- except that generic parameter Num has been replaced by Long_Long_Float, +-- and the default parameters have been removed because they are supplied +-- explicitly by the calls from within the generic template. Also used by +-- Ada.Wide_Wide_Text_IO.Fixed_IO, and by Ada.Wide_Wide_Text_IO.Decimal_IO. + +private package Ada.Wide_Wide_Text_IO.Float_Aux is + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load a possibly signed + -- real literal value from the input file into Buf, starting at Ptr + 1. + + procedure Get + (File : File_Type; + Item : out Long_Long_Float; + Width : Field); + + procedure Gets + (From : String; + Item : out Long_Long_Float; + Last : out Positive); + + procedure Put + (File : File_Type; + Item : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Puts + (To : out String; + Item : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Wide_Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/a-ztflio.adb b/gcc/ada/a-ztflio.adb new file mode 100644 index 00000000000..582fbbc3ba6 --- /dev/null +++ b/gcc/ada/a-ztflio.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2000 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Float_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Float_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-ztflio.ads b/gcc/ada/a-ztflio.ads new file mode 100644 index 00000000000..1b1064eb3d1 --- /dev/null +++ b/gcc/ada/a-ztflio.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Float_IO is a subpackage +-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Float_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is digits <>; + +package Ada.Wide_Wide_Text_IO.Float_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-ztgeau.adb b/gcc/ada/a-ztgeau.adb new file mode 100644 index 00000000000..dd621ef6dc5 --- /dev/null +++ b/gcc/ada/a-ztgeau.adb @@ -0,0 +1,517 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . G E N E R I C _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; + +package body Ada.Wide_Wide_Text_IO.Generic_Aux is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + subtype AP is FCB.AFCB_Ptr; + + ------------------------ + -- Check_End_Of_Field -- + ------------------------ + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field) + is + begin + if Ptr > Stop then + return; + + elsif Width = 0 then + raise Data_Error; + + else + for J in Ptr .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + end if; + end Check_End_Of_Field; + + ----------------------- + -- Check_On_One_Line -- + ----------------------- + + procedure Check_On_One_Line + (File : File_Type; + Length : Integer) + is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Line_Length /= 0 then + if Count (Length) > File.Line_Length then + raise Layout_Error; + elsif File.Col + Count (Length) > File.Line_Length + 1 then + New_Line (File); + end if; + end if; + end Check_On_One_Line; + + -------------- + -- Is_Blank -- + -------------- + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + ---------- + -- Load -- + ---------- + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean) + is + ch : int; + + begin + if File.Before_Wide_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch = Character'Pos (Char) then + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + else + Ungetc (ch, File); + Loaded := False; + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character) + is + ch : int; + + begin + if File.Before_Wide_Wide_Character then + null; + + else + ch := Getc (File); + + if ch = Character'Pos (Char) then + Store_Char (File, ch, Buf, Ptr); + else + Ungetc (ch, File); + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean) + is + ch : int; + + begin + if File.Before_Wide_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch = Character'Pos (Char1) + or else ch = Character'Pos (Char2) + then + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + else + Ungetc (ch, File); + Loaded := False; + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character) + is + ch : int; + + begin + if File.Before_Wide_Wide_Character then + null; + + else + ch := Getc (File); + + if ch = Character'Pos (Char1) + or else ch = Character'Pos (Char2) + then + Store_Char (File, ch, Buf, Ptr); + else + Ungetc (ch, File); + end if; + end if; + end Load; + + ----------------- + -- Load_Digits -- + ----------------- + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean) + is + ch : int; + After_Digit : Boolean; + + begin + if File.Before_Wide_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch not in Character'Pos ('0') .. Character'Pos ('9') then + Loaded := False; + + else + Loaded := True; + After_Digit := True; + + loop + Store_Char (File, ch, Buf, Ptr); + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + end loop; + end if; + + Ungetc (ch, File); + end if; + end Load_Digits; + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer) + is + ch : int; + After_Digit : Boolean; + + begin + if File.Before_Wide_Wide_Character then + return; + + else + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + loop + Store_Char (File, ch, Buf, Ptr); + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + end loop; + end if; + + Ungetc (ch, File); + end if; + end Load_Digits; + + -------------------------- + -- Load_Extended_Digits -- + -------------------------- + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean) + is + ch : int; + After_Digit : Boolean := False; + + begin + if File.Before_Wide_Wide_Character then + Loaded := False; + return; + + else + Loaded := False; + + loop + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') + or else + ch in Character'Pos ('a') .. Character'Pos ('f') + or else + ch in Character'Pos ('A') .. Character'Pos ('F') + then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + end loop; + + Ungetc (ch, File); + end if; + end Load_Extended_Digits; + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer) + is + Junk : Boolean; + + begin + Load_Extended_Digits (File, Buf, Ptr, Junk); + end Load_Extended_Digits; + + --------------- + -- Load_Skip -- + --------------- + + procedure Load_Skip (File : File_Type) is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + -- We need to explicitly test for the case of being before a wide + -- character (greater than 16#7F#). Since no such character can + -- ever legitimately be a valid numeric character, we can + -- immediately signal Data_Error. + + if File.Before_Wide_Wide_Character then + raise Data_Error; + end if; + + -- Otherwise loop till we find a non-blank character (note that as + -- usual in Wide_Wide_Text_IO, blank includes horizontal tab). Note that + -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately. + + loop + Get_Character (File, C); + exit when not Is_Blank (C); + end loop; + + Ungetc (Character'Pos (C), File); + File.Col := File.Col - 1; + end Load_Skip; + + ---------------- + -- Load_Width -- + ---------------- + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer) + is + ch : int; + WC : Wide_Wide_Character; + + Bad_Wide_Wide_C : Boolean := False; + -- Set True if one of the characters read is not in range of type + -- Character. This is always a Data_Error, but we do not signal it + -- right away, since we have to read the full number of characters. + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are immediately before a line mark, then we have no characters. + -- This is always a data error, so we may as well raise it right away. + + if File.Before_LM then + raise Data_Error; + + else + for J in 1 .. Width loop + if File.Before_Wide_Wide_Character then + Bad_Wide_Wide_C := True; + Store_Char (File, 0, Buf, Ptr); + File.Before_Wide_Wide_Character := False; + + else + ch := Getc (File); + + if ch = EOF then + exit; + + elsif ch = LM then + Ungetc (ch, File); + exit; + + else + WC := Get_Wide_Wide_Char (Character'Val (ch), File); + ch := Wide_Wide_Character'Pos (WC); + + if ch > 255 then + Bad_Wide_Wide_C := True; + ch := 0; + end if; + + Store_Char (File, ch, Buf, Ptr); + end if; + end if; + end loop; + + if Bad_Wide_Wide_C then + raise Data_Error; + end if; + end if; + end Load_Width; + + -------------- + -- Put_Item -- + -------------- + + procedure Put_Item (File : File_Type; Str : String) is + begin + Check_On_One_Line (File, Str'Length); + + for J in Str'Range loop + Put (File, Wide_Wide_Character'Val (Character'Pos (Str (J)))); + end loop; + end Put_Item; + + ---------------- + -- Store_Char -- + ---------------- + + procedure Store_Char + (File : File_Type; + ch : Integer; + Buf : out String; + Ptr : in out Integer) + is + begin + File.Col := File.Col + 1; + + if Ptr = Buf'Last then + raise Data_Error; + else + Ptr := Ptr + 1; + Buf (Ptr) := Character'Val (ch); + end if; + end Store_Char; + + ----------------- + -- String_Skip -- + ----------------- + + procedure String_Skip (Str : String; Ptr : out Integer) is + begin + Ptr := Str'First; + + loop + if Ptr > Str'Last then + raise End_Error; + + elsif not Is_Blank (Str (Ptr)) then + return; + + else + Ptr := Ptr + 1; + end if; + end loop; + end String_Skip; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + +end Ada.Wide_Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/a-ztgeau.ads b/gcc/ada/a-ztgeau.ads new file mode 100644 index 00000000000..2a41c4251eb --- /dev/null +++ b/gcc/ada/a-ztgeau.ads @@ -0,0 +1,186 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . G E N E R I C _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a set of auxiliary routines used by Wide_Wide_Text_IO +-- generic children, including for reading and writing numeric strings. + +-- Note: although this is the Wide version of the package, the interface here +-- is still in terms of Character and String rather than Wide_Wide_Character +-- and Wide_Wide_String, since all numeric strings are composed entirely of +-- characters in the range of type Standard.Character, and the basic +-- conversion routines work with Character rather than Wide_Wide_Character. + +package Ada.Wide_Wide_Text_IO.Generic_Aux is + + -- Note: for all the Load routines, File indicates the file to be read, + -- Buf is the string into which data is stored, Ptr is the index of the + -- last character stored so far, and is updated if additional characters + -- are stored. Data_Error is raised if the input overflows Buf. The only + -- Load routines that do a file status check are Load_Skip and Load_Width + -- so one of these two routines must be called first. + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field); + -- This routine is used after doing a get operations on a numeric value. + -- Buf is the string being scanned, and Stop is the last character of + -- the field being scanned. Ptr is as set by the call to the scan routine + -- that scanned out the numeric value, i.e. it points one past the last + -- character scanned, and Width is the width parameter from the Get call. + -- + -- There are two cases, if Width is non-zero, then a check is made that + -- the remainder of the field is all blanks. If Width is zero, then it + -- means that the scan routine scanned out only part of the field. We + -- have already scanned out the field that the ACVC tests seem to expect + -- us to read (even if it does not follow the syntax of the type being + -- scanned, e.g. allowing negative exponents in integers, and underscores + -- at the end of the string), so we just raise Data_Error. + + procedure Check_On_One_Line (File : File_Type; Length : Integer); + -- Check to see if item of length Integer characters can fit on + -- current line. Call New_Line if not, first checking that the + -- line length can accommodate Length characters, raise Layout_Error + -- if item is too large for a single line. + + function Is_Blank (C : Character) return Boolean; + -- Determines if C is a blank (space or tab) + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer); + -- Loads exactly Width characters, unless a line mark is encountered first + + procedure Load_Skip (File : File_Type); + -- Skips leading blanks and line and page marks, if the end of file is + -- read without finding a non-blank character, then End_Error is raised. + -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean); + -- If next character is Char, loads it, otherwise no characters are loaded + -- Loaded is set to indicate whether or not the character was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character); + -- Same as above, but no indication if character is loaded + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean); + -- If next character is Char1 or Char2, loads it, otherwise no characters + -- are loaded. Loaded is set to indicate whether or not one of the two + -- characters was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character); + -- Same as above, but no indication if character is loaded + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Loads a sequence of zero or more decimal digits. Loaded is set if + -- at least one digit is loaded. + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Like Load_Digits, but also allows extended digits a-f and A-F + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + procedure Put_Item (File : File_Type; Str : String); + -- This routine is like Wide_Wide_Text_IO.Put, except that it checks for + -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used + -- for all output of numeric values and of enumeration values. Note that + -- the buffer is of type String. Put_Item deals with converting this to + -- Wide_Wide_Characters as required. + + procedure Store_Char + (File : File_Type; + ch : Integer; + Buf : out String; + Ptr : in out Integer); + -- Store a single character in buffer, checking for overflow and + -- adjusting the column number in the file to reflect the fact + -- that a character has been acquired from the input stream. + -- The pos value of the character to store is in ch on entry. + + procedure String_Skip (Str : String; Ptr : out Integer); + -- Used in the Get from string procedures to skip leading blanks in the + -- string. Ptr is set to the index of the first non-blank. If the string + -- is all blanks, then the excption End_Error is raised, Note that blank + -- is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Ungetc (ch : Integer; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has + -- checked that the file is in read status. Device_Error is raised + -- if the character cannot be pushed back. An attempt to push back + -- an end of file (EOF) is ignored. + +private + pragma Inline (Is_Blank); + +end Ada.Wide_Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/a-ztinau.adb b/gcc/ada/a-ztinau.adb new file mode 100644 index 00000000000..4af54fcf70e --- /dev/null +++ b/gcc/ada/a-ztinau.adb @@ -0,0 +1,293 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; + +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; + +package body Ada.Wide_Wide_Text_IO.Integer_Aux is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load an possibly signed + -- integer literal value from the input file into Buf, starting at Ptr + 1. + -- On return, Ptr is set to the last character stored. + + ------------- + -- Get_Int -- + ------------- + + procedure Get_Int + (File : File_Type; + Item : out Integer; + Width : Field) + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer := 1; + Stop : Integer := 0; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Integer (File, Buf, Stop); + end if; + + Item := Scan_Integer (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_Int; + + ------------- + -- Get_LLI -- + ------------- + + procedure Get_LLI + (File : File_Type; + Item : out Long_Long_Integer; + Width : Field) + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer := 1; + Stop : Integer := 0; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Integer (File, Buf, Stop); + end if; + + Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_LLI; + + -------------- + -- Gets_Int -- + -------------- + + procedure Gets_Int + (From : String; + Item : out Integer; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Integer (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_Int; + + -------------- + -- Gets_LLI -- + -------------- + + procedure Gets_LLI + (From : String; + Item : out Long_Long_Integer; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_LLI; + + ------------------ + -- Load_Integer -- + ------------------ + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Integer; + + ------------- + -- Put_Int -- + ------------- + + procedure Put_Int + (File : File_Type; + Item : Integer; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Integer (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Integer (Item, Width, Buf, Ptr); + else + Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_Int; + + ------------- + -- Put_LLI -- + ------------- + + procedure Put_LLI + (File : File_Type; + Item : Long_Long_Integer; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Long_Long_Integer (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); + else + Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLI; + + -------------- + -- Puts_Int -- + -------------- + + procedure Puts_Int + (To : out String; + Item : Integer; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_Int; + + -------------- + -- Puts_LLI -- + -------------- + + procedure Puts_LLI + (To : out String; + Item : Long_Long_Integer; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_LLI; + +end Ada.Wide_Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/a-ztinau.ads b/gcc/ada/a-ztinau.ads new file mode 100644 index 00000000000..07839965fa4 --- /dev/null +++ b/gcc/ada/a-ztinau.ads @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO +-- that are shared among separate instantiations of this package. The +-- routines in this package are identical semantically to those in Integer_IO +-- itself, except that the generic parameter Num has been replaced by Integer +-- or Long_Long_Integer, and the default parameters have been removed because +-- they are supplied explicitly by the calls from within the generic template. + +private package Ada.Wide_Wide_Text_IO.Integer_Aux is + + procedure Get_Int + (File : File_Type; + Item : out Integer; + Width : Field); + + procedure Get_LLI + (File : File_Type; + Item : out Long_Long_Integer; + Width : Field); + + procedure Gets_Int + (From : String; + Item : out Integer; + Last : out Positive); + + procedure Gets_LLI + (From : String; + Item : out Long_Long_Integer; + Last : out Positive); + + procedure Put_Int + (File : File_Type; + Item : Integer; + Width : Field; + Base : Number_Base); + + procedure Put_LLI + (File : File_Type; + Item : Long_Long_Integer; + Width : Field; + Base : Number_Base); + + procedure Puts_Int + (To : out String; + Item : Integer; + Base : Number_Base); + + procedure Puts_LLI + (To : out String; + Item : Long_Long_Integer; + Base : Number_Base); + +end Ada.Wide_Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/a-ztinio.adb b/gcc/ada/a-ztinio.adb new file mode 100644 index 00000000000..5a8418fdae8 --- /dev/null +++ b/gcc/ada/a-ztinio.adb @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2000 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Integer_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Integer_IO is + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + -- Throughout this generic body, we distinguish between the case + -- where type Integer is acceptable, and where a Long_Long_Integer + -- is needed. This constant Boolean is used to test for these cases + -- and since it is a constant, only the code for the relevant case + -- will be included in the instance. + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Integer_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Need_LLI then + Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); + else + Aux.Get_Int (TFT (File), Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLI then + Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); + else + Aux.Gets_Int (S, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLI then + Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); + else + Aux.Put_Int (TFT (File), Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLI then + Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); + else + Aux.Puts_Int (S, Integer (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-ztinio.ads b/gcc/ada/a-ztinio.ads new file mode 100644 index 00000000000..2ccc0e52909 --- /dev/null +++ b/gcc/ada/a-ztinio.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Integer_IO is a subpackage +-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Integer_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is range <>; + +package Ada.Wide_Wide_Text_IO.Integer_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-ztmoau.adb b/gcc/ada/a-ztmoau.adb new file mode 100644 index 00000000000..ae673db0066 --- /dev/null +++ b/gcc/ada/a-ztmoau.adb @@ -0,0 +1,303 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2003 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; + +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; + +package body Ada.Wide_Wide_Text_IO.Modular_Aux is + + use System.Unsigned_Types; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Modular + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load an possibly signed + -- modular literal value from the input file into Buf, starting at Ptr + 1. + -- Ptr is left set to the last character stored. + + ------------- + -- Get_LLU -- + ------------- + + procedure Get_LLU + (File : File_Type; + Item : out Long_Long_Unsigned; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Modular (File, Buf, Stop); + end if; + + Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_LLU; + + ------------- + -- Get_Uns -- + ------------- + + procedure Get_Uns + (File : File_Type; + Item : out Unsigned; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Modular (File, Buf, Stop); + end if; + + Item := Scan_Unsigned (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_Uns; + + -------------- + -- Gets_LLU -- + -------------- + + procedure Gets_LLU + (From : String; + Item : out Long_Long_Unsigned; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_LLU; + + -------------- + -- Gets_Uns -- + -------------- + + procedure Gets_Uns + (From : String; + Item : out Unsigned; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Unsigned (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_Uns; + + ------------------ + -- Load_Modular -- + ------------------ + + procedure Load_Modular + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + + -- Note: it is a bit strange to allow a minus sign here, but it seems + -- consistent with the general behavior expected by the ACVC tests + -- which is to scan past junk and then signal data error, see ACVC + -- test CE3704F, case (6), which is for signed integer exponents, + -- which seems a similar case. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants + -- for the signed case, and there seems no good reason to treat + -- exponents differently for the signed and unsigned cases. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Modular; + + ------------- + -- Put_LLU -- + ------------- + + procedure Put_LLU + (File : File_Type; + Item : Long_Long_Unsigned; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); + else + Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLU; + + ------------- + -- Put_Uns -- + ------------- + + procedure Put_Uns + (File : File_Type; + Item : Unsigned; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Unsigned (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); + else + Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_Uns; + + -------------- + -- Puts_LLU -- + -------------- + + procedure Puts_LLU + (To : out String; + Item : Long_Long_Unsigned; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_LLU; + + -------------- + -- Puts_Uns -- + -------------- + + procedure Puts_Uns + (To : out String; + Item : Unsigned; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_Uns; + +end Ada.Wide_Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/a-ztmoau.ads b/gcc/ada/a-ztmoau.ads new file mode 100644 index 00000000000..6b4b2691478 --- /dev/null +++ b/gcc/ada/a-ztmoau.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Modular_IO +-- that are shared among separate instantiations of this package. The +-- routines in this package are identical semantically to those in Modular_IO +-- itself, except that the generic parameter Num has been replaced by +-- Unsigned or Long_Long_Unsigned, and the default parameters have been +-- removed because they are supplied explicitly by the calls from within the +-- generic template. + +with System.Unsigned_Types; + +private package Ada.Wide_Wide_Text_IO.Modular_Aux is + + package U renames System.Unsigned_Types; + + procedure Get_Uns + (File : File_Type; + Item : out U.Unsigned; + Width : Field); + + procedure Get_LLU + (File : File_Type; + Item : out U.Long_Long_Unsigned; + Width : Field); + + procedure Gets_Uns + (From : String; + Item : out U.Unsigned; + Last : out Positive); + + procedure Gets_LLU + (From : String; + Item : out U.Long_Long_Unsigned; + Last : out Positive); + + procedure Put_Uns + (File : File_Type; + Item : U.Unsigned; + Width : Field; + Base : Number_Base); + + procedure Put_LLU + (File : File_Type; + Item : U.Long_Long_Unsigned; + Width : Field; + Base : Number_Base); + + procedure Puts_Uns + (To : out String; + Item : U.Unsigned; + Base : Number_Base); + + procedure Puts_LLU + (To : out String; + Item : U.Long_Long_Unsigned; + Base : Number_Base); + +end Ada.Wide_Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/a-ztmoio.adb b/gcc/ada/a-ztmoio.adb new file mode 100644 index 00000000000..ed21c671200 --- /dev/null +++ b/gcc/ada/a-ztmoio.adb @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- 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.Modular_Aux; + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Modular_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Modular_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Unsigned'Size then + Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width); + else + Aux.Get_Uns (TFT (File), Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Unsigned'Size then + Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last); + else + Aux.Gets_Uns (S, Unsigned (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Num'Size > Unsigned'Size then + Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base); + else + Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Num'Size > Unsigned'Size then + Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base); + else + Aux.Puts_Uns (S, Unsigned (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/a-ztmoio.ads b/gcc/ada/a-ztmoio.ads new file mode 100644 index 00000000000..dc41a7334e3 --- /dev/null +++ b/gcc/ada/a-ztmoio.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Modular_IO is a subpackage of +-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading the +-- necessary code if Modular_IO is not instantiated. See the routine +-- Rtsfind.Text_IO_Kludge for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is mod <>; + +package Ada.Wide_Wide_Text_IO.Modular_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/a-zttest.adb b/gcc/ada/a-zttest.adb new file mode 100644 index 00000000000..4ba6e00dfc1 --- /dev/null +++ b/gcc/ada/a-zttest.adb @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2005 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 2, 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. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING. If not, write -- +-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- +-- MA 02111-1307, USA. -- +-- -- +-- As a special exception, if other files instantiate generics from this -- +-- unit, or you link this unit with other files to produce an executable, -- +-- this unit does not by itself cause the resulting executable to be -- +-- covered by the GNU General Public License. This exception does not -- +-- however invalidate any other reasons why the executable file might be -- +-- covered by the GNU Public License. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.File_IO; + +package body Ada.Wide_Wide_Text_IO.Text_Streams is + + ------------ + -- Stream -- + ------------ + + function Stream (File : File_Type) return Stream_Access is + begin + System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); + return Stream_Access (File); + end Stream; + +end Ada.Wide_Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-zttest.ads b/gcc/ada/a-zttest.ads new file mode 100644 index 00000000000..b417ecac925 --- /dev/null +++ b/gcc/ada/a-zttest.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; + +package Ada.Wide_Wide_Text_IO.Text_Streams is + + type Stream_Access is access all Streams.Root_Stream_Type'Class; + + function Stream (File : File_Type) return Stream_Access; + +end Ada.Wide_Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-zzunio.ads b/gcc/ada/a-zzunio.ads new file mode 100644 index 00000000000..fddc8a28c1f --- /dev/null +++ b/gcc/ada/a-zzunio.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUNTIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_UNBOUNDED_IO -- +-- -- +-- S p e c -- +-- -- +-- This specification is adapted from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Wide_Wide_Unbounded. So we implement this new Ada 2005 +-- package by renaming the subprograms in that child. This is a more +-- straightforward implementation anyway, since we need access to the +-- internal representation of Unbounded_Wide_Wide_String. + + +with Ada.Strings.Wide_Wide_Unbounded; +with Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; + +package Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put; + + procedure Put + (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put; + + procedure Put_Line + (File : Wide_Wide_Text_IO.File_Type; + Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line; + + function Get_Line + (File : File_Type) + return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + function Get_Line + return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + +end Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO; |