OSDN -- 开发和下载开源软件
简体中文翻译状态 translation status for zh
  • R/O
  • SSH
Fork

Ada95FL: 提交

Ada 95 foundation library


Commit MetaInfo

修订版04bb88a17ef551ca0f1141a64ea6fe368da7d368 (tree)
时间2019-10-09 09:12:41
作者Sergey Dukov <dukov54@live...>
CommiterSergey Dukov

Log Message

#32763 Реализация функционала "Wide_Wide_Unbounded"

更改概述

差异

diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/.#Ada_Magic_Forward.Wide_Wide_Characters.ads#
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Unbounded/.#Ada_Magic_Forward.Wide_Wide_Characters.ads# Wed Oct 09 04:12:41 2019 +0400
@@ -0,0 +1,69 @@
1+------------------------------------------------------------------------------
2+-- Copyright 2019 Levashev Ivan Aleksandrovich --
3+-- --
4+-- Licensed under the Apache License, Version 2.0 (the "License"); --
5+-- you may not use this file except in compliance with the License. --
6+-- You may obtain a copy of the License at --
7+-- --
8+-- http://www.apache.org/licenses/LICENSE-2.0 --
9+-- --
10+-- Unless required by applicable law or agreed to in writing, software --
11+-- distributed under the License is distributed on an "AS IS" BASIS, --
12+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. --
13+-- See the License for the specific language governing permissions and --
14+-- limitations under the License. --
15+------------------------------------------------------------------------------
16+
17+-- Character_32 and Wide_Wide_String backported to AdaMagic
18+--
19+-- GNAT version of this package is supposed to be empty. This is to make
20+-- possible to "use" this package and expect that the right thing will be
21+-- found in both GNAT and AdaMagic.
22+--
23+-- "Use"-ability of this package is in conflict with qualified referencing.
24+-- Ada_Magic_Forward.Standard_Forward complements this package to fill this
25+-- gap. I.e. Ada_Magic_Forward.Standard_Forward.Character_32 or
26+-- Ada_Magic_Forward.Standard_Forward."<" are defined in both GNAT and
27+-- AdaMagic.
28+
29+with System; use System;
30+with System.Storage_Elements;
31+with Interfaces;
32+
33+package Ada_Magic_Forward.Character_32s is
34+ pragma Preelaborate;
35+
36+ -- The declaration of type Character_32 is based on the full
37+ -- ISO/IEC 10646:2011 character set. The first 65536 positions have the
38+ -- same contents as type Wide_Character. See 3.5.2.
39+
40+ type Character_32 is
41+ new Interfaces.Unsigned_32 range 0 .. 16#10FFFF#;
42+ for Character_32'Size use 32;
43+ -- Enumerable nature of Character_32 had to be shown somehow.
44+ -- Public inheritance from Interfaces.Integer_32 achieves this.
45+ --
46+ -- Integer origins are cleaned, functions "+", "-" and so on are
47+ -- removed. However, it is still possible to create Character_32
48+ -- from universal integral literal. It virtually cannot be fixed.
49+ --
50+ -- Reminder: use Character_32'Val (...) for portable creation of
51+ -- character values.
52+
53+ type String_32 is array (Positive range <>) of Character_32;
54+ pragma Pack (String_32);
55+
56+ Null_String_32 : String_32(2 .. 1);
57+
58+ type Byte_Type is new System.Storage_Elements.Storage_Element;
59+ type Byte_Access is access all Byte_Type;
60+
61+ type Array_Of_Byte_Type is array
62+ (Positive range <>) of aliased Byte_Type;
63+ for Array_Of_Byte_Type'Alignment use 4;
64+ type Array_Of_Byte_Access is access all Array_Of_Byte_Type;
65+ Null_Array : Array_Of_Byte_Type(2 .. 1);
66+
67+
68+
69+end Ada_Magic_Forward.Character_32s;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/Ada_Magic_Forward.Character_32s.ads
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Unbounded/Ada_Magic_Forward.Character_32s.ads Wed Oct 09 04:12:41 2019 +0400
@@ -0,0 +1,69 @@
1+------------------------------------------------------------------------------
2+-- Copyright 2019 Levashev Ivan Aleksandrovich --
3+-- --
4+-- Licensed under the Apache License, Version 2.0 (the "License"); --
5+-- you may not use this file except in compliance with the License. --
6+-- You may obtain a copy of the License at --
7+-- --
8+-- http://www.apache.org/licenses/LICENSE-2.0 --
9+-- --
10+-- Unless required by applicable law or agreed to in writing, software --
11+-- distributed under the License is distributed on an "AS IS" BASIS, --
12+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. --
13+-- See the License for the specific language governing permissions and --
14+-- limitations under the License. --
15+------------------------------------------------------------------------------
16+
17+-- Character_32 and Wide_Wide_String backported to AdaMagic
18+--
19+-- GNAT version of this package is supposed to be empty. This is to make
20+-- possible to "use" this package and expect that the right thing will be
21+-- found in both GNAT and AdaMagic.
22+--
23+-- "Use"-ability of this package is in conflict with qualified referencing.
24+-- Ada_Magic_Forward.Standard_Forward complements this package to fill this
25+-- gap. I.e. Ada_Magic_Forward.Standard_Forward.Character_32 or
26+-- Ada_Magic_Forward.Standard_Forward."<" are defined in both GNAT and
27+-- AdaMagic.
28+
29+with System; use System;
30+with System.Storage_Elements;
31+with Interfaces;
32+
33+package Ada_Magic_Forward.Character_32s is
34+ pragma Preelaborate;
35+
36+ -- The declaration of type Character_32 is based on the full
37+ -- ISO/IEC 10646:2011 character set. The first 65536 positions have the
38+ -- same contents as type Wide_Character. See 3.5.2.
39+
40+ type Character_32 is
41+ new Interfaces.Unsigned_32 range 0 .. 16#10FFFF#;
42+ for Character_32'Size use 32;
43+ -- Enumerable nature of Character_32 had to be shown somehow.
44+ -- Public inheritance from Interfaces.Integer_32 achieves this.
45+ --
46+ -- Integer origins are cleaned, functions "+", "-" and so on are
47+ -- removed. However, it is still possible to create Character_32
48+ -- from universal integral literal. It virtually cannot be fixed.
49+ --
50+ -- Reminder: use Character_32'Val (...) for portable creation of
51+ -- character values.
52+
53+ type String_32 is array (Positive range <>) of Character_32;
54+ pragma Pack (String_32);
55+
56+ Null_String_32 : String_32(2 .. 1);
57+
58+ type Byte_Type is new System.Storage_Elements.Storage_Element;
59+ type Byte_Access is access all Byte_Type;
60+
61+ type Array_Of_Byte_Type is array
62+ (Positive range <>) of aliased Byte_Type;
63+ for Array_Of_Byte_Type'Alignment use 4;
64+ type Array_Of_Byte_Access is access all Array_Of_Byte_Type;
65+ Null_Array : Array_Of_Byte_Type(2 .. 1);
66+
67+
68+
69+end Ada_Magic_Forward.Character_32s;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/Ada_Magic_Forward.Strings.ads
--- a/Unbounded/Ada_Magic_Forward.Strings.ads Sun Oct 06 14:03:50 2019 +0400
+++ b/Unbounded/Ada_Magic_Forward.Strings.ads Wed Oct 09 04:12:41 2019 +0400
@@ -18,14 +18,26 @@
1818 --
1919 -- GNAT version renames Ada.Strings.Wide_Wide_Space
2020
21-with Ada_Magic_Forward.Wide_Wide_Characters;
22-use Ada_Magic_Forward.Wide_Wide_Characters;
21+with Ada_Magic_Forward.Character_32s;
22+use Ada_Magic_Forward.Character_32s;
2323
2424 package Ada_Magic_Forward.Strings is
2525
26- pragma Pure;
27- pragma Preelaborate;
28-
26+ BOM32 : constant := 16#0000FEFF#;
27+ Space : constant Character := ' ';
28+ Wide_Space : constant Wide_Character := ' ';
2929 Character_32_Space : constant Character_32 := Character_32'Val (32);
3030
31+ -- The following declaration is for Ada 2005 (AI-285)
32+
33+ Length_Error, Pattern_Error, Index_Error, Translation_Error : exception;
34+
35+ type Alignment is (Left, Right, Center);
36+ type Truncation is (Left, Right, Error);
37+ type Membership is (Inside, Outside);
38+ type Direction is (Forward, Backward);
39+ type Trim_End is (Left, Right, Both);
40+
41+ type String_Codec is (Utf8, Utf16, Utf32);
42+
3143 end Ada_Magic_Forward.Strings;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/Ada_Magic_Forward.Wide_Wide_Characters.ads
--- a/Unbounded/Ada_Magic_Forward.Wide_Wide_Characters.ads Sun Oct 06 14:03:50 2019 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,58 +0,0 @@
1-------------------------------------------------------------------------------
2--- Copyright 2019 Levashev Ivan Aleksandrovich --
3--- --
4--- Licensed under the Apache License, Version 2.0 (the "License"); --
5--- you may not use this file except in compliance with the License. --
6--- You may obtain a copy of the License at --
7--- --
8--- http://www.apache.org/licenses/LICENSE-2.0 --
9--- --
10--- Unless required by applicable law or agreed to in writing, software --
11--- distributed under the License is distributed on an "AS IS" BASIS, --
12--- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. --
13--- See the License for the specific language governing permissions and --
14--- limitations under the License. --
15-------------------------------------------------------------------------------
16-
17--- Wide_Wide_Character and Wide_Wide_String backported to AdaMagic
18---
19--- GNAT version of this package is supposed to be empty. This is to make
20--- possible to "use" this package and expect that the right thing will be
21--- found in both GNAT and AdaMagic.
22---
23--- "Use"-ability of this package is in conflict with qualified referencing.
24--- Ada_Magic_Forward.Standard_Forward complements this package to fill this
25--- gap. I.e. Ada_Magic_Forward.Standard_Forward.Character_32 or
26--- Ada_Magic_Forward.Standard_Forward."<" are defined in both GNAT and
27--- AdaMagic.
28-
29-with Interfaces;
30-
31-package Ada_Magic_Forward.Wide_Wide_Characters is
32-
33- pragma Pure;
34- pragma Preelaborate;
35-
36- -- The declaration of type Character_32 is based on the full
37- -- ISO/IEC 10646:2011 character set. The first 65536 positions have the
38- -- same contents as type Wide_Character. See 3.5.2.
39-
40- type Character_32 is
41- new Interfaces.Unsigned_32 range 0 .. 16#10FFFF#;
42- for Character_32'Size use 32;
43- -- Enumerable nature of Character_32 had to be shown somehow.
44- -- Public inheritance from Interfaces.Integer_32 achieves this.
45- --
46- -- Integer origins are cleaned, functions "+", "-" and so on are
47- -- removed. However, it is still possible to create Character_32
48- -- from universal integral literal. It virtually cannot be fixed.
49- --
50- -- Reminder: use Character_32'Val (...) for portable creation of
51- -- character values.
52-
53- type String_32 is array (Positive range <>) of Character_32;
54- pragma Pack (String_32);
55-
56- -- The predefined operators for this type correspond to those for String.
57-
58-end Ada_Magic_Forward.Wide_Wide_Characters;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/ada_magic_forward.strings.wide_wide_maps.adb
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Unbounded/ada_magic_forward.strings.wide_wide_maps.adb Wed Oct 09 04:12:41 2019 +0400
@@ -0,0 +1,530 @@
1+
2+with Ada.Unchecked_Deallocation;
3+
4+package body Ada_Magic_Forward.Strings.Wide_Wide_Maps is
5+
6+ function "-"
7+ (Left, Right : Character_32_Set) return Character_32_Set
8+ is
9+ LS : constant Character_32_Ranges_Access := Left.Set;
10+ RS : constant Character_32_Ranges_Access := Right.Set;
11+ Result : Character_32_Ranges (1 .. LS'Last + RS'Last);
12+ -- Each range on the right can generate at least one more range in
13+ -- the result, by splitting one of the left operand ranges.
14+ N : Natural := 0;
15+ R : Natural := 1;
16+ L : Natural := 1;
17+ Left_Low : Character_32;
18+ -- Left_Low is lowest character of the L'th range not yet dealt with
19+ begin
20+ if LS'Last = 0 or else RS'Last = 0 then
21+ return Left;
22+ end if;
23+ Left_Low := LS (L).Low;
24+ while R <= RS'Last loop
25+ -- If next right range is below current left range, skip it
26+ if RS (R).High < Left_Low then
27+ R := R + 1;
28+ -- If next right range above current left range, copy remainder of
29+ -- the left range to the result
30+ elsif RS (R).Low > LS (L).High then
31+ N := N + 1;
32+ Result (N).Low := Left_Low;
33+ Result (N).High := LS (L).High;
34+ L := L + 1;
35+ exit when L > LS'Last;
36+ Left_Low := LS (L).Low;
37+ else
38+ -- Next right range overlaps bottom of left range
39+ if RS (R).Low <= Left_Low then
40+ -- Case of right range complete overlaps left range
41+ if RS (R).High >= LS (L).High then
42+ L := L + 1;
43+ exit when L > LS'Last;
44+ Left_Low := LS (L).Low;
45+ -- Case of right range eats lower part of left range
46+ else
47+ Left_Low := Character_32'Succ (RS (R).High);
48+ R := R + 1;
49+ end if;
50+ -- Next right range overlaps some of left range, but not bottom
51+ else
52+ N := N + 1;
53+ Result (N).Low := Left_Low;
54+ Result (N).High := Character_32'Pred (RS (R).Low);
55+ -- Case of right range splits left range
56+ if RS (R).High < LS (L).High then
57+ Left_Low := Character_32'Succ (RS (R).High);
58+ R := R + 1;
59+ -- Case of right range overlaps top of left range
60+ else
61+ L := L + 1;
62+ exit when L > LS'Last;
63+ Left_Low := LS (L).Low;
64+ end if;
65+ end if;
66+ end if;
67+ end loop;
68+ -- Copy remainder of left ranges to result
69+ if L <= LS'Last then
70+ N := N + 1;
71+ Result (N).Low := Left_Low;
72+ Result (N).High := LS (L).High;
73+ loop
74+ L := L + 1;
75+ exit when L > LS'Last;
76+ N := N + 1;
77+ Result (N) := LS (L);
78+ end loop;
79+ end if;
80+ return (AF.Controlled with
81+ Set => new Character_32_Ranges'(Result (1 .. N)));
82+ end "-";
83+
84+ function "=" (Left, Right : Character_32_Set) return Boolean is
85+ begin
86+ return Left.Set.all = Right.Set.all;
87+ end "=";
88+
89+ function "and"
90+ (Left, Right : Character_32_Set) return Character_32_Set
91+ is
92+ LS : constant Character_32_Ranges_Access := Left.Set;
93+ RS : constant Character_32_Ranges_Access := Right.Set;
94+ Result : Character_32_Ranges (1 .. LS'Last + RS'Last);
95+ N : Natural := 0;
96+ L, R : Natural := 1;
97+ begin
98+ -- Loop to search for overlapping character ranges
99+ while L <= LS'Last and then R <= RS'Last loop
100+ if LS (L).High < RS (R).Low then
101+ L := L + 1;
102+ elsif RS (R).High < LS (L).Low then
103+ R := R + 1;
104+ -- Here we have LS (L).High >= RS (R).Low
105+ -- and RS (R).High >= LS (L).Low
106+ -- so we have an overlapping range
107+ else
108+ N := N + 1;
109+ Result (N).Low :=
110+ Character_32'Max (LS (L).Low, RS (R).Low);
111+ Result (N).High :=
112+ Character_32'Min (LS (L).High, RS (R).High);
113+ if RS (R).High = LS (L).High then
114+ L := L + 1;
115+ R := R + 1;
116+ elsif RS (R).High < LS (L).High then
117+ R := R + 1;
118+ else
119+ L := L + 1;
120+ end if;
121+ end if;
122+ end loop;
123+ return (AF.Controlled with
124+ Set => new Character_32_Ranges'(Result (1 .. N)));
125+ end "and";
126+
127+ function "not"
128+ (Right : Character_32_Set) return Character_32_Set
129+ is
130+ RS : constant Character_32_Ranges_Access := Right.Set;
131+ Result : Character_32_Ranges (1 .. RS'Last + 1);
132+ N : Natural := 0;
133+ begin
134+ if RS'Last = 0 then
135+ N := 1;
136+ Result (1) := (Low => Character_32'First,
137+ High => Character_32'Last);
138+ else
139+ if RS (1).Low /= Character_32'First then
140+ N := N + 1;
141+ Result (N).Low := Character_32'First;
142+ Result (N).High := Character_32'Pred (RS (1).Low);
143+ end if;
144+ for K in 1 .. RS'Last - 1 loop
145+ N := N + 1;
146+ Result (N).Low := Character_32'Succ (RS (K).High);
147+ Result (N).High := Character_32'Pred (RS (K + 1).Low);
148+ end loop;
149+ if RS (RS'Last).High /= Character_32'Last then
150+ N := N + 1;
151+ Result (N).Low := Character_32'Succ (RS (RS'Last).High);
152+ Result (N).High := Character_32'Last;
153+ end if;
154+ end if;
155+ return (AF.Controlled with
156+ Set => new Character_32_Ranges'(Result (1 .. N)));
157+ end "not";
158+
159+ function "or"
160+ (Left, Right : Character_32_Set) return Character_32_Set
161+ is
162+ LS : constant Character_32_Ranges_Access := Left.Set;
163+ RS : constant Character_32_Ranges_Access := Right.Set;
164+ Result : Character_32_Ranges (1 .. LS'Last + RS'Last);
165+ N : Natural;
166+ L, R : Natural;
167+ begin
168+ N := 0;
169+ L := 1;
170+ R := 1;
171+ -- Loop through ranges in output file
172+ loop
173+ -- If no left ranges left, copy next right range
174+ if L > LS'Last then
175+ exit when R > RS'Last;
176+ N := N + 1;
177+ Result (N) := RS (R);
178+ R := R + 1;
179+ -- If no right ranges left, copy next left range
180+ elsif R > RS'Last then
181+ N := N + 1;
182+ Result (N) := LS (L);
183+ L := L + 1;
184+ else
185+ -- We have two ranges, choose lower one
186+ N := N + 1;
187+ if LS (L).Low <= RS (R).Low then
188+ Result (N) := LS (L);
189+ L := L + 1;
190+ else
191+ Result (N) := RS (R);
192+ R := R + 1;
193+ end if;
194+ -- Loop to collapse ranges into last range
195+ loop
196+ -- Collapse next length range into current result range
197+ -- if possible.
198+ if L <= LS'Last
199+ and then LS (L).Low <=
200+ Character_32'Succ (Result (N).High)
201+ then
202+ Result (N).High :=
203+ Character_32'Max (Result (N).High, LS (L).High);
204+ L := L + 1;
205+ -- Collapse next right range into current result range
206+ -- if possible
207+ elsif R <= RS'Last
208+ and then RS (R).Low <=
209+ Character_32'Succ (Result (N).High)
210+ then
211+ Result (N).High :=
212+ Character_32'Max (Result (N).High, RS (R).High);
213+ R := R + 1;
214+ -- If neither range collapses, then done with this range
215+ else
216+ exit;
217+ end if;
218+ end loop;
219+ end if;
220+ end loop;
221+ return (AF.Controlled with
222+ Set => new Character_32_Ranges'(Result (1 .. N)));
223+ end "or";
224+
225+ function "xor"
226+ (Left, Right : Character_32_Set) return Character_32_Set
227+ is
228+ begin
229+ return (Left or Right) - (Left and Right);
230+ end "xor";
231+
232+
233+ procedure Adjust (Object : in out Character_32_Mapping) is
234+ begin
235+ Object.Map := new Character_32_Mapping_Values'(Object.Map.all);
236+ end Adjust;
237+
238+ procedure Adjust (Object : in out Character_32_Set) is
239+ begin
240+ Object.Set := new Character_32_Ranges'(Object.Set.all);
241+ end Adjust;
242+
243+
244+ procedure Finalize (Object : in out Character_32_Mapping) is
245+ procedure Free is new Ada.Unchecked_Deallocation
246+ (Character_32_Mapping_Values,
247+ Character_32_Mapping_Values_Access);
248+ begin
249+ if Object.Map /= Null_Map'Unrestricted_Access then
250+ Free (Object.Map);
251+ end if;
252+ end Finalize;
253+
254+ procedure Finalize (Object : in out Character_32_Set) is
255+ procedure Free is new Ada.Unchecked_Deallocation
256+ (Character_32_Ranges,
257+ Character_32_Ranges_Access);
258+ begin
259+ if Object.Set /= Null_Range'Unrestricted_Access then
260+ Free (Object.Set);
261+ end if;
262+ end Finalize;
263+
264+
265+ procedure Initialize (Object : in out Character_32_Mapping) is
266+ begin
267+ Object := Identity;
268+ end Initialize;
269+
270+ procedure Initialize (Object : in out Character_32_Set) is
271+ begin
272+ Object := Null_Set;
273+ end Initialize;
274+
275+
276+ function Is_In
277+ (Element : Character_32;
278+ Set : Character_32_Set) return Boolean
279+ is
280+ L, R, M : Natural;
281+ SS : constant Character_32_Ranges_Access := Set.Set;
282+ begin
283+ L := 1;
284+ R := SS'Last;
285+ -- Binary search loop. The invariant is that if Element is in any of
286+ -- of the constituent ranges it is in one between Set (L) and Set (R).
287+ loop
288+ if L > R then
289+ return False;
290+ else
291+ M := (L + R) / 2;
292+ if Element > SS (M).High then
293+ L := M + 1;
294+ elsif Element < SS (M).Low then
295+ R := M - 1;
296+ else
297+ return True;
298+ end if;
299+ end if;
300+ end loop;
301+ end Is_In;
302+
303+ function Is_Subset
304+ (Elements : Character_32_Set;
305+ Set : Character_32_Set) return Boolean
306+ is
307+ ES : constant Character_32_Ranges_Access := Elements.Set;
308+ SS : constant Character_32_Ranges_Access := Set.Set;
309+ S : Positive := 1;
310+ E : Positive := 1;
311+ begin
312+ loop
313+ -- If no more element ranges, done, and result is true
314+ if E > ES'Last then
315+ return True;
316+ -- If more element ranges, but no more set ranges, result is false
317+ elsif S > SS'Last then
318+ return False;
319+ -- Remove irrelevant set range
320+ elsif SS (S).High < ES (E).Low then
321+ S := S + 1;
322+ -- Get rid of element range that is properly covered by set
323+ elsif SS (S).Low <= ES (E).Low
324+ and then ES (E).High <= SS (S).High
325+ then
326+ E := E + 1;
327+ -- Otherwise we have a non-covered element range, result is false
328+ else
329+ return False;
330+ end if;
331+ end loop;
332+ end Is_Subset;
333+
334+ function To_Domain
335+ (Map : Character_32_Mapping) return Character_32_Sequence
336+ is
337+ begin
338+ return Map.Map.Domain;
339+ end To_Domain;
340+
341+ function To_Mapping
342+ (From, To : Character_32_Sequence)
343+ return Character_32_Mapping
344+ is
345+ Domain : Character_32_Sequence (1 .. From'Length);
346+ Rangev : Character_32_Sequence (1 .. To'Length);
347+ N : Natural := 0;
348+ begin
349+ if From'Length /= To'Length then
350+ raise Translation_Error;
351+ else
352+ pragma Warnings (Off); -- apparent uninit use of Domain
353+ for J in From'Range loop
354+ for M in 1 .. N loop
355+ if From (J) = Domain (M) then
356+ raise Translation_Error;
357+ elsif From (J) < Domain (M) then
358+ Domain (M + 1 .. N + 1) := Domain (M .. N);
359+ Rangev (M + 1 .. N + 1) := Rangev (M .. N);
360+ Domain (M) := From (J);
361+ Rangev (M) := To (J);
362+ goto Continue;
363+ end if;
364+ end loop;
365+ Domain (N + 1) := From (J);
366+ Rangev (N + 1) := To (J);
367+ <<Continue>>
368+ N := N + 1;
369+ end loop;
370+ pragma Warnings (On);
371+ return (AF.Controlled with
372+ Map => new Character_32_Mapping_Values'(
373+ Length => N,
374+ Domain => Domain (1 .. N),
375+ Rangev => Rangev (1 .. N)));
376+ end if;
377+ end To_Mapping;
378+
379+ function To_Range
380+ (Map : Character_32_Mapping) return Character_32_Sequence
381+ is
382+ begin
383+ return Map.Map.Rangev;
384+ end To_Range;
385+
386+ function To_Ranges
387+ (Set : Character_32_Set) return Character_32_Ranges
388+ is
389+ begin
390+ return Set.Set.all;
391+ end To_Ranges;
392+
393+ function To_Sequence
394+ (Set : Character_32_Set) return Character_32_Sequence
395+ is
396+ SS : constant Character_32_Ranges_Access := Set.Set;
397+ N : Natural := 0;
398+ Count : Natural := 0;
399+ begin
400+ for J in SS'Range loop
401+ Count :=
402+ Count + (Character_32'Pos (SS (J).High) -
403+ Character_32'Pos (SS (J).Low) + 1);
404+ end loop;
405+ declare
406+ Result : String_32 (1 .. Count);
407+ begin
408+ for J in SS'Range loop
409+ for K in SS (J).Low .. SS (J).High loop
410+ N := N + 1;
411+ Result (N) := K;
412+ end loop;
413+ end loop;
414+ return Result;
415+ end;
416+ end To_Sequence;
417+
418+ function To_Set
419+ (Ranges : Character_32_Ranges) return Character_32_Set
420+ is
421+ Result : Character_32_Ranges (Ranges'Range);
422+ N : Natural := 0;
423+ J : Natural;
424+ begin
425+ -- The output of To_Set is required to be sorted by increasing Low
426+ -- values, and discontiguous, so first we sort them as we enter them,
427+ -- using a simple insertion sort.
428+ pragma Warnings (Off);
429+ -- Kill bogus warning on Result being uninitialized
430+ for J in Ranges'Range loop
431+ for K in 1 .. N loop
432+ if Ranges (J).Low < Result (K).Low then
433+ Result (K + 1 .. N + 1) := Result (K .. N);
434+ Result (K) := Ranges (J);
435+ goto Continue;
436+ end if;
437+ end loop;
438+ Result (N + 1) := Ranges (J);
439+ <<Continue>>
440+ N := N + 1;
441+ end loop;
442+ pragma Warnings (On);
443+ -- Now collapse any contiguous or overlapping ranges
444+ J := 1;
445+ while J < N loop
446+ if Result (J).High < Result (J).Low then
447+ N := N - 1;
448+ Result (J .. N) := Result (J + 1 .. N + 1);
449+ elsif Character_32'Succ (Result (J).High) >=
450+ Result (J + 1).Low
451+ then
452+ Result (J).High :=
453+ Character_32'Max (Result (J).High, Result (J + 1).High);
454+ N := N - 1;
455+ Result (J + 1 .. N) := Result (J + 2 .. N + 1);
456+ else
457+ J := J + 1;
458+ end if;
459+ end loop;
460+ if Result (N).High < Result (N).Low then
461+ N := N - 1;
462+ end if;
463+ return (AF.Controlled with
464+ Set => new Character_32_Ranges'(Result (1 .. N)));
465+ end To_Set;
466+
467+ function To_Set
468+ (Span : Character_32_Range) return Character_32_Set
469+ is
470+ begin
471+ if Span.Low > Span.High then
472+ return Null_Set;
473+ -- This is safe, because there is no procedure with parameter
474+ -- Character_32_Set of mode "out" or "in out".
475+ else
476+ return (AF.Controlled with
477+ Set => new Character_32_Ranges'(1 => Span));
478+ end if;
479+ end To_Set;
480+
481+ function To_Set
482+ (Sequence : Character_32_Sequence) return Character_32_Set
483+ is
484+ R : Character_32_Ranges (1 .. Sequence'Length);
485+ begin
486+ for J in R'Range loop
487+ R (J) := (Sequence (J), Sequence (J));
488+ end loop;
489+ return To_Set (R);
490+ end To_Set;
491+
492+ function To_Set
493+ (Singleton : Character_32) return Character_32_Set
494+ is
495+ begin
496+ return
497+ (AF.Controlled with
498+ Set => new Character_32_Ranges'(1 => (Singleton, Singleton)));
499+ end To_Set;
500+
501+ function Value
502+ (Map : Character_32_Mapping;
503+ Element : Character_32) return Character_32
504+ is
505+ L, R, M : Natural;
506+ MV : constant Character_32_Mapping_Values_Access := Map.Map;
507+ begin
508+ L := 1;
509+ R := MV.Domain'Last;
510+ -- Binary search loop
511+ loop
512+ -- If not found, identity
513+ if L > R then
514+ return Element;
515+ -- Otherwise do binary divide
516+ else
517+ M := (L + R) / 2;
518+ if Element < MV.Domain (M) then
519+ R := M - 1;
520+ elsif Element > MV.Domain (M) then
521+ L := M + 1;
522+ else -- Element = MV.Domain (M) then
523+ return MV.Rangev (M);
524+ end if;
525+ end if;
526+ end loop;
527+ end Value;
528+
529+
530+end Ada_Magic_Forward.Strings.Wide_Wide_Maps;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/ada_magic_forward.strings.wide_wide_maps.ads
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Unbounded/ada_magic_forward.strings.wide_wide_maps.ads Wed Oct 09 04:12:41 2019 +0400
@@ -0,0 +1,144 @@
1+
2+with Ada.Finalization;
3+
4+package Ada_Magic_Forward.Strings.Wide_Wide_Maps is
5+
6+ type Character_32_Set is private;
7+ -- Representation for a set of Character_32 values:
8+ Null_Set : constant Character_32_Set;
9+
10+ type Character_32_Range is record
11+ Low : Character_32;
12+ High : Character_32;
13+ end record;
14+ -- Represents Character_32 range Low .. High
15+
16+ type Character_32_Ranges is
17+ array (Positive range <>) of Character_32_Range;
18+
19+ function To_Set
20+ (Ranges : Character_32_Ranges) return Character_32_Set;
21+
22+ function To_Set
23+ (Span : Character_32_Range) return Character_32_Set;
24+
25+ function To_Ranges
26+ (Set : Character_32_Set) return Character_32_Ranges;
27+
28+ function "=" (Left, Right : Character_32_Set) return Boolean;
29+
30+ function "not"
31+ (Right : Character_32_Set) return Character_32_Set;
32+
33+ function "and"
34+ (Left, Right : Character_32_Set) return Character_32_Set;
35+
36+ function "or"
37+ (Left, Right : Character_32_Set) return Character_32_Set;
38+
39+ function "xor"
40+ (Left, Right : Character_32_Set) return Character_32_Set;
41+
42+ function "-"
43+ (Left, Right : Character_32_Set) return Character_32_Set;
44+
45+ function Is_In
46+ (Element : Character_32;
47+ Set : Character_32_Set) return Boolean;
48+
49+ function Is_Subset
50+ (Elements : Character_32_Set;
51+ Set : Character_32_Set) return Boolean;
52+
53+ function "<="
54+ (Left : Character_32_Set;
55+ Right : Character_32_Set) return Boolean
56+ renames Is_Subset;
57+
58+ subtype Character_32_Sequence is String_32;
59+ -- Alternative representation for a set of character values
60+
61+ function To_Set
62+ (Sequence : Character_32_Sequence) return Character_32_Set;
63+
64+ function To_Set
65+ (Singleton : Character_32) return Character_32_Set;
66+
67+ function To_Sequence
68+ (Set : Character_32_Set) return Character_32_Sequence;
69+
70+ type Character_32_Mapping is private;
71+ -- Representation for a wide character to wide character mapping:
72+
73+ function Value
74+ (Map : Character_32_Mapping;
75+ Element : Character_32) return Character_32;
76+
77+ Identity : constant Character_32_Mapping;
78+
79+ function To_Mapping
80+ (From, To : Character_32_Sequence)
81+ return Character_32_Mapping;
82+
83+ function To_Domain
84+ (Map : Character_32_Mapping) return Character_32_Sequence;
85+
86+ function To_Range
87+ (Map : Character_32_Mapping) return Character_32_Sequence;
88+
89+ type Character_32_Mapping_Function is
90+ access function (From : Character_32) return Character_32;
91+
92+private
93+ package AF renames Ada.Finalization;
94+
95+ type Character_32_Ranges_Access is
96+ access all Character_32_Ranges;
97+
98+ type Character_32_Set is new AF.Controlled with record
99+ Set : Character_32_Ranges_Access;
100+ end record;
101+
102+ pragma Finalize_Storage_Only (Character_32_Set);
103+
104+ procedure Initialize (Object : in out Character_32_Set);
105+ procedure Adjust (Object : in out Character_32_Set);
106+ procedure Finalize (Object : in out Character_32_Set);
107+
108+ Null_Range : aliased constant Character_32_Ranges :=
109+ (1 .. 0 => (Low => 32, High => 32));
110+
111+ Null_Set : constant Character_32_Set :=
112+ (AF.Controlled with
113+ Set => Null_Range'Unrestricted_Access);
114+
115+ type Character_32_Mapping_Values (Length : Natural) is record
116+ Domain : Character_32_Sequence (1 .. Length);
117+ Rangev : Character_32_Sequence (1 .. Length);
118+ end record;
119+
120+ type Character_32_Mapping_Values_Access is
121+ access all Character_32_Mapping_Values;
122+
123+ type Character_32_Mapping is new AF.Controlled with record
124+ Map : Character_32_Mapping_Values_Access;
125+ end record;
126+
127+ pragma Finalize_Storage_Only (Character_32_Mapping);
128+
129+ procedure Initialize (Object : in out Character_32_Mapping);
130+ procedure Adjust (Object : in out Character_32_Mapping);
131+ procedure Finalize (Object : in out Character_32_Mapping);
132+
133+ Null_Map : aliased constant Character_32_Mapping_Values :=
134+ (Length => 0,
135+ Domain => Null_String_32,
136+ Rangev => Null_String_32);
137+
138+ Identity : constant Character_32_Mapping :=
139+ (AF.Controlled with
140+ Map => Null_Map'Unrestricted_Access);
141+
142+
143+
144+end Ada_Magic_Forward.Strings.Wide_Wide_Maps;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/ada_magic_forward.strings.wide_wide_search.adb
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Unbounded/ada_magic_forward.strings.wide_wide_search.adb Wed Oct 09 04:12:41 2019 +0400
@@ -0,0 +1,473 @@
1+
2+with Ada_Magic_Forward.Strings.Wide_Wide_Maps;
3+use Ada_Magic_Forward.Strings.Wide_Wide_Maps;
4+with System; use System;
5+
6+package body Ada_Magic_Forward.Strings.Wide_Wide_Search is
7+
8+ function Belongs
9+ (Element : Character_32;
10+ Set : Wide_Wide_Maps.Character_32_Set;
11+ Test : Membership) return Boolean;
12+ pragma Inline (Belongs);
13+
14+ function Belongs
15+ (Element : Character_32;
16+ Set : Wide_Wide_Maps.Character_32_Set;
17+ Test : Membership) return Boolean
18+ is
19+ begin
20+ if Test = Inside then
21+ return Is_In (Element, Set);
22+ else
23+ return not Is_In (Element, Set);
24+ end if;
25+ end Belongs;
26+
27+ function Count
28+ (Source : String_32;
29+ Pattern : String_32;
30+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
31+ Wide_Wide_Maps.Identity) return Natural
32+ is
33+ PL1 : constant Integer := Pattern'Length - 1;
34+ Num : Natural;
35+ Ind : Natural;
36+ Cur : Natural;
37+ begin
38+ if Pattern'Length = 0 then
39+ raise Pattern_Error;
40+ end if;
41+ Num := 0;
42+ Ind := Source'First;
43+ -- Unmapped case
44+ if Mapping'Address = Wide_Wide_Maps.Identity'Address then
45+ while Ind <= Source'Last - PL1 loop
46+ if Pattern = Source (Ind .. Ind + PL1) then
47+ Num := Num + 1;
48+ Ind := Ind + Pattern'Length;
49+ else
50+ Ind := Ind + 1;
51+ end if;
52+ end loop;
53+ -- Mapped case
54+ else
55+ while Ind <= Source'Last - PL1 loop
56+ Cur := Ind;
57+ for K in Pattern'Range loop
58+ if Pattern (K) /= Value (Mapping, Source (Cur)) then
59+ Ind := Ind + 1;
60+ goto Cont;
61+ else
62+ Cur := Cur + 1;
63+ end if;
64+ end loop;
65+ Num := Num + 1;
66+ Ind := Ind + Pattern'Length;
67+ <<Cont>>
68+ null;
69+ end loop;
70+ end if;
71+ -- Return result
72+ return Num;
73+ end Count;
74+
75+ function Count
76+ (Source : String_32;
77+ Pattern : String_32;
78+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
79+ return Natural
80+ is
81+ PL1 : constant Integer := Pattern'Length - 1;
82+ Num : Natural;
83+ Ind : Natural;
84+ Cur : Natural;
85+ begin
86+ if Pattern'Length = 0 then
87+ raise Pattern_Error;
88+ end if;
89+ -- Check for null pointer in case checks are off
90+ if Mapping = null then
91+ raise Constraint_Error;
92+ end if;
93+ Num := 0;
94+ Ind := Source'First;
95+ while Ind <= Source'Last - PL1 loop
96+ Cur := Ind;
97+ for K in Pattern'Range loop
98+ if Pattern (K) /= Mapping (Source (Cur)) then
99+ Ind := Ind + 1;
100+ goto Cont;
101+ else
102+ Cur := Cur + 1;
103+ end if;
104+ end loop;
105+ Num := Num + 1;
106+ Ind := Ind + Pattern'Length;
107+ <<Cont>>
108+ null;
109+ end loop;
110+ return Num;
111+ end Count;
112+
113+ function Count
114+ (Source : String_32;
115+ Set : Wide_Wide_Maps.Character_32_Set) return Natural
116+ is
117+ N : Natural := 0;
118+ begin
119+ for J in Source'Range loop
120+ if Is_In (Source (J), Set) then
121+ N := N + 1;
122+ end if;
123+ end loop;
124+ return N;
125+ end Count;
126+
127+ procedure Find_Token
128+ (Source : String_32;
129+ Set : Wide_Wide_Maps.Character_32_Set;
130+ From : Positive;
131+ Test : Membership;
132+ First : out Positive;
133+ Last : out Natural)
134+ is
135+ begin
136+ for J in From .. Source'Last loop
137+ if Belongs (Source (J), Set, Test) then
138+ First := J;
139+ for K in J + 1 .. Source'Last loop
140+ if not Belongs (Source (K), Set, Test) then
141+ Last := K - 1;
142+ return;
143+ end if;
144+ end loop;
145+ -- Here if J indexes first char of token, and all chars after J
146+ -- are in the token.
147+ Last := Source'Last;
148+ return;
149+ end if;
150+ end loop;
151+ -- Here if no token found
152+ First := From;
153+ Last := 0;
154+ end Find_Token;
155+
156+ procedure Find_Token
157+ (Source : String_32;
158+ Set : Wide_Wide_Maps.Character_32_Set;
159+ Test : Membership;
160+ First : out Positive;
161+ Last : out Natural)
162+ is
163+ begin
164+ for J in Source'Range loop
165+ if Belongs (Source (J), Set, Test) then
166+ First := J;
167+ for K in J + 1 .. Source'Last loop
168+ if not Belongs (Source (K), Set, Test) then
169+ Last := K - 1;
170+ return;
171+ end if;
172+ end loop;
173+ -- Here if J indexes first char of token, and all chars after J
174+ -- are in the token.
175+ Last := Source'Last;
176+ return;
177+ end if;
178+ end loop;
179+ -- Here if no token found
180+ -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if
181+ -- Source'First is not positive and is assigned to First. Formulation
182+ -- is slightly different in RM 2012, but the intent seems similar, so
183+ -- we check explicitly for that condition.
184+ if Source'First not in Positive then
185+ raise Constraint_Error;
186+ else
187+ First := Source'First;
188+ Last := 0;
189+ end if;
190+ end Find_Token;
191+
192+ function Index
193+ (Source : String_32;
194+ Pattern : String_32;
195+ Going : Direction := Forward;
196+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
197+ Wide_Wide_Maps.Identity) return Natural
198+ is
199+ PL1 : constant Integer := Pattern'Length - 1;
200+ Cur : Natural;
201+ Ind : Integer;
202+ -- Index for start of match check. This can be negative if the pattern
203+ -- length is greater than the string length, which is why this variable
204+ -- is Integer instead of Natural. In this case, the search loops do not
205+ -- execute at all, so this Ind value is never used.
206+ begin
207+ if Pattern'Length = 0 then
208+ raise Pattern_Error;
209+ end if;
210+ -- Forwards case
211+ if Going = Forward then
212+ Ind := Source'First;
213+ -- Unmapped forward case
214+ if Mapping'Address = Wide_Wide_Maps.Identity'Address then
215+ for J in 1 .. Source'Length - PL1 loop
216+ if Pattern = Source (Ind .. Ind + PL1) then
217+ return Ind;
218+ else
219+ Ind := Ind + 1;
220+ end if;
221+ end loop;
222+ -- Mapped forward case
223+ else
224+ for J in 1 .. Source'Length - PL1 loop
225+ Cur := Ind;
226+ for K in Pattern'Range loop
227+ if Pattern (K) /= Value (Mapping, Source (Cur)) then
228+ goto Cont1;
229+ else
230+ Cur := Cur + 1;
231+ end if;
232+ end loop;
233+ return Ind;
234+ <<Cont1>>
235+ Ind := Ind + 1;
236+ end loop;
237+ end if;
238+ -- Backwards case
239+ else
240+ -- Unmapped backward case
241+ Ind := Source'Last - PL1;
242+ if Mapping'Address = Wide_Wide_Maps.Identity'Address then
243+ for J in reverse 1 .. Source'Length - PL1 loop
244+ if Pattern = Source (Ind .. Ind + PL1) then
245+ return Ind;
246+ else
247+ Ind := Ind - 1;
248+ end if;
249+ end loop;
250+ -- Mapped backward case
251+ else
252+ for J in reverse 1 .. Source'Length - PL1 loop
253+ Cur := Ind;
254+ for K in Pattern'Range loop
255+ if Pattern (K) /= Value (Mapping, Source (Cur)) then
256+ goto Cont2;
257+ else
258+ Cur := Cur + 1;
259+ end if;
260+ end loop;
261+ return Ind;
262+ <<Cont2>>
263+ Ind := Ind - 1;
264+ end loop;
265+ end if;
266+ end if;
267+ -- Fall through if no match found. Note that the loops are skipped
268+ -- completely in the case of the pattern being longer than the source.
269+ return 0;
270+ end Index;
271+
272+ function Index
273+ (Source : String_32;
274+ Pattern : String_32;
275+ Going : Direction := Forward;
276+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
277+ return Natural
278+ is
279+ PL1 : constant Integer := Pattern'Length - 1;
280+ Ind : Natural;
281+ Cur : Natural;
282+ begin
283+ if Pattern'Length = 0 then
284+ raise Pattern_Error;
285+ end if;
286+ -- Check for null pointer in case checks are off
287+ if Mapping = null then
288+ raise Constraint_Error;
289+ end if;
290+ -- If Pattern longer than Source it can't be found
291+ if Pattern'Length > Source'Length then
292+ return 0;
293+ end if;
294+ -- Forwards case
295+ if Going = Forward then
296+ Ind := Source'First;
297+ for J in 1 .. Source'Length - PL1 loop
298+ Cur := Ind;
299+ for K in Pattern'Range loop
300+ if Pattern (K) /= Mapping.all (Source (Cur)) then
301+ goto Cont1;
302+ else
303+ Cur := Cur + 1;
304+ end if;
305+ end loop;
306+ return Ind;
307+ <<Cont1>>
308+ Ind := Ind + 1;
309+ end loop;
310+ -- Backwards case
311+ else
312+ Ind := Source'Last - PL1;
313+ for J in reverse 1 .. Source'Length - PL1 loop
314+ Cur := Ind;
315+ for K in Pattern'Range loop
316+ if Pattern (K) /= Mapping.all (Source (Cur)) then
317+ goto Cont2;
318+ else
319+ Cur := Cur + 1;
320+ end if;
321+ end loop;
322+ return Ind;
323+ <<Cont2>>
324+ Ind := Ind - 1;
325+ end loop;
326+ end if;
327+ -- Fall through if no match found. Note that the loops are skipped
328+ -- completely in the case of the pattern being longer than the source.
329+ return 0;
330+ end Index;
331+
332+ function Index
333+ (Source : String_32;
334+ Set : Wide_Wide_Maps.Character_32_Set;
335+ Test : Membership := Inside;
336+ Going : Direction := Forward) return Natural
337+ is
338+ begin
339+ -- Forwards case
340+ if Going = Forward then
341+ for J in Source'Range loop
342+ if Belongs (Source (J), Set, Test) then
343+ return J;
344+ end if;
345+ end loop;
346+ -- Backwards case
347+ else
348+ for J in reverse Source'Range loop
349+ if Belongs (Source (J), Set, Test) then
350+ return J;
351+ end if;
352+ end loop;
353+ end if;
354+ -- Fall through if no match
355+ return 0;
356+ end Index;
357+
358+ function Index
359+ (Source : String_32;
360+ Pattern : String_32;
361+ From : Positive;
362+ Going : Direction := Forward;
363+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
364+ Wide_Wide_Maps.Identity) return Natural
365+ is
366+ begin
367+ if Going = Forward then
368+ if From < Source'First then
369+ raise Index_Error;
370+ end if;
371+ return
372+ Index (Source (From .. Source'Last), Pattern, Forward, Mapping);
373+ else
374+ if From > Source'Last then
375+ raise Index_Error;
376+ end if;
377+ return
378+ Index (Source (Source'First .. From), Pattern, Backward, Mapping);
379+ end if;
380+ end Index;
381+
382+ function Index
383+ (Source : String_32;
384+ Pattern : String_32;
385+ From : Positive;
386+ Going : Direction := Forward;
387+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
388+ return Natural
389+ is
390+ begin
391+ if Going = Forward then
392+ if From < Source'First then
393+ raise Index_Error;
394+ end if;
395+ return Index
396+ (Source (From .. Source'Last), Pattern, Forward, Mapping);
397+ else
398+ if From > Source'Last then
399+ raise Index_Error;
400+ end if;
401+ return Index
402+ (Source (Source'First .. From), Pattern, Backward, Mapping);
403+ end if;
404+ end Index;
405+
406+ function Index
407+ (Source : String_32;
408+ Set : Wide_Wide_Maps.Character_32_Set;
409+ From : Positive;
410+ Test : Membership := Inside;
411+ Going : Direction := Forward) return Natural
412+ is
413+ begin
414+ if Going = Forward then
415+ if From < Source'First then
416+ raise Index_Error;
417+ end if;
418+ return
419+ Index (Source (From .. Source'Last), Set, Test, Forward);
420+ else
421+ if From > Source'Last then
422+ raise Index_Error;
423+ end if;
424+ return
425+ Index (Source (Source'First .. From), Set, Test, Backward);
426+ end if;
427+ end Index;
428+
429+ function Index_Non_Blank
430+ (Source : String_32;
431+ Going : Direction := Forward) return Natural
432+ is
433+ begin
434+ if Going = Forward then
435+ for J in Source'Range loop
436+ if Source (J) /= Character_32_Space then
437+ return J;
438+ end if;
439+ end loop;
440+ else -- Going = Backward
441+ for J in reverse Source'Range loop
442+ if Source (J) /= Character_32_Space then
443+ return J;
444+ end if;
445+ end loop;
446+ end if;
447+ -- Fall through if no match
448+ return 0;
449+ end Index_Non_Blank;
450+
451+ function Index_Non_Blank
452+ (Source : String_32;
453+ From : Positive;
454+ Going : Direction := Forward) return Natural
455+ is
456+ begin
457+ if Going = Forward then
458+ if From < Source'First then
459+ raise Index_Error;
460+ end if;
461+ return
462+ Index_Non_Blank (Source (From .. Source'Last), Forward);
463+ else
464+ if From > Source'Last then
465+ raise Index_Error;
466+ end if;
467+ return
468+ Index_Non_Blank (Source (Source'First .. From), Backward);
469+ end if;
470+ end Index_Non_Blank;
471+
472+
473+end Ada_Magic_Forward.Strings.Wide_Wide_Search;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/ada_magic_forward.strings.wide_wide_search.ads
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/Unbounded/ada_magic_forward.strings.wide_wide_search.ads Wed Oct 09 04:12:41 2019 +0400
@@ -0,0 +1,92 @@
1+
2+with Ada_Magic_Forward.Strings.Wide_Wide_Maps;
3+
4+package Ada_Magic_Forward.Strings.Wide_Wide_Search is
5+
6+ function Index
7+ (Source : String_32;
8+ Pattern : String_32;
9+ Going : Direction := Forward;
10+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
11+ Wide_Wide_Maps.Identity) return Natural;
12+
13+ function Index
14+ (Source : String_32;
15+ Pattern : String_32;
16+ Going : Direction := Forward;
17+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
18+ return Natural;
19+
20+ function Index
21+ (Source : String_32;
22+ Set : Wide_Wide_Maps.Character_32_Set;
23+ Test : Membership := Inside;
24+ Going : Direction := Forward) return Natural;
25+
26+ function Index
27+ (Source : String_32;
28+ Pattern : String_32;
29+ From : Positive;
30+ Going : Direction := Forward;
31+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
32+ Wide_Wide_Maps.Identity)
33+ return Natural;
34+
35+ function Index
36+ (Source : String_32;
37+ Pattern : String_32;
38+ From : Positive;
39+ Going : Direction := Forward;
40+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
41+ return Natural;
42+
43+ function Index
44+ (Source : String_32;
45+ Set : Wide_Wide_Maps.Character_32_Set;
46+ From : Positive;
47+ Test : Membership := Inside;
48+ Going : Direction := Forward) return Natural;
49+
50+ function Index_Non_Blank
51+ (Source : String_32;
52+ Going : Direction := Forward) return Natural;
53+
54+ function Index_Non_Blank
55+ (Source : String_32;
56+ From : Positive;
57+ Going : Direction := Forward) return Natural;
58+
59+ function Count
60+ (Source : String_32;
61+ Pattern : String_32;
62+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
63+ Wide_Wide_Maps.Identity)
64+ return Natural;
65+
66+ function Count
67+ (Source : String_32;
68+ Pattern : String_32;
69+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
70+ return Natural;
71+
72+ function Count
73+ (Source : String_32;
74+ Set : Wide_Wide_Maps.Character_32_Set) return Natural;
75+
76+ procedure Find_Token
77+ (Source : String_32;
78+ Set : Wide_Wide_Maps.Character_32_Set;
79+ From : Positive;
80+ Test : Membership;
81+ First : out Positive;
82+ Last : out Natural);
83+
84+ procedure Find_Token
85+ (Source : String_32;
86+ Set : Wide_Wide_Maps.Character_32_Set;
87+ Test : Membership;
88+ First : out Positive;
89+ Last : out Natural);
90+
91+
92+end Ada_Magic_Forward.Strings.Wide_Wide_Search;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/unbounded_array.adb
--- a/Unbounded/unbounded_array.adb Sun Oct 06 14:03:50 2019 +0400
+++ b/Unbounded/unbounded_array.adb Wed Oct 09 04:12:41 2019 +0400
@@ -1,3 +1,9 @@
1+
2+with System; use System;
3+with Ada_Magic_Forward.Strings.Wide_Wide_Search;
4+use Ada_Magic_Forward.Strings.Wide_Wide_Search;
5+with Ada_Magic_Forward.Strings; use Ada_Magic_Forward.Strings;
6+
17 package body Unbounded_Array is
28
39 Growth_Factor : constant := 2;
@@ -48,15 +54,13 @@
4854 end if;
4955 Decrement (Aux.Counter, Release);
5056 if Release then
51- -- Reference counter of Empty_Referenced_Buffer should never reach
52- -- zero. We check here in case it wraps around.
53--- if Aux /= Empty_Referenced_Buffer'Access then
54- if not Is_One(Aux.Lock_Counter) then
55- Raise_Exception(Buffer_Locked'Identity,
56- "Buffer is locked for change");
57- end if;
58- Free (Aux);
59--- end if;
57+ -- Reference counter of Empty_Referenced_Buffer should never reach
58+ -- zero. We check here in case it wraps around.
59+ if not Is_One(Aux.Lock_Counter) then
60+ Raise_Exception(Buffer_Locked'Identity,
61+ "Buffer is locked for change");
62+ end if;
63+ Free (Aux);
6064 end if;
6165 end Unreference;
6266
@@ -80,7 +84,7 @@
8084 Raise_Exception(Buffer_Locked'Identity,
8185 "Buffer is locked for change");
8286 end if;
83- if RB.UTF32 and then RB.Last rem 4 /= 0 then
87+ if RB.Codec = Utf32 and then RB.Last rem 4 /= 0 then
8488 Raise_Exception(Illegal_Unicode'Identity,
8589 "Illegal UNICODE length");
8690 end if;
@@ -219,7 +223,7 @@
219223 TA := Source;
220224 end if;
221225 end;
222- DR.UTF32 := True;
226+ DR.Codec := Utf32;
223227 DR.Last := DL;
224228 return (AF.Controlled with Reference => DR);
225229 end To_Unbounded_Array;
@@ -352,7 +356,7 @@
352356 if SL = 0 then
353357 return Null_String_32;
354358 end if;
355- if not SR.UTF32 then
359+ if SR.Codec /= Utf32 then
356360 Raise_Exception(Illegal_Unicode'Identity,
357361 "Source is not UNICODE");
358362 end if;
@@ -412,7 +416,7 @@
412416 Raise_Exception(Buffer_Locked'Identity,
413417 "Buffer is locked for change");
414418 end if;
415- if SR.UTF32 then
419+ if SR.Codec /= Utf16 then
416420 Raise_Exception(Illegal_Unicode'Identity,
417421 "Have not support operation for operand`s types");
418422 end if;
@@ -458,7 +462,7 @@
458462 Raise_Exception(Buffer_Locked'Identity,
459463 "Buffer is locked for change");
460464 end if;
461- if SR.UTF32 then
465+ if SR.Codec /= Utf8 then
462466 Raise_Exception(Illegal_Unicode'Identity,
463467 "Have not support operation for operand`s types");
464468 end if;
@@ -498,8 +502,8 @@
498502 Raise_Exception(Buffer_Locked'Identity,
499503 "Buffer is locked for change");
500504 end if;
501- if (LR.UTF32 and then not RR.UTF32)
502- or else (RR.UTF32 and then not LR.UTF32)
505+ if (LR.Codec = Utf32 and then RR.Codec /= Utf32)
506+ or else (RR.Codec = Utf32 and then LR.Codec /= Utf32)
503507 then
504508 Raise_Exception(Illegal_Unicode'Identity,
505509 "Can`t concatenate Unicode and non Unicode strings");
@@ -514,7 +518,7 @@
514518 elsif RR.Last = 0 then
515519 Reference (LR);
516520 DR := LR;
517- elsif LR.UTF32 and then RR.UTF32 then
521+ elsif LR.Codec = Utf32 and then RR.Codec = Utf32 then
518522 if LR.Last rem 4 /= 0 or else RR.Last rem 4 /= 0 then
519523 Raise_Exception(Illegal_Unicode'Identity,
520524 "Illegal UNICODE length");
@@ -559,7 +563,7 @@
559563 Result_Array(RI .. RI + LL - 1) := LA;
560564 RI := RI + LL;
561565 Result_Array(RI .. RI + RL - SR) := RA(SR .. RL);
562- DR.UTF32 := True;
566+ DR.Codec := Utf32;
563567 DR.Last := 4 * Result_Length;
564568 end;
565569 end;
@@ -585,11 +589,7 @@
585589 Raise_Exception(Buffer_Locked'Identity,
586590 "Buffer is locked for change");
587591 end if;
588- if LR.UTF32 then
589- Raise_Exception(Illegal_Unicode'Identity,
590- "Have not support concatenate for operand`s types");
591- end if;
592- if LR.UTF32 then
592+ if LR.Codec /= Utf8 then
593593 Raise_Exception(Illegal_Unicode'Identity,
594594 "Have not support concatenate for operand`s types");
595595 end if;
@@ -617,7 +617,7 @@
617617 LR : constant Referenced_Buffer_Access := Left.Reference;
618618 DR : Referenced_Buffer_Access;
619619 begin
620- if not LR.UTF32 then
620+ if LR.Codec /= Utf32 then
621621 Raise_Exception(Illegal_Unicode'Identity,
622622 "Have not support concatenate for operand`s types");
623623 end if;
@@ -669,7 +669,7 @@
669669 RI := RI + LL;
670670 RSA(RI .. Result_Length) := Right(SR .. Right'Last);
671671 DR.Last := 4 * Result_Length;
672- DR.UTF32 := True;
672+ DR.Codec := Utf32;
673673 end;
674674 end;
675675 end if;
@@ -700,7 +700,7 @@
700700 Raise_Exception(Buffer_Locked'Identity,
701701 "Buffer is locked for change");
702702 end if;
703- if RR.UTF32 then
703+ if RR.Codec /= Utf8 then
704704 Raise_Exception(Illegal_Unicode'Identity,
705705 "Have not support concatenate for operand`s types");
706706 end if;
@@ -745,7 +745,7 @@
745745 Raise_Exception(Buffer_Locked'Identity,
746746 "Buffer is locked for change");
747747 end if;
748- if LR.UTF32 then
748+ if LR.Codec /= Utf8 then
749749 Raise_Exception(Illegal_Unicode'Identity,
750750 "Have not support concatenate for operand`s types");
751751 end if;
@@ -776,7 +776,7 @@
776776 Raise_Exception(Buffer_Locked'Identity,
777777 "Buffer is locked for change");
778778 end if;
779- if RR.UTF32 then
779+ if RR.Codec /= Utf8 then
780780 Raise_Exception(Illegal_Unicode'Identity,
781781 "Have not support concatenate for operand`s types");
782782 end if;
@@ -804,7 +804,7 @@
804804 if Index <= SR.Last then
805805 return SR.Data (Index);
806806 else
807- raise Array_Index_Error;
807+ raise Index_Error;
808808 end if;
809809 end Element;
810810
@@ -826,7 +826,7 @@
826826 begin
827827 -- Note: test of High > Length is in accordance with AI95-00128
828828 if Low > SR.Last + 1 or else High > SR.Last then
829- raise Array_Index_Error;
829+ raise Index_Error;
830830 else
831831 return SR.Data (Low .. High);
832832 end if;
@@ -857,7 +857,7 @@
857857 begin
858858 -- Check bounds
859859 if Low > SR.Last + 1 or else High > SR.Last then
860- raise Array_Index_Error;
860+ raise Index_Error;
861861 -- Result is empty slice, reuse empty shared string
862862 elsif Low > High then
863863 DR := Empty_Referenced_Buffer'Access;
@@ -885,13 +885,13 @@
885885 Raise_Exception(Buffer_Locked'Identity,
886886 "Buffer is locked for change");
887887 end if;
888- if SR.UTF32 then
888+ if SR.Codec /= Utf8 then
889889 Raise_Exception(Illegal_Unicode'Identity,
890890 "Have not support operation for operand`s types");
891891 end if;
892892 -- Check bounds
893893 if Low > SR.Last + 1 then
894- raise Array_Index_Error;
894+ raise Index_Error;
895895 end if;
896896 -- Do replace operation when removed slice is not empty
897897 if High >= Low then
@@ -929,13 +929,13 @@
929929 Raise_Exception(Buffer_Locked'Identity,
930930 "Buffer is locked for change");
931931 end if;
932- if SR.UTF32 then
932+ if SR.Codec /= Utf8 then
933933 Raise_Exception(Illegal_Unicode'Identity,
934934 "Have not support operation for operand`s types");
935935 end if;
936936 -- Check index first
937937 if Before > SR.Last + 1 then
938- raise Array_Index_Error;
938+ raise Index_Error;
939939 end if;
940940 -- Result is empty, reuse empty shared string
941941 if DL = 0 then
@@ -977,7 +977,7 @@
977977 end if;
978978 -- Check bounds
979979 if Low > SR.Last + 1 or else High > SR.Last then
980- Raise_Exception(Array_Index_Error'Identity,
980+ Raise_Exception(Index_Error'Identity,
981981 "Illegal position values");
982982 end if;
983983 DL := High - Low + 1;
@@ -1015,13 +1015,13 @@
10151015 Raise_Exception(Buffer_Locked'Identity,
10161016 "Buffer is locked for change");
10171017 end if;
1018- if SR.UTF32 then
1018+ if SR.Codec /= Utf8 then
10191019 Raise_Exception(Illegal_Unicode'Identity,
10201020 "Have not support operation for operand`s types");
10211021 end if;
10221022 -- Check bounds
10231023 if Before > SR.Last + 1 then
1024- raise Array_Index_Error;
1024+ raise Index_Error;
10251025 end if;
10261026 -- Result is empty string, reuse empty shared string
10271027 if DL = 0 then
@@ -1116,13 +1116,13 @@
11161116 Raise_Exception(Buffer_Locked'Identity,
11171117 "Buffer is locked for change");
11181118 end if;
1119- if SR.UTF32 then
1119+ if SR.Codec /= Utf8 then
11201120 Raise_Exception(Illegal_Unicode'Identity,
11211121 "Have not support operation for operand`s types");
11221122 end if;
11231123 -- Check bounds
11241124 if Position > SR.Last + 1 then
1125- raise Array_Index_Error;
1125+ raise Index_Error;
11261126 end if;
11271127 DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
11281128 -- Result is empty string, reuse empty shared string
@@ -1170,13 +1170,13 @@
11701170 Raise_Exception(Buffer_Locked'Identity,
11711171 "Buffer is locked for change");
11721172 end if;
1173- if SR.UTF32 then
1173+ if SR.Codec /= Utf8 then
11741174 Raise_Exception(Illegal_Unicode'Identity,
11751175 "Have not support operation for operand`s types");
11761176 end if;
11771177 -- Bounds check
11781178 if Position > SR.Last + 1 then
1179- raise Array_Index_Error;
1179+ raise Index_Error;
11801180 end if;
11811181 DL := Integer'Max (SR.Last, Position + New_Item'Length - 1);
11821182 -- Result is empty string, reuse empty shared string
@@ -1298,7 +1298,7 @@
12981298 DR := Empty_Referenced_Buffer'Access;
12991299 -- Coefficient is one, just return string itself
13001300 elsif Left = 1 then
1301- if RR.UTF32 then
1301+ if RR.Codec = Utf32 then
13021302 if RR.Last rem 4 /= 0 then
13031303 Raise_Exception(Illegal_Unicode'Identity,
13041304 "Illegal UNICODE length");
@@ -1308,7 +1308,7 @@
13081308 DR := RR;
13091309 -- Otherwise, allocate new shared string and fill it
13101310 else
1311- if RR.UTF32 then
1311+ if RR.Codec = Utf32 then
13121312 if RR.Last rem 4 /= 0 then
13131313 Raise_Exception(Illegal_Unicode'Identity,
13141314 "Illegal UNICODE length");
@@ -1332,7 +1332,7 @@
13321332 K := K + RR.Last;
13331333 end loop;
13341334 end if;
1335- DR.UTF32 := True;
1335+ DR.Codec := Utf32;
13361336 else
13371337 DR := Allocate (DL);
13381338 K := 1;
@@ -1346,19 +1346,19 @@
13461346 return (AF.Controlled with Reference => DR);
13471347 end "*";
13481348
1349- procedure From_Utf8_To_Utf32 (Utf32 : in out Unbounded_Array_Type;
1350- Utf8 : Array_Of_Byte_Type;
1351- BOM : Boolean := False)
1349+ procedure From_Utf8_To_Utf32 (Utf32S : in out Unbounded_Array_Type;
1350+ Utf8S : Array_Of_Byte_Type;
1351+ BOM : Boolean := False)
13521352 is
1353- TR : Referenced_Buffer_Access := Utf32.Reference;
1353+ TR : Referenced_Buffer_Access := Utf32S.Reference;
13541354 DL : Natural := 0;
13551355 DR : Referenced_Buffer_Access;
1356- IL : Natural := Utf8'Length;
1356+ IL : Natural := Utf8S'Length;
13571357 UL : Natural := 0;
1358- OP : Natural := 1;
1359- SI : Natural := 1;
1360- Position : Natural := Utf8'First;
1361- Last : Natural := Utf8'Last;
1358+ OP : Positive := 1;
1359+ SI : Positive := 1;
1360+ Position : Positive := Utf8S'First;
1361+ Last : Positive := Utf8S'Last;
13621362 Byte1, Byte2, Byte3, Byte4 : Byte_Type;
13631363 Unicode_Symbol, Aux_Symbol : Character_32'Base;
13641364 BE : constant Boolean := (Default_Bit_Order = High_Order_First);
@@ -1377,7 +1377,7 @@
13771377 end if;
13781378 if IL >= 4 then
13791379 declare
1380- Sub_Array : Array_Of_Byte_Type := Utf8(Position .. Position + 3);
1380+ Sub_Array : Array_Of_Byte_Type := Utf8S(Position .. Position + 3);
13811381 begin
13821382 if Sub_Array = BOM32LE or else Sub_Array = BOM32BE then
13831383 Raise_Exception(Illegal_Input'Identity,
@@ -1387,7 +1387,7 @@
13871387 end if;
13881388 if IL >= 3 then
13891389 declare
1390- Sub_Array : Array_Of_Byte_Type := Utf8(Position .. Position + 2);
1390+ Sub_Array : Array_Of_Byte_Type := Utf8S(Position .. Position + 2);
13911391 begin
13921392 if Sub_Array = BOM8 then
13931393 if not BOM then
@@ -1407,7 +1407,7 @@
14071407 end;
14081408 elsif IL >= 2 then
14091409 declare
1410- Sub_Array : Array_Of_Byte_Type := Utf8(Position .. Position + 1);
1410+ Sub_Array : Array_Of_Byte_Type := Utf8S(Position .. Position + 1);
14111411 begin
14121412 if Sub_Array = BOM16LE or else Sub_Array = BOM16BE then
14131413 Raise_Exception(Illegal_Input'Identity,
@@ -1416,7 +1416,7 @@
14161416 end;
14171417 end if;
14181418 while Position <= Last loop
1419- Byte1 := Utf8(Position);
1419+ Byte1 := Utf8S(Position);
14201420 Position := Position + 1;
14211421 if Byte1 < 128 then
14221422 DL := DL + 4;
@@ -1427,19 +1427,19 @@
14271427 Raise_Exception(Illegal_Input'Identity,
14281428 "Illegal length of symbol");
14291429 end if;
1430- Byte2 := Utf8(Position);
1430+ Byte2 := Utf8S(Position);
14311431 if (Byte2 and Mask_First) /= Mask_Next then
14321432 Raise_Exception(Illegal_Input'Identity,
14331433 "Illegal second byte of symbol");
14341434 end if;
14351435 Position := Position + 1;
1436- Byte3 := Utf8(Position);
1436+ Byte3 := Utf8S(Position);
14371437 if (Byte3 and Mask_First) /= Mask_Next then
14381438 Raise_Exception(Illegal_Input'Identity,
14391439 "Illegal third byte of symbol");
14401440 end if;
14411441 Position := Position + 1;
1442- Byte4 := Utf8(Position);
1442+ Byte4 := Utf8S(Position);
14431443 if (Byte4 and Mask_First) /= Mask_Next then
14441444 Raise_Exception(Illegal_Input'Identity,
14451445 "Illegal fourth byte of symbol");
@@ -1459,13 +1459,13 @@
14591459 Raise_Exception(Illegal_Input'Identity,
14601460 "Illegal length of symbol");
14611461 end if;
1462- Byte2 := Utf8(Position);
1462+ Byte2 := Utf8S(Position);
14631463 if (Byte2 and Mask_First) /= Mask_Next then
14641464 Raise_Exception(Illegal_Input'Identity,
14651465 "Illegal second byte of symbol");
14661466 end if;
14671467 Position := Position + 1;
1468- Byte3 := Utf8(Position);
1468+ Byte3 := Utf8S(Position);
14691469 if (Byte3 and Mask_First) /= Mask_Next then
14701470 Raise_Exception(Illegal_Input'Identity,
14711471 "Illegal third byte of symbol");
@@ -1483,7 +1483,7 @@
14831483 Raise_Exception(Illegal_Input'Identity,
14841484 "Illegal length of symbol");
14851485 end if;
1486- Byte2 := Utf8(Position);
1486+ Byte2 := Utf8S(Position);
14871487 if (Byte2 and Mask_First) /= Mask_Next then
14881488 Raise_Exception(Illegal_Input'Identity,
14891489 "Illegal second byte of symbol");
@@ -1510,6 +1510,7 @@
15101510 end if;
15111511 end loop;
15121512 <<Fill_Array>>
1513+ Position := Utf8S'First;
15131514 -- Try to reuse existing shared string
15141515 if Can_Be_Reused (TR, DL) then
15151516 Reference (TR);
@@ -1517,11 +1518,10 @@
15171518 -- Otherwise allocate new shared string
15181519 else
15191520 DR := Allocate (DL);
1520- Utf32.Reference := DR;
1521+ Utf32S.Reference := DR;
15211522 end if;
15221523 DR.Last := DL;
1523- DR.UTF32 := True;
1524- Position := Utf8'First;
1524+ DR.Codec := Utf32;
15251525 if BOM then
15261526 if BE then
15271527 for J in BOM32BE'Range loop
@@ -1538,7 +1538,7 @@
15381538 end if;
15391539 if IL >= 3 then
15401540 declare
1541- Sub_Array : Array_Of_Byte_Type := Utf8(Position .. Position + 2);
1541+ Sub_Array : Array_Of_Byte_Type := Utf8S(Position .. Position + 2);
15421542 begin
15431543 if Sub_Array = BOM8 then
15441544 if not BOM then
@@ -1559,7 +1559,7 @@
15591559 end;
15601560 end if;
15611561 for I in SI .. UL loop
1562- Byte1 := Utf8(Position);
1562+ Byte1 := Utf8S(Position);
15631563 Position := Position + 1;
15641564 if Byte1 < 128 then
15651565 if BE then
@@ -1583,11 +1583,11 @@
15831583 end if;
15841584 else
15851585 if (Byte1 and 2#11111000#) = 2#11110000# then
1586- Byte2 := Utf8(Position);
1586+ Byte2 := Utf8S(Position);
15871587 Position := Position + 1;
1588- Byte3 := Utf8(Position);
1588+ Byte3 := Utf8S(Position);
15891589 Position := Position + 1;
1590- Byte4 := Utf8(Position);
1590+ Byte4 := Utf8S(Position);
15911591 Position := Position + 1;
15921592 Unicode_Symbol := Character_32'Base(Byte4 and Value_Mask);
15931593 Aux_Symbol := Character_32'Base(Byte3 and Value_Mask);
@@ -1600,9 +1600,9 @@
16001600 Aux_Symbol := Shift_Left(Aux_Symbol, 18);
16011601 Unicode_Symbol := Unicode_Symbol or Aux_Symbol;
16021602 elsif (Byte1 and 2#11110000#) = 2#11100000# then
1603- Byte2 := Utf8(Position);
1603+ Byte2 := Utf8S(Position);
16041604 Position := Position + 1;
1605- Byte3 := Utf8(Position);
1605+ Byte3 := Utf8S(Position);
16061606 Position := Position + 1;
16071607 Unicode_Symbol := Character_32'Base(Byte3 and Value_Mask);
16081608 Aux_Symbol := Character_32'Base(Byte2 and Value_Mask);
@@ -1612,7 +1612,7 @@
16121612 Aux_Symbol := Shift_Left(Aux_Symbol, 12);
16131613 Unicode_Symbol := Unicode_Symbol or Aux_Symbol;
16141614 else
1615- Byte2 := Utf8(Position);
1615+ Byte2 := Utf8S(Position);
16161616 Position := Position + 1;
16171617 Unicode_Symbol := Character_32'Base(Byte2 and Value_Mask);
16181618 Aux_Symbol := Character_32'Base(Byte1 and 2#00011111#);
@@ -1655,35 +1655,35 @@
16551655 Unreference(TR);
16561656 end From_Utf8_To_Utf32;
16571657
1658- procedure From_Utf8_To_Utf32 (Utf32 : in out Unbounded_Array_Type;
1659- Utf8 : String;
1660- BOM : Boolean := False)
1658+ procedure From_Utf8_To_Utf32 (Utf32S : in out Unbounded_Array_Type;
1659+ Utf8S : String;
1660+ BOM : Boolean := False)
16611661 is
1662- subtype Bounded_Array is Array_Of_Byte_Type(1 .. Utf8'Length);
1662+ subtype Bounded_Array is Array_Of_Byte_Type(1 .. Utf8S'Length);
16631663 package TP is new ATOAC(Bounded_Array);
16641664 Input_Ptr : TP.Object_Pointer :=
1665- TP.To_Pointer(Utf8(Utf8'First)'Address);
1665+ TP.To_Pointer(Utf8S(Utf8S'First)'Address);
16661666 begin
1667- From_Utf8_To_Utf32( Utf32, Input_Ptr.all, BOM );
1667+ From_Utf8_To_Utf32( Utf32S, Input_Ptr.all, BOM );
16681668 end From_Utf8_To_Utf32;
16691669
16701670 function Is_Utf32 (Object : Unbounded_Array_Type) return Boolean
16711671 is
16721672 begin
1673- return Object.Reference.UTF32;
1673+ return Object.Reference.Codec = Utf32;
16741674 end Is_Utf32;
16751675
1676- procedure From_Utf32_To_Utf8 (Utf8 : in out Unbounded_Array_Type;
1677- Utf32 : String_32;
1676+ procedure From_Utf32_To_Utf8 (Utf8S : in out Unbounded_Array_Type;
1677+ Utf32S : String_32;
16781678 BOM, SkipBOM : Boolean := False)
16791679 is
1680- TR : Referenced_Buffer_Access := Utf8.Reference;
1680+ TR : Referenced_Buffer_Access := Utf8S.Reference;
16811681 DR : Referenced_Buffer_Access;
16821682 DL : Natural := 0;
1683- SL : Natural := Utf32'Length;
1683+ SL : Natural := Utf32S'Length;
16841684 SI : Positive;
16851685 DI : Positive := 1;
1686- Last : Natural := Utf32'Last;
1686+ Last : Natural := Utf32S'Last;
16871687 BOMV : Boolean := BOM;
16881688 Word1, Word2 : Character_32'Base;
16891689 Byte1, Byte2, Byte3, Byte4 : Byte_Type := 0;
@@ -1693,7 +1693,7 @@
16931693 "Buffer is locked for change");
16941694 end if;
16951695 if SL = 0 and then not BOMV then
1696- Utf8.Reference := Empty_Referenced_Buffer'Access;
1696+ Utf8S.Reference := Empty_Referenced_Buffer'Access;
16971697 Unreference (TR);
16981698 return;
16991699 end if;
@@ -1703,18 +1703,18 @@
17031703 if SL = 0 then
17041704 goto Fill_Data;
17051705 end if;
1706- if Utf32(Utf32'First) = BOM32 then
1707- SI := Utf32'First + 1;
1706+ if Utf32S(Utf32S'First) = BOM32 then
1707+ SI := Utf32S'First + 1;
17081708 SL := SL - 1;
17091709 if not BOMV and then not SkipBOM then
17101710 DL := 3;
17111711 BOMV := True;
17121712 end if;
17131713 else
1714- SI := Utf32'First;
1714+ SI := Utf32S'First;
17151715 end if;
17161716 for I in SI .. Last loop
1717- Word1 := Utf32(I);
1717+ Word1 := Utf32S(I);
17181718 if Word1 = BOM32 then
17191719 Raise_Exception(Illegal_Unicode'Identity,
17201720 "Illegal position of BOM");
@@ -1735,7 +1735,7 @@
17351735 end loop;
17361736 <<Fill_Data>>
17371737 if SL = 0 and then not BOMV then
1738- Utf8.Reference := Empty_Referenced_Buffer'Access;
1738+ Utf8S.Reference := Empty_Referenced_Buffer'Access;
17391739 Unreference (TR);
17401740 return;
17411741 end if;
@@ -1746,14 +1746,14 @@
17461746 -- Otherwise allocate new shared string
17471747 else
17481748 DR := Allocate (DL);
1749- Utf8.Reference := DR;
1749+ Utf8S.Reference := DR;
17501750 end if;
17511751 if BOMV then
17521752 DR.Data(1 .. 3) := BOM8;
17531753 DI := 4;
17541754 end if;
17551755 for I in SI .. Last loop
1756- Word1 := Utf32(I);
1756+ Word1 := Utf32S(I);
17571757 if Word1 < 128 then
17581758 DR.Data(DI) := Byte_Type(Word1);
17591759 DI := DI + 1;
@@ -1805,7 +1805,7 @@
18051805 end if;
18061806 end loop;
18071807 DR.Last := DL;
1808- DR.UTF32 := False;
1808+ DR.Codec := Utf8;
18091809 Unreference (TR);
18101810 end From_Utf32_To_Utf8;
18111811
@@ -1837,7 +1837,7 @@
18371837 LL : Natural := Left'Length;
18381838 DR : Referenced_Buffer_Access;
18391839 begin
1840- if not RR.UTF32 then
1840+ if RR.Codec /= Utf32 then
18411841 Raise_Exception(Illegal_Unicode'Identity,
18421842 "Have not support concatenate for operand`s types");
18431843 end if;
@@ -1888,7 +1888,7 @@
18881888 RI := RI + LL;
18891889 RSA(RI .. DL) := RA(SR .. RL);
18901890 DR.Last := 4 * DL;
1891- DR.UTF32 := True;
1891+ DR.Codec := Utf32;
18921892 end;
18931893 end;
18941894 end if;
@@ -1902,7 +1902,7 @@
19021902 LR : Referenced_Buffer_Access := Left.Reference;
19031903 DR : Referenced_Buffer_Access;
19041904 begin
1905- if not LR.UTF32 then
1905+ if LR.Codec /= Utf32 then
19061906 Raise_Exception(Illegal_Unicode'Identity,
19071907 "Have not support concatenate for operand`s types");
19081908 end if;
@@ -1952,7 +1952,7 @@
19521952 DA(DL) := Right;
19531953 end if;
19541954 DR.Last := 4 * DL;
1955- DR.UTF32 := True;
1955+ DR.Codec := Utf32;
19561956 end;
19571957 end;
19581958 return (AF.Controlled with Reference => DR);
@@ -1965,7 +1965,7 @@
19651965 RR : Referenced_Buffer_Access := Right.Reference;
19661966 DR : Referenced_Buffer_Access;
19671967 begin
1968- if not RR.UTF32 then
1968+ if RR.Codec /= Utf32 then
19691969 Raise_Exception(Illegal_Unicode'Identity,
19701970 "Have not support concatenate for operand`s types");
19711971 end if;
@@ -2016,7 +2016,7 @@
20162016 DA(2 .. DL) := RA;
20172017 end if;
20182018 DR.Last := 4*DL;
2019- DR.UTF32 := True;
2019+ DR.Codec := Utf32;
20202020 end;
20212021 end;
20222022 return (AF.Controlled with Reference => DR);
@@ -2028,7 +2028,7 @@
20282028 is
20292029 SR : Referenced_Buffer_Access := Source.Reference;
20302030 begin
2031- if not SR.UTF32 then
2031+ if SR.Codec /= Utf32 then
20322032 Raise_Exception(Illegal_Unicode'Identity,
20332033 "Have not support operation for operand`s types");
20342034 end if;
@@ -2045,7 +2045,7 @@
20452045 SA : SM renames Source_Ptr.all;
20462046 begin
20472047 if Index > SL then
2048- Raise_Exception(Array_Index_Error'Identity,
2048+ Raise_Exception(Index_Error'Identity,
20492049 "Illegal index value");
20502050 end if;
20512051 return SA(Index);
@@ -2059,7 +2059,7 @@
20592059 is
20602060 SR : constant Referenced_Buffer_Access := Source.Reference;
20612061 begin
2062- if not SR.UTF32 then
2062+ if SR.Codec /= Utf32 then
20632063 Raise_Exception(Illegal_Unicode'Identity,
20642064 "Have not support operation for operand`s types");
20652065 end if;
@@ -2076,7 +2076,7 @@
20762076 SA : SM renames Source_Ptr.all;
20772077 begin
20782078 if Low > SL + 1 or else High > SL then
2079- Raise_Exception(Array_Index_Error'Identity,
2079+ Raise_Exception(Index_Error'Identity,
20802080 "Illegal position values");
20812081 end if;
20822082 return SA(Low .. High);
@@ -2092,7 +2092,7 @@
20922092 DL : Natural;
20932093 DR : Referenced_Buffer_Access;
20942094 begin
2095- if not SR.UTF32 then
2095+ if SR.Codec /= Utf32 then
20962096 Raise_Exception(Illegal_Unicode'Identity,
20972097 "Have not support operation for operand`s types");
20982098 end if;
@@ -2113,7 +2113,7 @@
21132113 SA : SM renames Source_Ptr.all;
21142114 begin
21152115 if Low > SL + 1 or else High > SL then
2116- Raise_Exception(Array_Index_Error'Identity,
2116+ Raise_Exception(Index_Error'Identity,
21172117 "Illegal position values");
21182118 end if;
21192119 DL := High - Low + 1;
@@ -2127,7 +2127,7 @@
21272127 begin
21282128 RA := SA(Low .. High);
21292129 DR.Last := 4*DL;
2130- DR.UTF32 := True;
2130+ DR.Codec := Utf32;
21312131 end;
21322132 end;
21332133 return (AF.Controlled with Reference => DR);
@@ -2152,7 +2152,7 @@
21522152 Raise_Exception(Buffer_Locked'Identity,
21532153 "Buffer is locked for change");
21542154 end if;
2155- if not SR.UTF32 then
2155+ if SR.Codec /= Utf32 then
21562156 Raise_Exception(Illegal_Unicode'Identity,
21572157 "Have not support operation for operand`s types");
21582158 end if;
@@ -2169,7 +2169,7 @@
21692169 SA : SM renames Source_Ptr.all;
21702170 begin
21712171 if Low > SL + 1 or else High > SL then
2172- Raise_Exception(Array_Index_Error'Identity,
2172+ Raise_Exception(Index_Error'Identity,
21732173 "Illegal position values");
21742174 end if;
21752175 DL := High - Low + 1;
@@ -2186,7 +2186,7 @@
21862186 begin
21872187 DA := SA(Low .. High);
21882188 DR.Last := 4*DL;
2189- DR.UTF32 := True;
2189+ DR.Codec := Utf32;
21902190 return;
21912191 end;
21922192 end if;
@@ -2206,7 +2206,7 @@
22062206 begin
22072207 DA := SA(Low .. High);
22082208 DR.Last := 4*DL;
2209- DR.UTF32 := True;
2209+ DR.Codec := Utf32;
22102210 end;
22112211 end;
22122212 Unreference (TR);
@@ -2229,7 +2229,7 @@
22292229 Raise_Exception(Buffer_Locked'Identity,
22302230 "Buffer is locked for change");
22312231 end if;
2232- if not SR.UTF32 then
2232+ if SR.Codec /= Utf32 then
22332233 Raise_Exception(Illegal_Unicode'Identity,
22342234 "Have not support operation for operand`s types");
22352235 end if;
@@ -2252,7 +2252,7 @@
22522252 begin
22532253 -- Check index first
22542254 if Before > SL + 1 then
2255- Raise_Exception(Array_Index_Error'Identity,
2255+ Raise_Exception(Index_Error'Identity,
22562256 "Illegal position values");
22572257 end if;
22582258 DL := SL + NL;
@@ -2285,7 +2285,7 @@
22852285 DA(Before + NL .. DL) := SA(Before .. SL);
22862286 end;
22872287 DR.Last := 4*DL;
2288- DR.UTF32 := True;
2288+ DR.Codec := Utf32;
22892289 end if;
22902290 end;
22912291 return (AF.Controlled with Reference => DR);
@@ -2311,13 +2311,13 @@
23112311 if NR.Last = 0 then
23122312 return;
23132313 end if;
2314- if (SR.UTF32 and then not NR.UTF32)
2315- or else (not SR.UTF32 and then NR.UTF32)
2314+ if (SR.Codec = Utf32 and then NR.Codec /= Utf32)
2315+ or else (SR.Codec /= Utf32 and then NR.Codec = Utf32)
23162316 then
23172317 Raise_Exception(Illegal_Unicode'Identity,
23182318 "Have not support operation for operand`s types");
23192319 end if;
2320- if SR.UTF32 then
2320+ if SR.Codec = Utf32 then
23212321 if SR.Last rem 4 /= 0 or else NR.Last rem 4 /= 0 then
23222322 Raise_Exception(Illegal_Unicode'Identity,
23232323 "Illegal buffer length");
@@ -2380,7 +2380,7 @@
23802380 end if;
23812381 Source.Reference := DR;
23822382 DR.Last := 4*DL;
2383- DR.UTF32 := True;
2383+ DR.Codec := Utf32;
23842384 Unreference(SR);
23852385 end;
23862386 end;
@@ -2420,7 +2420,7 @@
24202420 Raise_Exception(Buffer_Locked'Identity,
24212421 "Buffer is locked for change");
24222422 end if;
2423- if not SR.UTF32 then
2423+ if SR.Codec /= Utf32 then
24242424 Raise_Exception(Illegal_Unicode'Identity,
24252425 "Have not support operation for operand`s types");
24262426 end if;
@@ -2489,7 +2489,7 @@
24892489 end if;
24902490 end if;
24912491 DR.Last := 4*DL;
2492- DR.UTF32 := True;
2492+ DR.Codec := Utf32;
24932493 Source.Reference := DR;
24942494 Unreference(SR);
24952495 end;
@@ -2509,7 +2509,7 @@
25092509 Raise_Exception(Buffer_Locked'Identity,
25102510 "Buffer is locked for change");
25112511 end if;
2512- if not SR.UTF32 then
2512+ if SR.Codec /= Utf32 then
25132513 Raise_Exception(Illegal_Unicode'Identity,
25142514 "Have not support operation for operand`s types");
25152515 end if;
@@ -2563,7 +2563,7 @@
25632563 DA(DL) := New_Item;
25642564 end if;
25652565 DR.Last := 4*DL;
2566- DR.UTF32 := True;
2566+ DR.Codec := Utf32;
25672567 Source.Reference := DR;
25682568 Unreference(SR);
25692569 end;
@@ -2593,12 +2593,12 @@
25932593 DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last);
25942594 DR.Data (Index) := By;
25952595 DR.Last := SR.Last;
2596- DR.UTF32 := SR.UTF32;
2596+ DR.Codec := SR.Codec;
25972597 Source.Reference := DR;
25982598 Unreference (SR);
25992599 end if;
26002600 else
2601- Raise_Exception(Array_Index_Error'Identity,
2601+ Raise_Exception(Index_Error'Identity,
26022602 "Illegal position values");
26032603 end if;
26042604 end Replace_Element;
@@ -2615,7 +2615,7 @@
26152615 Raise_Exception(Buffer_Locked'Identity,
26162616 "Buffer is locked for change");
26172617 end if;
2618- if not SR.UTF32 then
2618+ if SR.Codec /= Utf32 then
26192619 Raise_Exception(Illegal_Unicode'Identity,
26202620 "Have not support operation for operand`s types");
26212621 end if;
@@ -2636,7 +2636,7 @@
26362636 SA : SM renames Source_Ptr.all;
26372637 begin
26382638 if Index > SL then
2639- Raise_Exception(Array_Index_Error'Identity,
2639+ Raise_Exception(Index_Error'Identity,
26402640 "Illegal index value");
26412641 end if;
26422642 if Can_Be_Reused(SR, 4*SL) then
@@ -2651,7 +2651,7 @@
26512651 DA := SA;
26522652 DA(Index) := By;
26532653 DR.Last := 4*SL;
2654- DR.UTF32 := True;
2654+ DR.Codec := Utf32;
26552655 Source.Reference := DR;
26562656 Unreference(SR);
26572657 end;
@@ -2673,13 +2673,13 @@
26732673 Raise_Exception(Buffer_Locked'Identity,
26742674 "Buffer is locked for change");
26752675 end if;
2676- if SR.UTF32 then
2676+ if SR.Codec /= Utf8 then
26772677 Raise_Exception(Illegal_Unicode'Identity,
26782678 "Have not support operation for operand`s types");
26792679 end if;
26802680 -- Bounds check
26812681 if Low > SR.Last + 1 then
2682- raise Array_Index_Error;
2682+ raise Index_Error;
26832683 end if;
26842684 -- Do replace operation only when replaced slice is not empty
26852685 if High >= Low then
@@ -2729,7 +2729,7 @@
27292729 Raise_Exception(Buffer_Locked'Identity,
27302730 "Buffer is locked for change");
27312731 end if;
2732- if not SR.UTF32 then
2732+ if SR.Codec /= Utf32 then
27332733 Raise_Exception(Illegal_Unicode'Identity,
27342734 "Have not support operation for operand`s types");
27352735 end if;
@@ -2751,7 +2751,7 @@
27512751 SA : SM renames Source_Ptr.all;
27522752 begin
27532753 if Low > SL + 1 then
2754- Raise_Exception(Array_Index_Error'Identity,
2754+ Raise_Exception(Index_Error'Identity,
27552755 "Illegal position values");
27562756 end if;
27572757 if High >= Low then
@@ -2785,7 +2785,7 @@
27852785 DA(Low .. Low + BL - 1) := By(SB .. EB);
27862786 DA(Low + BL .. DL) := SA(High + 1 .. SL);
27872787 DR.Last := 4*DL;
2788- DR.UTF32 := True;
2788+ DR.Codec := Utf32;
27892789 end;
27902790 end if;
27912791 return (AF.Controlled with Reference => DR);
@@ -2814,7 +2814,7 @@
28142814 Raise_Exception(Buffer_Locked'Identity,
28152815 "Buffer is locked for change");
28162816 end if;
2817- if not SR.UTF32 then
2817+ if SR.Codec /= Utf32 then
28182818 Raise_Exception(Illegal_Unicode'Identity,
28192819 "Have not support operation for operand`s types");
28202820 end if;
@@ -2834,7 +2834,7 @@
28342834 SA : SM renames Source_Ptr.all;
28352835 begin
28362836 if Low > SL + 1 then
2837- Raise_Exception(Array_Index_Error'Identity,
2837+ Raise_Exception(Index_Error'Identity,
28382838 "Illegal position values");
28392839 end if;
28402840 if High >= Low then
@@ -2883,7 +2883,7 @@
28832883 DA(Low + BL .. DL) := SA(High + 1 .. SL);
28842884 DA(Low .. Low + BL - 1) := By(SB .. EB);
28852885 DR.Last := 4*DL;
2886- DR.UTF32 := True;
2886+ DR.Codec := Utf32;
28872887 Source.Reference := DR;
28882888 Unreference(SR);
28892889 end;
@@ -2911,7 +2911,7 @@
29112911 Raise_Exception(Buffer_Locked'Identity,
29122912 "Buffer is locked for change");
29132913 end if;
2914- if not SR.UTF32 then
2914+ if SR.Codec /= Utf32 then
29152915 Raise_Exception(Illegal_Unicode'Identity,
29162916 "Have not support operation for operand`s types");
29172917 end if;
@@ -2932,7 +2932,7 @@
29322932 begin
29332933 -- Check index first
29342934 if Before > SL + 1 then
2935- Raise_Exception(Array_Index_Error'Identity,
2935+ Raise_Exception(Index_Error'Identity,
29362936 "Illegal position values");
29372937 end if;
29382938 DL := SL + NL;
@@ -2972,7 +2972,7 @@
29722972 DA(Before + NL .. DL) := SA(Before .. SL);
29732973 end;
29742974 DR.Last := 4*DL;
2975- DR.UTF32 := True;
2975+ DR.Codec := Utf32;
29762976 Source.Reference := DR;
29772977 Unreference(SR);
29782978 end;
@@ -2991,7 +2991,7 @@
29912991 Raise_Exception(Buffer_Locked'Identity,
29922992 "Buffer is locked for change");
29932993 end if;
2994- if not SR.UTF32 then
2994+ if SR.Codec /= Utf32 then
29952995 Raise_Exception(Illegal_Unicode'Identity,
29962996 "Have not support operation for operand`s types");
29972997 end if;
@@ -3011,7 +3011,7 @@
30113011 EN : Positive := New_Item'Last;
30123012 begin
30133013 if Position > SL + 1 then
3014- Raise_Exception(Array_Index_Error'Identity,
3014+ Raise_Exception(Index_Error'Identity,
30153015 "Illegal position values");
30163016 end if;
30173017 if New_Item(SN) = BOM32 then
@@ -3040,7 +3040,7 @@
30403040 DA(Position .. Position + NL - 1) := New_Item(SN .. EN);
30413041 DA(Position + NL .. DL) := SA(Position + NL .. SL);
30423042 DR.Last := 4*DL;
3043- DR.UTF32 := True;
3043+ DR.Codec := Utf32;
30443044 end;
30453045 end if;
30463046 return (AF.Controlled with Reference => DR);
@@ -3060,13 +3060,13 @@
30603060 Raise_Exception(Buffer_Locked'Identity,
30613061 "Buffer is locked for change");
30623062 end if;
3063- if not SR.UTF32 then
3063+ if SR.Codec /= Utf32 then
30643064 Raise_Exception(Illegal_Unicode'Identity,
30653065 "Have not support operation for operand`s types");
30663066 end if;
30673067 -- Bounds check
30683068 if Position > SR.Last + 1 then
3069- raise Array_Index_Error;
3069+ raise Index_Error;
30703070 end if;
30713071 if SR.Last rem 4 /= 0 then
30723072 Raise_Exception(Illegal_Unicode'Identity,
@@ -3084,7 +3084,7 @@
30843084 EN : Positive := New_Item'Last;
30853085 begin
30863086 if Position > SL + 1 then
3087- Raise_Exception(Array_Index_Error'Identity,
3087+ Raise_Exception(Index_Error'Identity,
30883088 "Illegal position values");
30893089 end if;
30903090 if New_Item(SN) = BOM32 then
@@ -3126,7 +3126,7 @@
31263126 DA(Position .. Position + NL - 1) := New_Item(SN .. EN);
31273127 DA(Position + NL .. DL) := SA(Position + NL .. SL);
31283128 DR.Last := 4*DL;
3129- DR.UTF32 := True;
3129+ DR.Codec := Utf32;
31303130 Source.Reference := DR;
31313131 Unreference (SR);
31323132 end;
@@ -3138,7 +3138,7 @@
31383138 is
31393139 SR : constant Referenced_Buffer_Access := Source.Reference;
31403140 begin
3141- if SR.UTF32 then
3141+ if SR.Codec = Utf32 then
31423142 if SR.Last rem 4 /= 0 then
31433143 Raise_Exception(Illegal_Unicode'Identity,
31443144 "Illegal buffer length");
@@ -3167,7 +3167,7 @@
31673167 DR := SR;
31683168 return (AF.Controlled with Reference => DR);
31693169 end if;
3170- if SR.UTF32 then
3170+ if SR.Codec = Utf32 then
31713171 if SR.Last rem 4 /= 0 then
31723172 Raise_Exception(Illegal_Unicode'Identity,
31733173 "Illegal buffer length");
@@ -3181,7 +3181,7 @@
31813181 SA : SSM renames Source_Ptr.all;
31823182 begin
31833183 if Through > SL then
3184- Raise_Exception(Array_Index_Error'Identity,
3184+ Raise_Exception(Index_Error'Identity,
31853185 "Illegal position values");
31863186 end if;
31873187 DL := SL - (Through - From + 1);
@@ -3199,7 +3199,7 @@
31993199 DA(1 .. From - 1) := SA(1 .. From - 1);
32003200 DA(From .. DL) := SA(Through + 1 .. SL);
32013201 DR.Last := 4*DL;
3202- DR.UTF32 := True;
3202+ DR.Codec := Utf32;
32033203 end;
32043204 end if;
32053205 end;
@@ -3207,7 +3207,7 @@
32073207 end if;
32083208 -- Index is out of range
32093209 if Through > SR.Last then
3210- Raise_Exception(Array_Index_Error'Identity,
3210+ Raise_Exception(Index_Error'Identity,
32113211 "Illegal position values");
32123212 end if;
32133213 -- Compute size of the result
@@ -3242,7 +3242,7 @@
32423242 if From > Through then
32433243 return;
32443244 end if;
3245- if SR.UTF32 then
3245+ if SR.Codec = Utf32 then
32463246 if SR.Last rem 4 /= 0 then
32473247 Raise_Exception(Illegal_Unicode'Identity,
32483248 "Illegal buffer length");
@@ -3256,7 +3256,7 @@
32563256 SA : SSM renames Source_Ptr.all;
32573257 begin
32583258 if Through > SL then
3259- Raise_Exception(Array_Index_Error'Identity,
3259+ Raise_Exception(Index_Error'Identity,
32603260 "Illegal position values");
32613261 end if;
32623262 DL := SL - (Through - From + 1);
@@ -3290,7 +3290,7 @@
32903290 DA(1 .. From - 1) := SA(1 .. From - 1);
32913291 DA(From .. DL) := SA(Through + 1 .. SL);
32923292 DR.Last := 4*DL;
3293- DR.UTF32 := True;
3293+ DR.Codec := Utf32;
32943294 Source.Reference := DR;
32953295 Unreference (SR);
32963296 end;
@@ -3299,7 +3299,7 @@
32993299 end if;
33003300 -- Through is outside of the range
33013301 if Through > SR.Last then
3302- Raise_Exception(Array_Index_Error'Identity,
3302+ Raise_Exception(Index_Error'Identity,
33033303 "Illegal position values");
33043304 else
33053305 DL := SR.Last - (Through - From + 1);
@@ -3366,10 +3366,1468 @@
33663366 K := K + RL;
33673367 end loop;
33683368 DR.Last := 4*DL;
3369- DR.UTF32 := True;
3369+ DR.Codec := Utf32;
33703370 end;
33713371 return (AF.Controlled with Reference => DR);
33723372 end "*";
33733373
3374+ function Get_Codec(Object : Unbounded_Array_Type) return String_Codec
3375+ is
3376+ begin
3377+ return Object.Reference.Codec;
3378+ end Get_Codec;
3379+
3380+ function Trim
3381+ (Source : Unbounded_Array_Type;
3382+ Side : Trim_End) return Unbounded_Array_Type
3383+ is
3384+ SR : constant Referenced_Buffer_Access := Source.Reference;
3385+ DL : Natural;
3386+ DR : Referenced_Buffer_Access;
3387+ Low : Natural;
3388+ High : Natural;
3389+ begin
3390+ if SR.Last = 0 then
3391+ DR := Empty_Referenced_Buffer'Access;
3392+ return (AF.Controlled with Reference => DR);
3393+ end if;
3394+ if not Is_One(SR.Lock_Counter) then
3395+ Raise_Exception(Buffer_Locked'Identity,
3396+ "Buffer is locked for change");
3397+ end if;
3398+ if SR.Codec /= Utf32 then
3399+ Raise_Exception(Illegal_Unicode'Identity,
3400+ "Have not support operation for operand`s types");
3401+ end if;
3402+ if SR.Last rem 4 /= 0 then
3403+ Raise_Exception(Illegal_Unicode'Identity,
3404+ "Illegal buffer length");
3405+ end if;
3406+ declare
3407+ SL : Natural := SR.Last/4;
3408+ subtype SSM is String_32(1 .. SL);
3409+ package STP is new ATOAC(SSM);
3410+ Source_Ptr : STP.Object_Pointer :=
3411+ STP.To_Pointer(SR.Data(1)'Address);
3412+ SA : SSM renames Source_Ptr.all;
3413+ begin
3414+ Low := Index_Non_Blank (SA, Forward);
3415+ -- All blanks, reuse empty shared string
3416+ if Low = 0 then
3417+ DR := Empty_Referenced_Buffer'Access;
3418+ return (AF.Controlled with Reference => DR);
3419+ end if;
3420+ case Side is
3421+ when Left =>
3422+ High := SL;
3423+ DL := SL - Low + 1;
3424+ when Right =>
3425+ Low := 1;
3426+ High := Index_Non_Blank (Source, Backward);
3427+ DL := High;
3428+ when Both =>
3429+ High := Index_Non_Blank (Source, Backward);
3430+ DL := High - Low + 1;
3431+ end case;
3432+ -- Length of the result is the same as length of the source string,
3433+ -- reuse source shared string.
3434+ if DL = SL then
3435+ Reference (SR);
3436+ DR := SR;
3437+ -- Otherwise, allocate new shared string
3438+ else
3439+ DR := Allocate (4*DL);
3440+ declare
3441+ subtype DSM is String_32(1 .. DL);
3442+ package DTP is new ATOAC(DSM);
3443+ Result_Ptr : DTP.Object_Pointer :=
3444+ DTP.To_Pointer(DR.Data(1)'Address);
3445+ DA : DSM renames Result_Ptr.all;
3446+ begin
3447+ DA(1 .. DL) := SA(Low .. High);
3448+ DR.Last := 4*DL;
3449+ DR.Codec := Utf32;
3450+ end;
3451+ end if;
3452+ end;
3453+ return (AF.Controlled with Reference => DR);
3454+ end Trim;
3455+
3456+ procedure Trim
3457+ (Source : in out Unbounded_Array_Type;
3458+ Side : Trim_End)
3459+ is
3460+ SR : constant Referenced_Buffer_Access := Source.Reference;
3461+ DL : Natural;
3462+ DR : Referenced_Buffer_Access;
3463+ Low : Natural;
3464+ High : Natural;
3465+ begin
3466+ if SR.Last = 0 then
3467+ Source.Reference := Empty_Referenced_Buffer'Access;
3468+ Unreference (SR);
3469+ return;
3470+ end if;
3471+ if not Is_One(SR.Lock_Counter) then
3472+ Raise_Exception(Buffer_Locked'Identity,
3473+ "Buffer is locked for change");
3474+ end if;
3475+ if SR.Codec /= Utf32 then
3476+ Raise_Exception(Illegal_Unicode'Identity,
3477+ "Have not support operation for operand`s types");
3478+ end if;
3479+ if SR.Last rem 4 /= 0 then
3480+ Raise_Exception(Illegal_Unicode'Identity,
3481+ "Illegal buffer length");
3482+ end if;
3483+ Low := Index_Non_Blank (Source, Forward);
3484+ -- All blanks, reuse empty shared string
3485+ if Low = 0 then
3486+ Source.Reference := Empty_Referenced_Buffer'Access;
3487+ Unreference (SR);
3488+ return;
3489+ end if;
3490+ declare
3491+ SL : Natural := SR.Last/4;
3492+ subtype SSM is String_32(1 .. SL);
3493+ package STP is new ATOAC(SSM);
3494+ Source_Ptr : STP.Object_Pointer :=
3495+ STP.To_Pointer(SR.Data(1)'Address);
3496+ SA : SSM renames Source_Ptr.all;
3497+ begin
3498+ case Side is
3499+ when Left =>
3500+ High := SL;
3501+ DL := SL - Low + 1;
3502+ when Right =>
3503+ Low := 1;
3504+ High := Index_Non_Blank (Source, Backward);
3505+ DL := High;
3506+ when Both =>
3507+ High := Index_Non_Blank (Source, Backward);
3508+ DL := High - Low + 1;
3509+ end case;
3510+ -- Length of the result is the same as length of the source string,
3511+ -- nothing to do.
3512+ if DL = SL then
3513+ return;
3514+ end if;
3515+ -- Try to reuse existent shared string
3516+ if Can_Be_Reused (SR, 4*DL) then
3517+ DR := SR;
3518+ declare
3519+ subtype DSM is String_32(1 .. DL);
3520+ package DTP is new ATOAC(DSM);
3521+ Result_Ptr : DTP.Object_Pointer :=
3522+ DTP.To_Pointer(DR.Data(1)'Address);
3523+ DA : DSM renames Result_Ptr.all;
3524+ begin
3525+ DA(1 .. DL) := SA(Low .. High);
3526+ SR.Last := 4*DL;
3527+ return;
3528+ end;
3529+ end if;
3530+ -- Otherwise, allocate new shared string
3531+ DR := Allocate (4*DL);
3532+ declare
3533+ subtype DSM is String_32(1 .. DL);
3534+ package DTP is new ATOAC(DSM);
3535+ Result_Ptr : DTP.Object_Pointer :=
3536+ DTP.To_Pointer(DR.Data(1)'Address);
3537+ DA : DSM renames Result_Ptr.all;
3538+ begin
3539+ DA(1 .. DL) := SA(Low .. High);
3540+ DR.Last := 4*DL;
3541+ DR.Codec := Utf32;
3542+ Source.Reference := DR;
3543+ Unreference (SR);
3544+ end;
3545+ end;
3546+ end Trim;
3547+
3548+ function Trim
3549+ (Source : Unbounded_Array_Type;
3550+ Left : Wide_Wide_Maps.Character_32_Set;
3551+ Right : Wide_Wide_Maps.Character_32_Set)
3552+ return Unbounded_Array_Type
3553+ is
3554+ SR : constant Referenced_Buffer_Access := Source.Reference;
3555+ DL : Natural;
3556+ DR : Referenced_Buffer_Access;
3557+ Low : Natural;
3558+ High : Natural;
3559+ begin
3560+ if SR.Last = 0 then
3561+ DR := Empty_Referenced_Buffer'Access;
3562+ return (AF.Controlled with Reference => DR);
3563+ end if;
3564+ if not Is_One(SR.Lock_Counter) then
3565+ Raise_Exception(Buffer_Locked'Identity,
3566+ "Buffer is locked for change");
3567+ end if;
3568+ if SR.Codec /= Utf32 then
3569+ Raise_Exception(Illegal_Unicode'Identity,
3570+ "Have not support operation for operand`s types");
3571+ end if;
3572+ if SR.Last rem 4 /= 0 then
3573+ Raise_Exception(Illegal_Unicode'Identity,
3574+ "Illegal buffer length");
3575+ end if;
3576+ Low := Index (Source, Left, Outside, Forward);
3577+ -- Source includes only characters from Left set, reuse empty shared
3578+ -- string.
3579+ if Low = 0 then
3580+ DR := Empty_Referenced_Buffer'Access;
3581+ else
3582+ High := Index (Source, Right, Outside, Backward);
3583+ DL := Integer'Max (0, High - Low + 1);
3584+ -- Source includes only characters from Right set or result string
3585+ -- is empty, reuse empty shared string.
3586+ if High = 0 or else DL = 0 then
3587+ Reference (Empty_Referenced_Buffer'Access);
3588+ DR := Empty_Referenced_Buffer'Access;
3589+ -- Otherwise, allocate new shared string and fill it
3590+ else
3591+ DR := Allocate (4*DL);
3592+ declare
3593+ SL : Natural := SR.Last/4;
3594+ subtype SSM is String_32(1 .. SL);
3595+ package STP is new ATOAC(SSM);
3596+ Source_Ptr : STP.Object_Pointer :=
3597+ STP.To_Pointer(SR.Data(1)'Address);
3598+ SA : SSM renames Source_Ptr.all;
3599+ subtype DSM is String_32(1 .. DL);
3600+ package DTP is new ATOAC(DSM);
3601+ Result_Ptr : DTP.Object_Pointer :=
3602+ DTP.To_Pointer(DR.Data(1)'Address);
3603+ DA : DSM renames Result_Ptr.all;
3604+ begin
3605+ DA(1 .. DL) := SA(Low .. High);
3606+ DR.Last := 4*DL;
3607+ DR.Codec := Utf32;
3608+ end;
3609+ end if;
3610+ end if;
3611+ return (AF.Controlled with Reference => DR);
3612+ end Trim;
3613+
3614+ procedure Trim
3615+ (Source : in out Unbounded_Array_Type;
3616+ Left : Wide_Wide_Maps.Character_32_Set;
3617+ Right : Wide_Wide_Maps.Character_32_Set)
3618+ is
3619+ SR : constant Referenced_Buffer_Access := Source.Reference;
3620+ DL : Natural;
3621+ DR : Referenced_Buffer_Access;
3622+ Low : Natural;
3623+ High : Natural;
3624+ begin
3625+ if SR.Last = 0 then
3626+ Source.Reference := Empty_Referenced_Buffer'Access;
3627+ Unreference (SR);
3628+ return;
3629+ end if;
3630+ if not Is_One(SR.Lock_Counter) then
3631+ Raise_Exception(Buffer_Locked'Identity,
3632+ "Buffer is locked for change");
3633+ end if;
3634+ if SR.Codec /= Utf32 then
3635+ Raise_Exception(Illegal_Unicode'Identity,
3636+ "Have not support operation for operand`s types");
3637+ end if;
3638+ if SR.Last rem 4 /= 0 then
3639+ Raise_Exception(Illegal_Unicode'Identity,
3640+ "Illegal buffer length");
3641+ end if;
3642+ Low := Index (Source, Left, Outside, Forward);
3643+ -- Source includes only characters from Left set, reuse empty shared
3644+ -- string.
3645+ if Low = 0 then
3646+ Source.Reference := Empty_Referenced_Buffer'Access;
3647+ Unreference (SR);
3648+ return;
3649+ end if;
3650+ High := Index (Source, Right, Outside, Backward);
3651+ DL := Integer'Max (0, High - Low + 1);
3652+ -- Source includes only characters from Right set or result string
3653+ -- is empty, reuse empty shared string.
3654+ if High = 0 or else DL = 0 then
3655+ Source.Reference := Empty_Referenced_Buffer'Access;
3656+ Unreference (SR);
3657+ return;
3658+ end if;
3659+ -- Try to reuse existent shared string
3660+ if Can_Be_Reused (SR, 4*DL) then
3661+ DR := SR;
3662+ declare
3663+ SL : Natural := SR.Last/4;
3664+ subtype SSM is String_32(1 .. SL);
3665+ package STP is new ATOAC(SSM);
3666+ Source_Ptr : STP.Object_Pointer :=
3667+ STP.To_Pointer(SR.Data(1)'Address);
3668+ SA : SSM renames Source_Ptr.all;
3669+ subtype DSM is String_32(1 .. DL);
3670+ package DTP is new ATOAC(DSM);
3671+ Result_Ptr : DTP.Object_Pointer :=
3672+ DTP.To_Pointer(DR.Data(1)'Address);
3673+ DA : DSM renames Result_Ptr.all;
3674+ begin
3675+ DA(1 .. DL) := SA(Low .. High);
3676+ DR.Last := 4*DL;
3677+ end;
3678+ -- Otherwise, allocate new shared string and fill it
3679+ else
3680+ DR := Allocate (4*DL);
3681+ declare
3682+ SL : Natural := SR.Last/4;
3683+ subtype SSM is String_32(1 .. SL);
3684+ package STP is new ATOAC(SSM);
3685+ Source_Ptr : STP.Object_Pointer :=
3686+ STP.To_Pointer(SR.Data(1)'Address);
3687+ SA : SSM renames Source_Ptr.all;
3688+ subtype DSM is String_32(1 .. DL);
3689+ package DTP is new ATOAC(DSM);
3690+ Result_Ptr : DTP.Object_Pointer :=
3691+ DTP.To_Pointer(DR.Data(1)'Address);
3692+ DA : DSM renames Result_Ptr.all;
3693+ begin
3694+ DA(1 .. DL) := SA(Low .. High);
3695+ DR.Last := 4*DL;
3696+ end;
3697+ DR.Last := 4*DL;
3698+ DR.Codec := Utf32;
3699+ Source.Reference := DR;
3700+ Unreference (SR);
3701+ end if;
3702+ end Trim;
3703+
3704+ function Index
3705+ (Source : Unbounded_Array_Type;
3706+ Pattern : String_32;
3707+ Going : Direction := Forward;
3708+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
3709+ Wide_Wide_Maps.Identity) return Natural
3710+ is
3711+ SR : constant Referenced_Buffer_Access := Source.Reference;
3712+ begin
3713+ if SR.Last = 0 then
3714+ return Wide_Wide_Search.Index
3715+ (Null_String_32, Pattern, Going, Mapping);
3716+ end if;
3717+ if not Is_One(SR.Lock_Counter) then
3718+ Raise_Exception(Buffer_Locked'Identity,
3719+ "Buffer is locked for change");
3720+ end if;
3721+ if SR.Codec /= Utf32 then
3722+ Raise_Exception(Illegal_Unicode'Identity,
3723+ "Have not support operation for operand`s types");
3724+ end if;
3725+ if SR.Last rem 4 /= 0 then
3726+ Raise_Exception(Illegal_Unicode'Identity,
3727+ "Illegal buffer length");
3728+ end if;
3729+ declare
3730+ SL : Natural := SR.Last/4;
3731+ subtype SSM is String_32(1 .. SL);
3732+ package STP is new ATOAC(SSM);
3733+ Source_Ptr : STP.Object_Pointer :=
3734+ STP.To_Pointer(SR.Data(1)'Address);
3735+ SA : SSM renames Source_Ptr.all;
3736+ begin
3737+ return Wide_Wide_Search.Index
3738+ (SA, Pattern, Going, Mapping);
3739+ end;
3740+ end Index;
3741+
3742+ function Index
3743+ (Source : Unbounded_Array_Type;
3744+ Pattern : String_32;
3745+ Going : Direction := Forward;
3746+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
3747+ return Natural
3748+ is
3749+ SR : constant Referenced_Buffer_Access := Source.Reference;
3750+ begin
3751+ if SR.Last = 0 then
3752+ return Wide_Wide_Search.Index
3753+ (Null_String_32, Pattern, Going, Mapping);
3754+ end if;
3755+ if not Is_One(SR.Lock_Counter) then
3756+ Raise_Exception(Buffer_Locked'Identity,
3757+ "Buffer is locked for change");
3758+ end if;
3759+ if SR.Codec /= Utf32 then
3760+ Raise_Exception(Illegal_Unicode'Identity,
3761+ "Have not support operation for operand`s types");
3762+ end if;
3763+ if SR.Last rem 4 /= 0 then
3764+ Raise_Exception(Illegal_Unicode'Identity,
3765+ "Illegal buffer length");
3766+ end if;
3767+ declare
3768+ SL : Natural := SR.Last/4;
3769+ subtype SSM is String_32(1 .. SL);
3770+ package STP is new ATOAC(SSM);
3771+ Source_Ptr : STP.Object_Pointer :=
3772+ STP.To_Pointer(SR.Data(1)'Address);
3773+ SA : SSM renames Source_Ptr.all;
3774+ begin
3775+ return Wide_Wide_Search.Index (SA, Pattern, Going, Mapping);
3776+ end;
3777+ end Index;
3778+
3779+ function Index
3780+ (Source : Unbounded_Array_Type;
3781+ Set : Wide_Wide_Maps.Character_32_Set;
3782+ Test : Membership := Inside;
3783+ Going : Direction := Forward) return Natural
3784+ is
3785+ SR : constant Referenced_Buffer_Access := Source.Reference;
3786+ begin
3787+ if SR.Last = 0 then
3788+ return Wide_Wide_Search.Index (Null_String_32, Set, Test, Going);
3789+ end if;
3790+ if not Is_One(SR.Lock_Counter) then
3791+ Raise_Exception(Buffer_Locked'Identity,
3792+ "Buffer is locked for change");
3793+ end if;
3794+ if SR.Codec /= Utf32 then
3795+ Raise_Exception(Illegal_Unicode'Identity,
3796+ "Have not support operation for operand`s types");
3797+ end if;
3798+ if SR.Last rem 4 /= 0 then
3799+ Raise_Exception(Illegal_Unicode'Identity,
3800+ "Illegal buffer length");
3801+ end if;
3802+ declare
3803+ SL : Natural := SR.Last/4;
3804+ subtype SSM is String_32(1 .. SL);
3805+ package STP is new ATOAC(SSM);
3806+ Source_Ptr : STP.Object_Pointer :=
3807+ STP.To_Pointer(SR.Data(1)'Address);
3808+ SA : SSM renames Source_Ptr.all;
3809+ begin
3810+ return Wide_Wide_Search.Index (SA, Set, Test, Going);
3811+ end;
3812+ end Index;
3813+
3814+ function Index
3815+ (Source : Unbounded_Array_Type;
3816+ Pattern : String_32;
3817+ From : Positive;
3818+ Going : Direction := Forward;
3819+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
3820+ Wide_Wide_Maps.Identity) return Natural
3821+ is
3822+ SR : constant Referenced_Buffer_Access := Source.Reference;
3823+ begin
3824+ if SR.Last = 0 then
3825+ return Wide_Wide_Search.Index
3826+ (Null_String_32, Pattern, From, Going, Mapping);
3827+ end if;
3828+ if not Is_One(SR.Lock_Counter) then
3829+ Raise_Exception(Buffer_Locked'Identity,
3830+ "Buffer is locked for change");
3831+ end if;
3832+ if SR.Codec /= Utf32 then
3833+ Raise_Exception(Illegal_Unicode'Identity,
3834+ "Have not support operation for operand`s types");
3835+ end if;
3836+ if SR.Last rem 4 /= 0 then
3837+ Raise_Exception(Illegal_Unicode'Identity,
3838+ "Illegal buffer length");
3839+ end if;
3840+ declare
3841+ SL : Natural := SR.Last/4;
3842+ subtype SSM is String_32(1 .. SL);
3843+ package STP is new ATOAC(SSM);
3844+ Source_Ptr : STP.Object_Pointer :=
3845+ STP.To_Pointer(SR.Data(1)'Address);
3846+ SA : SSM renames Source_Ptr.all;
3847+ begin
3848+ return Wide_Wide_Search.Index (SA, Pattern, From, Going, Mapping);
3849+ end;
3850+ end Index;
3851+
3852+ function Index
3853+ (Source : Unbounded_Array_Type;
3854+ Pattern : String_32;
3855+ From : Positive;
3856+ Going : Direction := Forward;
3857+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
3858+ return Natural
3859+ is
3860+ SR : constant Referenced_Buffer_Access := Source.Reference;
3861+ begin
3862+ if SR.Last = 0 then
3863+ return Wide_Wide_Search.Index
3864+ (Null_String_32, Pattern, From, Going, Mapping);
3865+ end if;
3866+ if not Is_One(SR.Lock_Counter) then
3867+ Raise_Exception(Buffer_Locked'Identity,
3868+ "Buffer is locked for change");
3869+ end if;
3870+ if SR.Codec /= Utf32 then
3871+ Raise_Exception(Illegal_Unicode'Identity,
3872+ "Have not support operation for operand`s types");
3873+ end if;
3874+ if SR.Last rem 4 /= 0 then
3875+ Raise_Exception(Illegal_Unicode'Identity,
3876+ "Illegal buffer length");
3877+ end if;
3878+ declare
3879+ SL : Natural := SR.Last/4;
3880+ subtype SSM is String_32(1 .. SL);
3881+ package STP is new ATOAC(SSM);
3882+ Source_Ptr : STP.Object_Pointer :=
3883+ STP.To_Pointer(SR.Data(1)'Address);
3884+ SA : SSM renames Source_Ptr.all;
3885+ begin
3886+ return Wide_Wide_Search.Index (SA, Pattern, From, Going, Mapping);
3887+ end;
3888+ end Index;
3889+
3890+ function Index
3891+ (Source : Unbounded_Array_Type;
3892+ Set : Wide_Wide_Maps.Character_32_Set;
3893+ From : Positive;
3894+ Test : Membership := Inside;
3895+ Going : Direction := Forward) return Natural
3896+ is
3897+ SR : constant Referenced_Buffer_Access := Source.Reference;
3898+ begin
3899+ if SR.Last = 0 then
3900+ return Wide_Wide_Search.Index(Null_String_32, Set, From, Test, Going);
3901+ end if;
3902+ if not Is_One(SR.Lock_Counter) then
3903+ Raise_Exception(Buffer_Locked'Identity,
3904+ "Buffer is locked for change");
3905+ end if;
3906+ if SR.Codec /= Utf32 then
3907+ Raise_Exception(Illegal_Unicode'Identity,
3908+ "Have not support operation for operand`s types");
3909+ end if;
3910+ if SR.Last rem 4 /= 0 then
3911+ Raise_Exception(Illegal_Unicode'Identity,
3912+ "Illegal buffer length");
3913+ end if;
3914+ declare
3915+ SL : Natural := SR.Last/4;
3916+ subtype SSM is String_32(1 .. SL);
3917+ package STP is new ATOAC(SSM);
3918+ Source_Ptr : STP.Object_Pointer :=
3919+ STP.To_Pointer(SR.Data(1)'Address);
3920+ SA : SSM renames Source_Ptr.all;
3921+ begin
3922+ return Wide_Wide_Search.Index (SA, Set, From, Test, Going);
3923+ end;
3924+ end Index;
3925+
3926+ function Head
3927+ (Source : Unbounded_Array_Type;
3928+ Count : Natural;
3929+ Pad : Character_32 := Character_32_Space)
3930+ return Unbounded_Array_Type
3931+ is
3932+ SR : constant Referenced_Buffer_Access := Source.Reference;
3933+ DR : Referenced_Buffer_Access;
3934+ begin
3935+ -- Result is empty, reuse empty shared string
3936+ if Count = 0 then
3937+ DR := Empty_Referenced_Buffer'Access;
3938+ return (AF.Controlled with Reference => DR);
3939+ end if;
3940+ if SR.Last > 0 then
3941+ if not Is_One(SR.Lock_Counter) then
3942+ Raise_Exception(Buffer_Locked'Identity,
3943+ "Buffer is locked for change");
3944+ end if;
3945+ if SR.Codec /= Utf32 then
3946+ Raise_Exception(Illegal_Unicode'Identity,
3947+ "Have not support operation for operand`s types");
3948+ end if;
3949+ if SR.Last rem 4 /= 0 then
3950+ Raise_Exception(Illegal_Unicode'Identity,
3951+ "Illegal buffer length");
3952+ end if;
3953+ end if;
3954+ declare
3955+ SL : Natural := SR.Last/4;
3956+ subtype SSM is String_32(1 .. SL);
3957+ package STP is new ATOAC(SSM);
3958+ Source_Ptr : STP.Object_Pointer :=
3959+ STP.To_Pointer(SR.Data(1)'Address);
3960+ SA : SSM renames Source_Ptr.all;
3961+ begin
3962+ -- Length of the string is the same as requested, reuse source shared
3963+ -- string.
3964+ if Count = SL then
3965+ Reference (SR);
3966+ DR := SR;
3967+ return (AF.Controlled with Reference => DR);
3968+ end if;
3969+ -- Otherwise, allocate new shared string and fill it
3970+ DR := Allocate (4*Count);
3971+ declare
3972+ subtype DSM is String_32(1 .. Count);
3973+ package DTP is new ATOAC(DSM);
3974+ Result_Ptr : DTP.Object_Pointer :=
3975+ DTP.To_Pointer(DR.Data(1)'Address);
3976+ DA : DSM renames Result_Ptr.all;
3977+ begin
3978+ -- Length of the source string is more than requested, copy
3979+ -- corresponding slice.
3980+ if Count < SL then
3981+ DA := SA(1 .. Count);
3982+ -- Length of the source string is less than requested, copy all
3983+ -- contents and fill others by Pad character.
3984+ else
3985+ DA(1 .. SL) := SA;
3986+ for J in SL + 1 .. Count loop
3987+ DA(J) := Pad;
3988+ end loop;
3989+ end if;
3990+ end;
3991+ DR.Last := 4*Count;
3992+ DR.Codec := Utf32;
3993+ return (AF.Controlled with Reference => DR);
3994+ end;
3995+ end Head;
3996+
3997+ procedure Head
3998+ (Source : in out Unbounded_Array_Type;
3999+ Count : Natural;
4000+ Pad : Character_32 := Character_32_Space)
4001+ is
4002+ SR : constant Referenced_Buffer_Access := Source.Reference;
4003+ DR : Referenced_Buffer_Access;
4004+ begin
4005+ -- Result is empty, reuse empty shared string
4006+ if Count = 0 then
4007+ Source.Reference := Empty_Referenced_Buffer'Access;
4008+ Unreference (SR);
4009+ return;
4010+ end if;
4011+ if SR.Last > 0 then
4012+ if not Is_One(SR.Lock_Counter) then
4013+ Raise_Exception(Buffer_Locked'Identity,
4014+ "Buffer is locked for change");
4015+ end if;
4016+ if SR.Codec /= Utf32 then
4017+ Raise_Exception(Illegal_Unicode'Identity,
4018+ "Have not support operation for operand`s types");
4019+ end if;
4020+ if SR.Last rem 4 /= 0 then
4021+ Raise_Exception(Illegal_Unicode'Identity,
4022+ "Illegal buffer length");
4023+ end if;
4024+ end if;
4025+ declare
4026+ SL : Natural := SR.Last/4;
4027+ subtype SSM is String_32(1 .. SL);
4028+ package STP is new ATOAC(SSM);
4029+ Source_Ptr : STP.Object_Pointer :=
4030+ STP.To_Pointer(SR.Data(1)'Address);
4031+ SA : SSM renames Source_Ptr.all;
4032+ begin
4033+ -- Result is same with source string, reuse source shared string
4034+ if Count = SL then
4035+ return;
4036+ end if;
4037+ -- Try to reuse existent shared string
4038+ if Can_Be_Reused (SR, 4*Count) then
4039+ DR := SR;
4040+ declare
4041+ subtype DSM is String_32(1 .. Count);
4042+ package DTP is new ATOAC(DSM);
4043+ Result_Ptr : DTP.Object_Pointer :=
4044+ DTP.To_Pointer(DR.Data(1)'Address);
4045+ DA : DSM renames Result_Ptr.all;
4046+ begin
4047+ if Count > SL then
4048+ for J in SL + 1 .. Count loop
4049+ DA(J) := Pad;
4050+ end loop;
4051+ end if;
4052+ DR.Last := 4*Count;
4053+ return;
4054+ end;
4055+ end if;
4056+ -- Otherwise, allocate new shared string and fill it
4057+ DR := Allocate (4*Count);
4058+ declare
4059+ subtype DSM is String_32(1 .. Count);
4060+ package DTP is new ATOAC(DSM);
4061+ Result_Ptr : DTP.Object_Pointer :=
4062+ DTP.To_Pointer(DR.Data(1)'Address);
4063+ DA : DSM renames Result_Ptr.all;
4064+ begin
4065+ -- Length of the source string is greater than requested, copy
4066+ -- corresponding slice.
4067+ if Count < SL then
4068+ DA := SA(1 .. Count);
4069+ -- Length of the source string is less than requested, copy all
4070+ -- exists data and fill others by Pad character.
4071+ else
4072+ DA(1 .. SL) := SA;
4073+ for J in SL + 1 .. Count loop
4074+ DA(J) := Pad;
4075+ end loop;
4076+ end if;
4077+ DR.Last := 4*Count;
4078+ DR.Codec := Utf32;
4079+ Source.Reference := DR;
4080+ Unreference (SR);
4081+ end;
4082+ end;
4083+ end Head;
4084+
4085+ function Tail
4086+ (Source : Unbounded_Array_Type;
4087+ Count : Natural;
4088+ Pad : Character_32 := Character_32_Space)
4089+ return Unbounded_Array_Type
4090+ is
4091+ SR : constant Referenced_Buffer_Access := Source.Reference;
4092+ DR : Referenced_Buffer_Access;
4093+ begin
4094+ -- For empty result reuse empty shared string
4095+ if Count = 0 then
4096+ DR := Empty_Referenced_Buffer'Access;
4097+ return (AF.Controlled with Reference => DR);
4098+ end if;
4099+ if SR.Last > 0 then
4100+ if not Is_One(SR.Lock_Counter) then
4101+ Raise_Exception(Buffer_Locked'Identity,
4102+ "Buffer is locked for change");
4103+ end if;
4104+ if SR.Codec /= Utf32 then
4105+ Raise_Exception(Illegal_Unicode'Identity,
4106+ "Have not support operation for operand`s types");
4107+ end if;
4108+ if SR.Last rem 4 /= 0 then
4109+ Raise_Exception(Illegal_Unicode'Identity,
4110+ "Illegal buffer length");
4111+ end if;
4112+ end if;
4113+ declare
4114+ SL : Natural := SR.Last/4;
4115+ subtype SSM is String_32(1 .. SL);
4116+ package STP is new ATOAC(SSM);
4117+ Source_Ptr : STP.Object_Pointer :=
4118+ STP.To_Pointer(SR.Data(1)'Address);
4119+ SA : SSM renames Source_Ptr.all;
4120+ begin
4121+ -- Result is hole source string, reuse source shared string
4122+ if Count = SL then
4123+ Reference (SR);
4124+ DR := SR;
4125+ return (AF.Controlled with Reference => DR);
4126+ end if;
4127+ -- Otherwise allocate new shared string and fill it
4128+ DR := Allocate (4*Count);
4129+ declare
4130+ subtype DSM is String_32(1 .. Count);
4131+ package DTP is new ATOAC(DSM);
4132+ Result_Ptr : DTP.Object_Pointer :=
4133+ DTP.To_Pointer(DR.Data(1)'Address);
4134+ DA : DSM renames Result_Ptr.all;
4135+ begin
4136+ if Count < SL then
4137+ DA := SA(SL - Count + 1 .. SL);
4138+ else
4139+ for J in 1 .. Count - SL loop
4140+ DA(J) := Pad;
4141+ end loop;
4142+ DA(Count - SL + 1 .. Count) := SA;
4143+ end if;
4144+ DR.Last := 4*Count;
4145+ DR.Codec := Utf32;
4146+ return (AF.Controlled with Reference => DR);
4147+ end;
4148+ end;
4149+ end Tail;
4150+
4151+ procedure Tail
4152+ (Source : in out Unbounded_Array_Type;
4153+ Count : Natural;
4154+ Pad : Character_32 := Character_32_Space)
4155+ is
4156+ SR : constant Referenced_Buffer_Access := Source.Reference;
4157+ DR : Referenced_Buffer_Access;
4158+ begin
4159+ -- Result is empty string, reuse empty shared string
4160+ if Count = 0 then
4161+ Source.Reference := Empty_Referenced_Buffer'Access;
4162+ Unreference (SR);
4163+ return;
4164+ end if;
4165+ if SR.Last > 0 then
4166+ if not Is_One(SR.Lock_Counter) then
4167+ Raise_Exception(Buffer_Locked'Identity,
4168+ "Buffer is locked for change");
4169+ end if;
4170+ if SR.Codec /= Utf32 then
4171+ Raise_Exception(Illegal_Unicode'Identity,
4172+ "Have not support operation for operand`s types");
4173+ end if;
4174+ if SR.Last rem 4 /= 0 then
4175+ Raise_Exception(Illegal_Unicode'Identity,
4176+ "Illegal buffer length");
4177+ end if;
4178+ end if;
4179+ declare
4180+ SL : Natural := SR.Last/4;
4181+ subtype SSM is String_32(1 .. SL);
4182+ package STP is new ATOAC(SSM);
4183+ Source_Ptr : STP.Object_Pointer :=
4184+ STP.To_Pointer(SR.Data(1)'Address);
4185+ SA : SSM renames Source_Ptr.all;
4186+ begin
4187+ -- Length of the result is the same with length of the source string,
4188+ -- reuse source shared string.
4189+ if Count = SL then
4190+ return;
4191+ end if;
4192+ -- Try to reuse existent shared string
4193+ if Can_Be_Reused (SR, 4*Count) then
4194+ DR := SR;
4195+ declare
4196+ subtype DSM is String_32(1 .. Count);
4197+ package DTP is new ATOAC(DSM);
4198+ Result_Ptr : DTP.Object_Pointer :=
4199+ DTP.To_Pointer(DR.Data(1)'Address);
4200+ DA : DSM renames Result_Ptr.all;
4201+ begin
4202+ if Count < SL then
4203+ DA := SA(SL - Count + 1 .. SL);
4204+ else
4205+ DA(Count - SL + 1 .. Count) := SA;
4206+ for J in 1 .. Count - SR.Last loop
4207+ DA(J) := Pad;
4208+ end loop;
4209+ end if;
4210+ DR.Last := 4*Count;
4211+ return;
4212+ end;
4213+ end if;
4214+ -- Otherwise allocate new shared string and fill it
4215+ DR := Allocate (4*Count);
4216+ declare
4217+ subtype DSM is String_32(1 .. Count);
4218+ package DTP is new ATOAC(DSM);
4219+ Result_Ptr : DTP.Object_Pointer :=
4220+ DTP.To_Pointer(DR.Data(1)'Address);
4221+ DA : DSM renames Result_Ptr.all;
4222+ begin
4223+ if Count < SL then
4224+ DA := SA(SL - Count + 1 .. SL);
4225+ else
4226+ DA(Count - SL + 1 .. Count) := SA;
4227+ for J in 1 .. Count - SR.Last loop
4228+ DA(J) := Pad;
4229+ end loop;
4230+ end if;
4231+ DR.Last := 4*Count;
4232+ DR.Codec := Utf32;
4233+ end;
4234+ Source.Reference := DR;
4235+ Unreference (SR);
4236+ end;
4237+ end Tail;
4238+
4239+ function Index_Non_Blank
4240+ (Source : Unbounded_Array_Type;
4241+ Going : Direction := Forward) return Natural
4242+ is
4243+ SR : constant Referenced_Buffer_Access := Source.Reference;
4244+ begin
4245+ if SR.Last = 0 then
4246+ return Wide_Wide_Search.Index_Non_Blank (Null_String_32, Going);
4247+ end if;
4248+ if not Is_One(SR.Lock_Counter) then
4249+ Raise_Exception(Buffer_Locked'Identity,
4250+ "Buffer is locked for change");
4251+ end if;
4252+ if SR.Codec /= Utf32 then
4253+ Raise_Exception(Illegal_Unicode'Identity,
4254+ "Have not support operation for operand`s types");
4255+ end if;
4256+ if SR.Last rem 4 /= 0 then
4257+ Raise_Exception(Illegal_Unicode'Identity,
4258+ "Illegal buffer length");
4259+ end if;
4260+ declare
4261+ SL : Natural := SR.Last/4;
4262+ subtype SSM is String_32(1 .. SL);
4263+ package STP is new ATOAC(SSM);
4264+ Source_Ptr : STP.Object_Pointer :=
4265+ STP.To_Pointer(SR.Data(1)'Address);
4266+ SA : SSM renames Source_Ptr.all;
4267+ begin
4268+ return Wide_Wide_Search.Index_Non_Blank (SA, Going);
4269+ end;
4270+ end Index_Non_Blank;
4271+
4272+ function Index_Non_Blank
4273+ (Source : Unbounded_Array_Type;
4274+ From : Positive;
4275+ Going : Direction := Forward) return Natural
4276+ is
4277+ SR : constant Referenced_Buffer_Access := Source.Reference;
4278+ begin
4279+ if SR.Last = 0 then
4280+ return Wide_Wide_Search.Index_Non_Blank (Null_String_32, From, Going);
4281+ end if;
4282+ if not Is_One(SR.Lock_Counter) then
4283+ Raise_Exception(Buffer_Locked'Identity,
4284+ "Buffer is locked for change");
4285+ end if;
4286+ if SR.Codec /= Utf32 then
4287+ Raise_Exception(Illegal_Unicode'Identity,
4288+ "Have not support operation for operand`s types");
4289+ end if;
4290+ if SR.Last rem 4 /= 0 then
4291+ Raise_Exception(Illegal_Unicode'Identity,
4292+ "Illegal buffer length");
4293+ end if;
4294+ declare
4295+ SL : Natural := SR.Last/4;
4296+ subtype SSM is String_32(1 .. SL);
4297+ package STP is new ATOAC(SSM);
4298+ Source_Ptr : STP.Object_Pointer :=
4299+ STP.To_Pointer(SR.Data(1)'Address);
4300+ SA : SSM renames Source_Ptr.all;
4301+ begin
4302+ return Wide_Wide_Search.Index_Non_Blank (SA, From, Going);
4303+ end;
4304+ end Index_Non_Blank;
4305+
4306+ function Count
4307+ (Source : Unbounded_Array_Type;
4308+ Pattern : String_32;
4309+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
4310+ Wide_Wide_Maps.Identity) return Natural
4311+ is
4312+ SR : constant Referenced_Buffer_Access := Source.Reference;
4313+ begin
4314+ if SR.Last = 0 then
4315+ return Wide_Wide_Search.Count (Null_String_32, Pattern, Mapping);
4316+ end if;
4317+ if not Is_One(SR.Lock_Counter) then
4318+ Raise_Exception(Buffer_Locked'Identity,
4319+ "Buffer is locked for change");
4320+ end if;
4321+ if SR.Codec /= Utf32 then
4322+ Raise_Exception(Illegal_Unicode'Identity,
4323+ "Have not support operation for operand`s types");
4324+ end if;
4325+ if SR.Last rem 4 /= 0 then
4326+ Raise_Exception(Illegal_Unicode'Identity,
4327+ "Illegal buffer length");
4328+ end if;
4329+ declare
4330+ SL : Natural := SR.Last/4;
4331+ subtype SSM is String_32(1 .. SL);
4332+ package STP is new ATOAC(SSM);
4333+ Source_Ptr : STP.Object_Pointer :=
4334+ STP.To_Pointer(SR.Data(1)'Address);
4335+ SA : SSM renames Source_Ptr.all;
4336+ begin
4337+ return Wide_Wide_Search.Count (SA, Pattern, Mapping);
4338+ end;
4339+ end Count;
4340+
4341+ function Count
4342+ (Source : Unbounded_Array_Type;
4343+ Pattern : String_32;
4344+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
4345+ return Natural
4346+ is
4347+ SR : constant Referenced_Buffer_Access := Source.Reference;
4348+ begin
4349+ if SR.Last = 0 then
4350+ return Wide_Wide_Search.Count (Null_String_32, Pattern, Mapping);
4351+ end if;
4352+ if not Is_One(SR.Lock_Counter) then
4353+ Raise_Exception(Buffer_Locked'Identity,
4354+ "Buffer is locked for change");
4355+ end if;
4356+ if SR.Codec /= Utf32 then
4357+ Raise_Exception(Illegal_Unicode'Identity,
4358+ "Have not support operation for operand`s types");
4359+ end if;
4360+ if SR.Last rem 4 /= 0 then
4361+ Raise_Exception(Illegal_Unicode'Identity,
4362+ "Illegal buffer length");
4363+ end if;
4364+ declare
4365+ SL : Natural := SR.Last/4;
4366+ subtype SSM is String_32(1 .. SL);
4367+ package STP is new ATOAC(SSM);
4368+ Source_Ptr : STP.Object_Pointer :=
4369+ STP.To_Pointer(SR.Data(1)'Address);
4370+ SA : SSM renames Source_Ptr.all;
4371+ begin
4372+ return Wide_Wide_Search.Count (SA, Pattern, Mapping);
4373+ end;
4374+ end Count;
4375+
4376+ function Count
4377+ (Source : Unbounded_Array_Type;
4378+ Set : Wide_Wide_Maps.Character_32_Set) return Natural
4379+ is
4380+ SR : constant Referenced_Buffer_Access := Source.Reference;
4381+ begin
4382+ if SR.Last = 0 then
4383+ return Wide_Wide_Search.Count (Null_String_32, Set);
4384+ end if;
4385+ if not Is_One(SR.Lock_Counter) then
4386+ Raise_Exception(Buffer_Locked'Identity,
4387+ "Buffer is locked for change");
4388+ end if;
4389+ if SR.Codec /= Utf32 then
4390+ Raise_Exception(Illegal_Unicode'Identity,
4391+ "Have not support operation for operand`s types");
4392+ end if;
4393+ if SR.Last rem 4 /= 0 then
4394+ Raise_Exception(Illegal_Unicode'Identity,
4395+ "Illegal buffer length");
4396+ end if;
4397+ declare
4398+ SL : Natural := SR.Last/4;
4399+ subtype SSM is String_32(1 .. SL);
4400+ package STP is new ATOAC(SSM);
4401+ Source_Ptr : STP.Object_Pointer :=
4402+ STP.To_Pointer(SR.Data(1)'Address);
4403+ SA : SSM renames Source_Ptr.all;
4404+ begin
4405+ return Wide_Wide_Search.Count (SA, Set);
4406+ end;
4407+ end Count;
4408+
4409+ procedure Find_Token
4410+ (Source : Unbounded_Array_Type;
4411+ Set : Wide_Wide_Maps.Character_32_Set;
4412+ From : Positive;
4413+ Test : Membership;
4414+ First : out Positive;
4415+ Last : out Natural)
4416+ is
4417+ SR : constant Referenced_Buffer_Access := Source.Reference;
4418+ begin
4419+ if SR.Last = 0 then
4420+ Wide_Wide_Search.Find_Token(Null_String_32, Set, Test, First, Last);
4421+ return;
4422+ end if;
4423+ if not Is_One(SR.Lock_Counter) then
4424+ Raise_Exception(Buffer_Locked'Identity,
4425+ "Buffer is locked for change");
4426+ end if;
4427+ if SR.Codec /= Utf32 then
4428+ Raise_Exception(Illegal_Unicode'Identity,
4429+ "Have not support operation for operand`s types");
4430+ end if;
4431+ if SR.Last rem 4 /= 0 then
4432+ Raise_Exception(Illegal_Unicode'Identity,
4433+ "Illegal buffer length");
4434+ end if;
4435+ declare
4436+ SL : Natural := SR.Last/4;
4437+ subtype SSM is String_32(1 .. SL);
4438+ package STP is new ATOAC(SSM);
4439+ Source_Ptr : STP.Object_Pointer :=
4440+ STP.To_Pointer(SR.Data(1)'Address);
4441+ SA : SSM renames Source_Ptr.all;
4442+ begin
4443+ Wide_Wide_Search.Find_Token(SA(From .. SL), Set, Test, First, Last);
4444+ end;
4445+ end Find_Token;
4446+
4447+ procedure Find_Token
4448+ (Source : Unbounded_Array_Type;
4449+ Set : Wide_Wide_Maps.Character_32_Set;
4450+ Test : Membership;
4451+ First : out Positive;
4452+ Last : out Natural)
4453+ is
4454+ SR : constant Referenced_Buffer_Access := Source.Reference;
4455+ begin
4456+ if SR.Last = 0 then
4457+ Wide_Wide_Search.Find_Token(Null_String_32, Set, Test, First, Last);
4458+ return;
4459+ end if;
4460+ if not Is_One(SR.Lock_Counter) then
4461+ Raise_Exception(Buffer_Locked'Identity,
4462+ "Buffer is locked for change");
4463+ end if;
4464+ if SR.Codec /= Utf32 then
4465+ Raise_Exception(Illegal_Unicode'Identity,
4466+ "Have not support operation for operand`s types");
4467+ end if;
4468+ if SR.Last rem 4 /= 0 then
4469+ Raise_Exception(Illegal_Unicode'Identity,
4470+ "Illegal buffer length");
4471+ end if;
4472+ declare
4473+ SL : Natural := SR.Last/4;
4474+ subtype SSM is String_32(1 .. SL);
4475+ package STP is new ATOAC(SSM);
4476+ Source_Ptr : STP.Object_Pointer :=
4477+ STP.To_Pointer(SR.Data(1)'Address);
4478+ SA : SSM renames Source_Ptr.all;
4479+ begin
4480+ Wide_Wide_Search.Find_Token(SA, Set, Test, First, Last);
4481+ end;
4482+ end Find_Token;
4483+
4484+ function Translate
4485+ (Source : Unbounded_Array_Type;
4486+ Mapping : Wide_Wide_Maps.Character_32_Mapping)
4487+ return Unbounded_Array_Type
4488+ is
4489+ SR : constant Referenced_Buffer_Access := Source.Reference;
4490+ DR : Referenced_Buffer_Access;
4491+ begin
4492+ -- Nothing to translate, reuse empty shared string
4493+ if SR.Last = 0 then
4494+ DR := Empty_Referenced_Buffer'Access;
4495+ return (AF.Controlled with Reference => DR);
4496+ end if;
4497+ if not Is_One(SR.Lock_Counter) then
4498+ Raise_Exception(Buffer_Locked'Identity,
4499+ "Buffer is locked for change");
4500+ end if;
4501+ if SR.Codec /= Utf32 then
4502+ Raise_Exception(Illegal_Unicode'Identity,
4503+ "Have not support operation for operand`s types");
4504+ end if;
4505+ if SR.Last rem 4 /= 0 then
4506+ Raise_Exception(Illegal_Unicode'Identity,
4507+ "Illegal buffer length");
4508+ end if;
4509+ declare
4510+ SL : Natural := SR.Last/4;
4511+ subtype SSM is String_32(1 .. SL);
4512+ package STP is new ATOAC(SSM);
4513+ Source_Ptr : STP.Object_Pointer :=
4514+ STP.To_Pointer(SR.Data(1)'Address);
4515+ SA : SSM renames Source_Ptr.all;
4516+ begin
4517+ -- Otherwise, allocate new shared string and fill it
4518+ DR := Allocate (4*SL);
4519+ declare
4520+ Result_Ptr : STP.Object_Pointer :=
4521+ STP.To_Pointer(DR.Data(1)'Address);
4522+ DA : SSM renames Result_Ptr.all;
4523+ begin
4524+ for J in 1 .. SR.Last loop
4525+ DA(J) := Value (Mapping, SA(J));
4526+ end loop;
4527+ DR.Last := SR.Last;
4528+ DR.Codec := Utf32;
4529+ return (AF.Controlled with Reference => DR);
4530+ end;
4531+ end;
4532+ end Translate;
4533+
4534+ procedure Translate
4535+ (Source : in out Unbounded_Array_Type;
4536+ Mapping : Wide_Wide_Maps.Character_32_Mapping)
4537+ is
4538+ SR : constant Referenced_Buffer_Access := Source.Reference;
4539+ DR : Referenced_Buffer_Access;
4540+ begin
4541+ -- Nothing to translate
4542+ if SR.Last = 0 then
4543+ return;
4544+ end if;
4545+ if not Is_One(SR.Lock_Counter) then
4546+ Raise_Exception(Buffer_Locked'Identity,
4547+ "Buffer is locked for change");
4548+ end if;
4549+ if SR.Codec /= Utf32 then
4550+ Raise_Exception(Illegal_Unicode'Identity,
4551+ "Have not support operation for operand`s types");
4552+ end if;
4553+ if SR.Last rem 4 /= 0 then
4554+ Raise_Exception(Illegal_Unicode'Identity,
4555+ "Illegal buffer length");
4556+ end if;
4557+ declare
4558+ SL : Natural := SR.Last/4;
4559+ subtype SM is String_32(1 .. SL);
4560+ package TP is new ATOAC(SM);
4561+ Source_Ptr : TP.Object_Pointer :=
4562+ TP.To_Pointer(SR.Data(1)'Address);
4563+ SA : SM renames Source_Ptr.all;
4564+ begin
4565+ -- Try to reuse shared string
4566+ if Can_Be_Reused (SR, 4*SL) then
4567+ for J in 1 .. SL loop
4568+ SA(J) := Value (Mapping, SA(J));
4569+ end loop;
4570+ return;
4571+ end if;
4572+ -- Otherwise, allocate new shared string
4573+ DR := Allocate (4*SL);
4574+ declare
4575+ Result_Ptr : TP.Object_Pointer :=
4576+ TP.To_Pointer(DR.Data(1)'Address);
4577+ DA : SM renames Result_Ptr.all;
4578+ begin
4579+ for J in 1 .. SL loop
4580+ DA(J) := Value (Mapping, SA(J));
4581+ end loop;
4582+ DR.Last := SR.Last;
4583+ DR.Codec := Utf32;
4584+ Source.Reference := DR;
4585+ Unreference (SR);
4586+ end;
4587+ end;
4588+ end Translate;
4589+
4590+ function Translate
4591+ (Source : Unbounded_Array_Type;
4592+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
4593+ return Unbounded_Array_Type
4594+ is
4595+ SR : constant Referenced_Buffer_Access := Source.Reference;
4596+ DR : Referenced_Buffer_Access;
4597+ begin
4598+ -- Nothing to translate, reuse empty shared string
4599+ if SR.Last = 0 then
4600+ DR := Empty_Referenced_Buffer'Access;
4601+ return (AF.Controlled with Reference => DR);
4602+ end if;
4603+ if not Is_One(SR.Lock_Counter) then
4604+ Raise_Exception(Buffer_Locked'Identity,
4605+ "Buffer is locked for change");
4606+ end if;
4607+ if SR.Codec /= Utf32 then
4608+ Raise_Exception(Illegal_Unicode'Identity,
4609+ "Have not support operation for operand`s types");
4610+ end if;
4611+ if SR.Last rem 4 /= 0 then
4612+ Raise_Exception(Illegal_Unicode'Identity,
4613+ "Illegal buffer length");
4614+ end if;
4615+ declare
4616+ SL : Natural := SR.Last/4;
4617+ subtype SM is String_32(1 .. SL);
4618+ package TP is new ATOAC(SM);
4619+ Source_Ptr : TP.Object_Pointer :=
4620+ TP.To_Pointer(SR.Data(1)'Address);
4621+ SA : SM renames Source_Ptr.all;
4622+ begin
4623+ -- Otherwise, allocate new shared string and fill it
4624+ DR := Allocate (4*SL);
4625+ declare
4626+ Result_Ptr : TP.Object_Pointer :=
4627+ TP.To_Pointer(DR.Data(1)'Address);
4628+ DA : SM renames Result_Ptr.all;
4629+ begin
4630+ for J in 1 .. SL loop
4631+ DA(J) := Mapping.all (SA(J));
4632+ end loop;
4633+ DR.Last := SR.Last;
4634+ DR.Codec := Utf32;
4635+ return (AF.Controlled with Reference => DR);
4636+ exception
4637+ when others =>
4638+ Unreference (DR);
4639+ raise;
4640+ end;
4641+ end;
4642+ end Translate;
4643+
4644+ procedure Translate
4645+ (Source : in out Unbounded_Array_Type;
4646+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
4647+ is
4648+ SR : constant Referenced_Buffer_Access := Source.Reference;
4649+ DR : Referenced_Buffer_Access;
4650+ begin
4651+ -- Nothing to translate
4652+ if SR.Last = 0 then
4653+ Source.Reference := Empty_Referenced_Buffer'Access;
4654+ Unreference(SR);
4655+ return;
4656+ end if;
4657+ if not Is_One(SR.Lock_Counter) then
4658+ Raise_Exception(Buffer_Locked'Identity,
4659+ "Buffer is locked for change");
4660+ end if;
4661+ if SR.Codec /= Utf32 then
4662+ Raise_Exception(Illegal_Unicode'Identity,
4663+ "Have not support operation for operand`s types");
4664+ end if;
4665+ if SR.Last rem 4 /= 0 then
4666+ Raise_Exception(Illegal_Unicode'Identity,
4667+ "Illegal buffer length");
4668+ end if;
4669+ declare
4670+ SL : Natural := SR.Last/4;
4671+ subtype SM is String_32(1 .. SL);
4672+ package TP is new ATOAC(SM);
4673+ Source_Ptr : TP.Object_Pointer :=
4674+ TP.To_Pointer(SR.Data(1)'Address);
4675+ SA : SM renames Source_Ptr.all;
4676+ begin
4677+ -- Try to reuse shared string
4678+ if Can_Be_Reused (SR, 4*SL) then
4679+ for J in 1 .. SR.Last loop
4680+ SA(J) := Mapping.all (SA(J));
4681+ end loop;
4682+ return;
4683+ end if;
4684+ -- Otherwise allocate new shared string and fill it
4685+ DR := Allocate (4*SL);
4686+ declare
4687+ Result_Ptr : TP.Object_Pointer :=
4688+ TP.To_Pointer(DR.Data(1)'Address);
4689+ DA : SM renames Result_Ptr.all;
4690+ begin
4691+ for J in 1 .. SL loop
4692+ DA(J) := Mapping.all (SA(J));
4693+ end loop;
4694+ DR.Last := SR.Last;
4695+ DR.Codec := Utf32;
4696+ Source.Reference := DR;
4697+ Unreference (SR);
4698+ exception
4699+ when others =>
4700+ if DR /= null then
4701+ Unreference (DR);
4702+ end if;
4703+ raise;
4704+ end;
4705+ end;
4706+ end Translate;
4707+
4708+ function BOM_Exist(Source : Unbounded_Array_Type) return Boolean
4709+ is
4710+ SR : Referenced_Buffer_Access := Source.Reference;
4711+ begin
4712+ case SR.Codec is
4713+ when Utf8 =>
4714+ if SR.Last >= 3 and then SR.Data(1 .. 3) = BOM8 then
4715+ return True;
4716+ end if;
4717+ when Utf32 =>
4718+ if SR.Last rem 4 /= 0 then
4719+ Raise_Exception(Illegal_Unicode'Identity,
4720+ "Illegal buffer length");
4721+ end if;
4722+ declare
4723+ SL : Natural := SR.Last/4;
4724+ subtype SM is String_32(1 .. SL);
4725+ package TP is new ATOAC(SM);
4726+ Source_Ptr : TP.Object_Pointer :=
4727+ TP.To_Pointer(SR.Data(1)'Address);
4728+ SA : SM renames Source_Ptr.all;
4729+ begin
4730+ return SA(1) = BOM32;
4731+ end;
4732+ when others =>
4733+ Raise_Exception(Illegal_Unicode'Identity,
4734+ "Unsupported codec");
4735+ end case;
4736+ return False;
4737+ end BOM_Exist;
4738+
4739+ procedure Delete_BOM(Source : in out Unbounded_Array_Type)
4740+ is
4741+ SR : Referenced_Buffer_Access := Source.Reference;
4742+ SL : Natural := SR.Last;
4743+ DL : Natural;
4744+ DR : Referenced_Buffer_Access;
4745+ begin
4746+ if not Is_One(SR.Lock_Counter) then
4747+ Raise_Exception(Buffer_Locked'Identity,
4748+ "Buffer is locked for change");
4749+ end if;
4750+ if SL = 0 then
4751+ Source.Reference := Empty_Referenced_Buffer'Access;
4752+ Unreference(SR);
4753+ return;
4754+ end if;
4755+ case SR.Codec is
4756+ when Utf8 =>
4757+ if SL >= 3 and then SR.Data(1 .. 3) = BOM8 then
4758+ SL := SL - 3;
4759+ if SL = 0 then
4760+ Source.Reference := Empty_Referenced_Buffer'Access;
4761+ Unreference(SR);
4762+ return;
4763+ end if;
4764+ if Can_Be_Reused(SR, SL) then
4765+ SR.Data(1 .. SL) := SR.Data(4 .. SR.Last);
4766+ SR.Last := SL;
4767+ return;
4768+ end if;
4769+ DR := Allocate(SL);
4770+ DR.Data(1 .. SL) := SR.Data(4 .. SR.Last);
4771+ DR.Last := SL;
4772+ Source.Reference := DR;
4773+ Unreference(SR);
4774+ return;
4775+ end if;
4776+ when Utf32 =>
4777+ if SR.Last rem 4 /= 0 then
4778+ Raise_Exception(Illegal_Unicode'Identity,
4779+ "Illegal buffer length");
4780+ end if;
4781+ SL := SR.Last/4;
4782+ declare
4783+ subtype SSM is String_32(1 .. SL);
4784+ package STP is new ATOAC(SSM);
4785+ Source_Ptr : STP.Object_Pointer :=
4786+ STP.To_Pointer(SR.Data(1)'Address);
4787+ SA : SSM renames Source_Ptr.all;
4788+ begin
4789+ if SA(1) = BOM32 then
4790+ DL := SL - 1;
4791+ if DL = 0 then
4792+ Source.Reference := Empty_Referenced_Buffer'Access;
4793+ Unreference(SR);
4794+ return;
4795+ end if;
4796+ if Can_Be_Reused(SR, 4*DL) then
4797+ DR := SR;
4798+ declare
4799+ subtype DSM is String_32(1 .. DL);
4800+ package DTP is new ATOAC(DSM);
4801+ Result_Ptr : DTP.Object_Pointer :=
4802+ DTP.To_Pointer(DR.Data(1)'Address);
4803+ DA : DSM renames Result_Ptr.all;
4804+ begin
4805+ DA := SA(2 .. SL);
4806+ DR.Last := 4*DL;
4807+ return;
4808+ end;
4809+ end if;
4810+ DR := Allocate(4*DL);
4811+ declare
4812+ subtype DSM is String_32(1 .. DL);
4813+ package DTP is new ATOAC(DSM);
4814+ Result_Ptr : DTP.Object_Pointer :=
4815+ DTP.To_Pointer(DR.Data(1)'Address);
4816+ DA : DSM renames Result_Ptr.all;
4817+ begin
4818+ DA := SA(2 .. SL);
4819+ DR.Last := 4*DL;
4820+ DR.Codec := Utf32;
4821+ Source.Reference := DR;
4822+ Unreference(SR);
4823+ end;
4824+ end if;
4825+ end;
4826+ when others =>
4827+ Raise_Exception(Illegal_Unicode'Identity,
4828+ "Unsupported codec");
4829+ end case;
4830+ end Delete_BOM;
4831+
33744832
33754833 end Unbounded_Array;
diff -r 19274b084e74 -r 04bb88a17ef5 Unbounded/unbounded_array.ads
--- a/Unbounded/unbounded_array.ads Sun Oct 06 14:03:50 2019 +0400
+++ b/Unbounded/unbounded_array.ads Wed Oct 09 04:12:41 2019 +0400
@@ -1,14 +1,15 @@
11
2-with System; use System;
3-with System.Storage_Elements;
42 with Ada.Finalization; use Ada.Finalization;
53 with System.Address_To_Access_Conversions;
64 with Ada.Exceptions; use Ada.Exceptions;
75 with Ada.Unchecked_Deallocation;
86 with Interfaces; use Interfaces;
97 with Atomic_Counters; use Atomic_Counters;
10-with Ada_Magic_Forward.Wide_Wide_Characters;
11-use Ada_Magic_Forward.Wide_Wide_Characters;
8+with Ada_Magic_Forward.Character_32s;
9+use Ada_Magic_Forward.Character_32s;
10+with Ada_Magic_Forward.Strings.Wide_Wide_Maps;
11+use Ada_Magic_Forward.Strings.Wide_Wide_Maps;
12+with Ada_Magic_Forward.Strings; use Ada_Magic_Forward.Strings;
1213
1314 package Unbounded_Array is
1415
@@ -17,26 +18,12 @@
1718 Mask_First : constant := 2#11000000#;
1819 Mask_Next : constant := 2#10000000#;
1920 Value_Mask : constant := 2#00111111#;
20- BOM32 : constant := 16#0000FEFF#;
2121
2222 Source_Is_Empty : exception;
2323 Illegal_Input : exception;
2424 Buffer_Locked : exception;
25- Array_Index_Error : exception;
2625 Illegal_Unicode : exception;
2726
28- type Byte_Type is new System.Storage_Elements.Storage_Element;
29- type Byte_Access is access all Byte_Type;
30-
31- type Array_Of_Byte_Type is array
32- (Positive range <>) of aliased Byte_Type;
33- for Array_Of_Byte_Type'Alignment use 4;
34- type Array_Of_Byte_Access is access all Array_Of_Byte_Type;
35- Null_Array : Array_Of_Byte_Type(2 .. 1);
36-
37-
38- Null_String_32 : String_32(2 .. 1);
39-
4027 BOM32LE : constant Array_Of_Byte_Type := (16#FF#, 16#FE#, 0, 0);
4128 BOM32BE : constant Array_Of_Byte_Type := (0, 0, 16#FE#, 16#FF#);
4229 BOM16LE : constant Array_Of_Byte_Type := (16#FF#, 16#FE#);
@@ -371,26 +358,178 @@
371358 function Is_Utf32 (Object : Unbounded_Array_Type) return Boolean;
372359 pragma Inline(Is_Utf32);
373360
374- procedure From_Utf8_To_Utf32 (Utf32 : in out Unbounded_Array_Type;
375- Utf8 : Array_Of_Byte_Type;
376- BOM : Boolean := False);
361+ function Get_Codec(Object : Unbounded_Array_Type) return String_Codec;
362+ pragma Inline(Get_Codec);
363+
364+ procedure From_Utf8_To_Utf32 (Utf32S : in out Unbounded_Array_Type;
365+ Utf8S : Array_Of_Byte_Type;
366+ BOM : Boolean := False);
377367
378368 function To_Utf32(Source : Unbounded_Array_Type;
379369 BOM : Boolean := False)
380370 return Unbounded_Array_Type;
381371
382- procedure From_Utf8_To_Utf32 (Utf32 : in out Unbounded_Array_Type;
383- Utf8 : String;
384- BOM : Boolean := False);
372+ procedure From_Utf8_To_Utf32 (Utf32S : in out Unbounded_Array_Type;
373+ Utf8S : String;
374+ BOM : Boolean := False);
385375
386- procedure From_Utf32_To_Utf8 (Utf8 : in out Unbounded_Array_Type;
387- Utf32 : String_32;
376+ procedure From_Utf32_To_Utf8 (Utf8S : in out Unbounded_Array_Type;
377+ Utf32S : String_32;
388378 BOM, SkipBOM : Boolean := False);
389379
390380 function To_Ut8(Source : Unbounded_Array_Type;
391381 BOM, SkipBOM : Boolean := False)
392382 return Unbounded_Array_Type;
393383
384+ function Trim
385+ (Source : Unbounded_Array_Type;
386+ Side : Trim_End) return Unbounded_Array_Type;
387+
388+ procedure Trim
389+ (Source : in out Unbounded_Array_Type;
390+ Side : Trim_End);
391+
392+ function Trim
393+ (Source : Unbounded_Array_Type;
394+ Left : Wide_Wide_Maps.Character_32_Set;
395+ Right : Wide_Wide_Maps.Character_32_Set)
396+ return Unbounded_Array_Type;
397+
398+ procedure Trim
399+ (Source : in out Unbounded_Array_Type;
400+ Left : Wide_Wide_Maps.Character_32_Set;
401+ Right : Wide_Wide_Maps.Character_32_Set);
402+
403+ function Head
404+ (Source : Unbounded_Array_Type;
405+ Count : Natural;
406+ Pad : Character_32 := Character_32_Space)
407+ return Unbounded_Array_Type;
408+
409+ procedure Head
410+ (Source : in out Unbounded_Array_Type;
411+ Count : Natural;
412+ Pad : Character_32 := Character_32_Space);
413+
414+ function Tail
415+ (Source : Unbounded_Array_Type;
416+ Count : Natural;
417+ Pad : Character_32 := Character_32_Space)
418+ return Unbounded_Array_Type;
419+
420+ procedure Tail
421+ (Source : in out Unbounded_Array_Type;
422+ Count : Natural;
423+ Pad : Character_32 := Character_32_Space);
424+
425+ function Index_Non_Blank
426+ (Source : Unbounded_Array_Type;
427+ Going : Direction := Forward) return Natural;
428+
429+ function Index_Non_Blank
430+ (Source : Unbounded_Array_Type;
431+ From : Positive;
432+ Going : Direction := Forward) return Natural;
433+
434+ function Index
435+ (Source : Unbounded_Array_Type;
436+ Pattern : String_32;
437+ Going : Direction := Forward;
438+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
439+ Wide_Wide_Maps.Identity)
440+ return Natural;
441+
442+ function Index
443+ (Source : Unbounded_Array_Type;
444+ Pattern : String_32;
445+ Going : Direction := Forward;
446+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
447+ return Natural;
448+
449+ function Index
450+ (Source : Unbounded_Array_Type;
451+ Set : Wide_Wide_Maps.Character_32_Set;
452+ Test : Membership := Inside;
453+ Going : Direction := Forward) return Natural;
454+
455+ function Index
456+ (Source : Unbounded_Array_Type;
457+ Pattern : String_32;
458+ From : Positive;
459+ Going : Direction := Forward;
460+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
461+ Wide_Wide_Maps.Identity)
462+ return Natural;
463+
464+ function Index
465+ (Source : Unbounded_Array_Type;
466+ Pattern : String_32;
467+ From : Positive;
468+ Going : Direction := Forward;
469+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
470+ return Natural;
471+
472+ function Index
473+ (Source : Unbounded_Array_Type;
474+ Set : Wide_Wide_Maps.Character_32_Set;
475+ From : Positive;
476+ Test : Membership := Inside;
477+ Going : Direction := Forward) return Natural;
478+
479+ function Count
480+ (Source : Unbounded_Array_Type;
481+ Pattern : String_32;
482+ Mapping : Wide_Wide_Maps.Character_32_Mapping :=
483+ Wide_Wide_Maps.Identity)
484+ return Natural;
485+
486+ function Count
487+ (Source : Unbounded_Array_Type;
488+ Pattern : String_32;
489+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
490+ return Natural;
491+
492+ function Count
493+ (Source : Unbounded_Array_Type;
494+ Set : Wide_Wide_Maps.Character_32_Set) return Natural;
495+
496+ procedure Find_Token
497+ (Source : Unbounded_Array_Type;
498+ Set : Wide_Wide_Maps.Character_32_Set;
499+ From : Positive;
500+ Test : Membership;
501+ First : out Positive;
502+ Last : out Natural);
503+
504+ procedure Find_Token
505+ (Source : Unbounded_Array_Type;
506+ Set : Wide_Wide_Maps.Character_32_Set;
507+ Test : Membership;
508+ First : out Positive;
509+ Last : out Natural);
510+
511+ function Translate
512+ (Source : Unbounded_Array_Type;
513+ Mapping : Wide_Wide_Maps.Character_32_Mapping)
514+ return Unbounded_Array_Type;
515+
516+ procedure Translate
517+ (Source : in out Unbounded_Array_Type;
518+ Mapping : Wide_Wide_Maps.Character_32_Mapping);
519+
520+ function Translate
521+ (Source : Unbounded_Array_Type;
522+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function)
523+ return Unbounded_Array_Type;
524+
525+ procedure Translate
526+ (Source : in out Unbounded_Array_Type;
527+ Mapping : Wide_Wide_Maps.Character_32_Mapping_Function);
528+
529+ function BOM_Exist(Source : Unbounded_Array_Type) return Boolean;
530+ pragma Inline(BOM_Exist);
531+
532+ procedure Delete_BOM(Source : in out Unbounded_Array_Type);
394533
395534 private
396535 package AF renames Ada.Finalization;
@@ -404,7 +543,7 @@
404543 Data : Array_Of_Byte_Type (1 .. Max_Length);
405544 -- Last is the index of last significant element of the Data. All
406545 -- elements with larger indexes are currently insignificant.
407- UTF32 : Boolean := False;
546+ Codec : String_Codec := Utf8;
408547 end record;
409548
410549 type Referenced_Buffer_Access is access all Referenced_Buffer;
diff -r 19274b084e74 -r 04bb88a17ef5 tester/unbounded_tester.adb
--- a/tester/unbounded_tester.adb Sun Oct 06 14:03:50 2019 +0400
+++ b/tester/unbounded_tester.adb Wed Oct 09 04:12:41 2019 +0400
@@ -2,8 +2,9 @@
22 with System; use System;
33 with Ada.Sequential_IO;
44 with Unbounded_Array; use Unbounded_Array;
5-with Ada_Magic_Forward.Wide_Wide_Characters;
6-use Ada_Magic_Forward.Wide_Wide_Characters;
5+with Ada_Magic_Forward.Character_32s;
6+use Ada_Magic_Forward.Character_32s;
7+with Ada_Magic_Forward.Strings; use Ada_Magic_Forward.Strings;
78
89 procedure Unbounded_Tester is
910 package Byte_IO is new Ada.Sequential_IO(Byte_Type); use Byte_IO;
Show on old repository browser