• R/O
  • SSH

Ada95FL: 提交

Ada 95 foundation library


Commit MetaInfo

修订版8d08208bfd97dd3dce509f05d8355bc866e17261 (tree)
时间2019-10-15 03:10:58
作者Sergey Dukov <dukov54@live...>
CommiterSergey Dukov

Log Message

#32763 Создание новой ветви "novector"

更改概述

  • delete: vector95fl/Referencing.Types.Operations.adb
  • delete: vector95fl/Referencing.Types.Operations.ads
  • delete: vector95fl/Referencing.Types.ads
  • delete: vector95fl/Referencing.ads
  • delete: vector95fl/containers.ads
  • delete: vector95fl/vector_of_bytes.adb
  • delete: vector95fl/vector_of_bytes.ads

差异

diff -r ba93446a344d -r 8d08208bfd97 vector95fl/Referencing.Types.Operations.adb
--- a/vector95fl/Referencing.Types.Operations.adb Mon Oct 14 02:04:38 2019 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,48 +0,0 @@
1-------------------------------------------------------------------------------
2--- Copyright 2018 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-with Atomic_Counters;
18-
19-package body Referencing.Types.Operations is
20-
21- ---------------
22- -- Is_Unique --
23- ---------------
24-
25- function Is_Unique (Object : Referenced'Class) return Boolean is
26- begin
27- return Atomic_Counters.Is_One (Object.Counter);
28- end Is_Unique;
29-
30- ------------
31- -- Retain --
32- ------------
33-
34- procedure Retain (Object : in out Referenced'Class) is
35- begin
36- Atomic_Counters.Increment (Object.Counter);
37- end Retain;
38-
39- -------------
40- -- Release --
41- -------------
42-
43- procedure Release (Object : in out Referenced'Class; Result : out Boolean) is
44- begin
45- Atomic_Counters.Decrement (Object.Counter, Result);
46- end Release;
47-
48-end Referencing.Types.Operations;
diff -r ba93446a344d -r 8d08208bfd97 vector95fl/Referencing.Types.Operations.ads
--- a/vector95fl/Referencing.Types.Operations.ads Mon Oct 14 02:04:38 2019 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,37 +0,0 @@
1-------------------------------------------------------------------------------
2--- Copyright 2018 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-with Ada.Unchecked_Deallocation;
18-with System;
19-with Ada.Unchecked_Conversion;
20-
21-package Referencing.Types.Operations is
22-
23- type Referenced_Access is access all Referenced'Class;
24- function To_Access is
25- new Ada.Unchecked_Conversion (System.Address, Referenced_Access);
26- procedure Free is new Ada.Unchecked_Deallocation (Object => Referenced'Class, Name => Referenced_Access);
27- function To_Address is
28- new Ada.Unchecked_Conversion (Referenced_Access, System.Address);
29-
30- function Is_Unique (Object : Referenced'Class) return Boolean;
31- pragma Inline(Is_Unique);
32- procedure Retain (Object : in out Referenced'Class);
33- pragma Inline(Retain);
34- procedure Release (Object : in out Referenced'Class; Result : out Boolean);
35- pragma Inline(Release);
36-
37-end Referencing.Types.Operations;
diff -r ba93446a344d -r 8d08208bfd97 vector95fl/Referencing.Types.ads
--- a/vector95fl/Referencing.Types.ads Mon Oct 14 02:04:38 2019 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,30 +0,0 @@
1-------------------------------------------------------------------------------
2--- Copyright 2018 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-with Ada.Finalization;
18-with Atomic_Counters;
19-
20-package Referencing.Types is
21-
22- type Referenced is tagged limited private;
23-
24-private
25-
26- type Referenced is tagged limited record
27- Counter : Atomic_Counters.Atomic_Counter;
28- end record;
29-
30-end Referencing.Types;
diff -r ba93446a344d -r 8d08208bfd97 vector95fl/Referencing.ads
--- a/vector95fl/Referencing.ads Mon Oct 14 02:04:38 2019 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,27 +0,0 @@
1-------------------------------------------------------------------------------
2--- Copyright 2018 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-with System.Storage_Elements;
18-
19-package Referencing is
20-
21-private
22-
23- Dummy_Structure : aliased constant array
24- (Positive range 1 .. 3) of
25- System.Storage_Elements.Integer_Address := (0, 0, 0);
26-
27-end Referencing;
diff -r ba93446a344d -r 8d08208bfd97 vector95fl/containers.ads
--- a/vector95fl/containers.ads Mon Oct 14 02:04:38 2019 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,10 +0,0 @@
1-
2-package Containers is
3- pragma Pure;
4-
5- type Hash_Type is mod 2**32;
6- type Count_Type is range 0 .. 2**31 - 1;
7-
8- Capacity_Error : exception;
9-
10-end Containers;
diff -r ba93446a344d -r 8d08208bfd97 vector95fl/vector_of_bytes.adb
--- a/vector95fl/vector_of_bytes.adb Mon Oct 14 02:04:38 2019 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,800 +0,0 @@
1-
2-package body Vector_Of_Bytes is
3-
4- procedure Finalize (Object : in out Vector_Type) is
5- This : Vector_Access := Object'Unchecked_Access;
6- Released : Boolean;
7- begin
8- if Object.RB /= null then
9- if Is_Unique(Object.RB.all) then
10- Free(Object.RB.Elements);
11- Free(Object.RB);
12- else
13- Release(Object.RB.all, Released);
14- end if;
15- end if;
16- begin
17- Free(This);
18- exception
19- when others => null;
20- end;
21- end Finalize;
22-
23- procedure Copy (Target : in out Vector_Type; Source : Vector_Type)
24- is
25- Released : Boolean;
26- begin
27- if Source.RB = null then
28- Raise_Exception(Source_Is_Empty'Identity,
29- "Source for Copy command is Empty!");
30- end if;
31- if Target.RB = Source.RB then
32- return;
33- end if;
34- if Target.RB /= null then
35- if Is_Unique(Target.RB.all) then
36- Free (Target.RB.Elements);
37- Free (Target.RB);
38- else
39- Release (Target.RB.all, Released);
40- end if;
41- end if;
42- Target.RB := Source.RB;
43- Retain (Target.RB.all);
44- end Copy;
45-
46- procedure Move (Target, Source : in out Vector_Type)
47- is
48- Released : Boolean;
49- Source_Ptr : Vector_Access := Source'Unchecked_Access;
50- begin
51- if Source.RB = null then
52- Raise_Exception(Source_Is_Empty'Identity,
53- "Source for Move command is Empty!");
54- end if;
55- if Target.RB = Source.RB then
56- Source.RB := null;
57- Source.Last := No_Index;
58- Source.BS := 0;
59- return;
60- end if;
61- if Target.RB /= null then
62- if Is_Unique(Target.RB.all) then
63- Free (Target.RB.Elements);
64- Free (Target.RB);
65- else
66- Release (Target.RB.all, Released);
67- end if;
68- end if;
69- Target.RB := Source.RB;
70- Target.Last := Source.Last;
71- Target.BS := Source.BS;
72- Source.RB := null;
73- Source.Last := No_Index;
74- Source.BS := 0;
75- end Move;
76-
77- function Is_Empty (Vector : Vector_Type) return Boolean
78- is
79- begin
80- return Vector.RB = null;
81- end Is_Empty;
82-
83- procedure Clean (Vector : in out Vector_Type; Unallocate : Boolean := False)
84- is
85- Released : Boolean;
86- Vector_Ptr : Vector_Access := Vector'Unchecked_Access;
87- begin
88- if Vector.RB = null then
89- return;
90- end if;
91- if Is_Unique(Vector.RB.all) then
92- Free(Vector.RB.Elements);
93- Free(Vector.RB);
94- else
95- Release(Vector.RB.all, Released);
96- end if;
97- Vector.RB := null;
98- Vector.Last := No_Index;
99- Vector.BS := 0;
100- if Unallocate then
101- declare
102- begin
103- Free(Vector_Ptr);
104- exception
105- when others => null;
106- end;
107- end if;
108- end Clean;
109-
110- function Length (Vector : Vector_Type) return Count_Type
111- is
112- begin
113- if Vector.RB = null then
114- return 0;
115- end if;
116- return Count_Type(Vector.Last - Index_Type'First + 1);
117- end Length;
118-
119- procedure Create (Vector : in out Vector_Type;
120- Source : Array_Of_Byte_Type)
121- is
122- Source_Length : Count_Type := Source'Length;
123- Released : Boolean;
124- begin
125- if Source_Length < 1 then
126- Raise_Exception(Source_Is_Empty'Identity,
127- "Source array for Create command is Empty!");
128- end if;
129- if Vector.RB /= null then
130- if Is_Unique(Vector.RB.all) then
131- if Vector.BS >= Source_Length then
132- declare
133- subtype Buffer_Type is Array_Of_Byte_Type(Source'Range);
134- type Buffer_Access is access all Buffer_Type;
135- function To_Pointer is
136- new Ada.Unchecked_Conversion
137- (System.Address, Buffer_Access);
138- Target_Buffer : Buffer_Access :=
139- To_Pointer (Vector.RB.Elements.all'Address);
140- begin
141- Target_Buffer.all := Source;
142- Vector.Last := Source'Last;
143- return;
144- end;
145- else
146- Free(Vector.RB.Elements);
147- Free(Vector.RB);
148- Vector.RB := null;
149- Vector.Last := No_Index;
150- Vector.BS := 0;
151- end if;
152- else
153- Release(Vector.RB.all, Released);
154- Vector.RB := null;
155- Vector.Last := No_Index;
156- Vector.BS := 0;
157- end if;
158- end if;
159- Vector.RB := new Referenced_Buffer;
160- declare
161- Target_Buffer : Array_Of_Byte_Access :=
162- new Array_Of_Byte_Type
163- (Index_Type'First .. Source'Last - Source'First + Size_Delta);
164- Target_Index : Index_Type;
165- begin
166- for I in Source'Range loop
167- Target_Index := Index_Type'First + (I - Source'First) + 1;
168- Target_Buffer.all(Target_Index) := Source(I);
169- end loop;
170- Vector.RB.Elements :=
171- To_Pointer(Target_Buffer.all(Target_Buffer.all'First)'Address);
172- Vector.BS := Target_Buffer.all'Length;
173- end;
174- Vector.Last := Source'Last;
175- end Create;
176-
177- procedure Append (Vector : in out Vector_Type;
178- Source : Element_Type;
179- Index : out Index_Type)
180- is
181- Released : Boolean;
182- begin
183- if Vector.RB /= null then
184- if Is_Unique(Vector.RB.all) then
185- if Vector.BS > Length(Vector) then
186- Vector.Last := Vector.Last + 1;
187- declare
188- subtype Target_Array_Type is
189- Array_Of_Byte_Type(Index_Type'First .. Vector.Last);
190- type Target_Array_Access is access all Target_Array_Type;
191- function To_Pointer is
192- new Ada.Unchecked_Conversion
193- (System.Address, Target_Array_Access);
194- Target_Array : Target_Array_Access :=
195- To_Pointer(Vector.RB.Elements.all'Address);
196- begin
197- Target_Array.all(Vector.Last) := Source;
198- end;
199- Index := Vector.Last;
200- return;
201- end if;
202- declare
203- Target_Buffer : Array_Of_Byte_Access :=
204- new Array_Of_Byte_Type
205- (Index_Type'First .. Vector.Last + Size_Delta);
206- subtype Target_Array_Type is
207- Array_Of_Byte_Type(Index_Type'First .. Vector.Last);
208- type Target_Array_Access is access all Target_Array_Type;
209- function To_Pointer is
210- new Ada.Unchecked_Conversion
211- (System.Address, Target_Array_Access);
212- Target_Array : Target_Array_Access :=
213- To_Pointer(Vector.RB.Elements.all'Address);
214- begin
215- for I in Target_Array.all'Range loop
216- Target_Buffer.all(I) := Target_Array.all(I);
217- end loop;
218- Vector.Last := Vector.Last + 1;
219- Target_Buffer.all(Vector.Last) := Source;
220- Free(Vector.RB.Elements);
221- Vector.RB.Elements :=
222- To_Pointer(Target_Buffer.all(Index_Type'First)'Address);
223- Vector.BS := Target_Buffer.all'Length;
224- end;
225- Index := Vector.Last;
226- return;
227- end if;
228- declare
229- Target_Buffer : Array_Of_Byte_Access :=
230- new Array_Of_Byte_Type
231- (Index_Type'First .. Vector.Last + Size_Delta);
232- subtype Target_Array_Type is
233- Array_Of_Byte_Type(Index_Type'First .. Vector.Last);
234- type Target_Array_Access is access all Target_Array_Type;
235- function To_Pointer is
236- new Ada.Unchecked_Conversion
237- (System.Address, Target_Array_Access);
238- Target_Array : Target_Array_Access :=
239- To_Pointer(Vector.RB.Elements.all'Address);
240- begin
241- for I in Target_Array.all'Range loop
242- Target_Buffer.all(I) := Target_Array.all(I);
243- end loop;
244- Vector.Last := Vector.Last + 1;
245- Target_Buffer.all(Vector.Last) := Source;
246- Release(Vector.RB.all, Released);
247- Vector.RB := new Referenced_Buffer;
248- Vector.RB.Elements :=
249- To_Pointer(Target_Buffer.all(Index_Type'First)'Address);
250- Vector.BS := Target_Buffer.all'Length;
251- end;
252- Index := Vector.Last;
253- return;
254- end if;
255- Vector.Last := Index_Type'First;
256- declare
257- Target_Buffer : Array_Of_Byte_Access :=
258- new Array_Of_Byte_Type
259- (Index_Type'First .. Vector.Last + Size_Delta);
260- begin
261- Target_Buffer.all(Vector.Last) := Source;
262- Vector.RB := new Referenced_Buffer;
263- Vector.RB.Elements :=
264- To_Pointer(Target_Buffer.all(Index_Type'First)'Address);
265- Vector.BS := Target_Buffer.all'Length;
266- end;
267- Index := Vector.Last;
268- end Append;
269-
270- procedure Append (Vector : in out Vector_Type;
271- Source : Array_Of_Byte_Type)
272- is
273- Source_Length : Count_Type := Source'Length;
274- Old_Length : Count_Type := Length(Vector);
275- New_Length : Count_Type := Old_Length + Source_Length;
276- Released : Boolean;
277- begin
278- if Source_Length < 1 then
279- Raise_Exception(Source_Is_Empty'Identity,
280- "Source array for Append command is Empty!");
281- end if;
282- if Vector.RB /= null then
283- if Is_Unique(Vector.RB.all) then
284- if Vector.BS >= New_Length then
285- declare
286- subtype Target_Array_Type is Array_Of_Byte_Type
287- (Index_Type'First ..
288- Index_Type'First + Index_Type(New_Length - 1));
289- type Target_Array_Access is access all Target_Array_Type;
290- function To_Pointer is
291- new Ada.Unchecked_Conversion
292- (System.Address, Target_Array_Access);
293- Target_Array_Ptr : Target_Array_Access :=
294- To_Pointer(Vector.RB.Elements.all'Address);
295- New_Index : Index_Type;
296- begin
297- for I in Source'Range loop
298- New_Index := Vector.Last + (I - Source'First) + 1;
299- Target_Array_Ptr.all(New_Index) := Source(I);
300- end loop;
301- end;
302- Vector.Last := Vector.Last + Index_Type(Source_Length);
303- return;
304- end if;
305- declare
306- New_Buffer : Array_Of_Byte_Access :=
307- new Array_Of_Byte_Type
308- (Index_Type'First ..
309- Index_Type'First + Index_Type(New_Length + Size_Delta));
310- subtype Old_Buffer_Type is Array_Of_Byte_Type
311- (Index_Type'First .. Vector.Last);
312- type Old_Buffer_Access is access Old_Buffer_Type;
313- function To_Pointer is
314- new Ada.Unchecked_Conversion
315- (System.Address, Old_Buffer_Access);
316- Old_Buffer_Ptr : Old_Buffer_Access :=
317- To_Pointer(Vector.RB.Elements.all'Address);
318- New_Index : Index_Type;
319- begin
320- for I in Old_Buffer_Ptr.all'Range loop
321- New_Buffer.all(I) := Old_Buffer_Ptr.all(I);
322- end loop;
323- for I in Source'Range loop
324- New_Index := Vector.Last + (I - Source'First + 1);
325- New_Buffer.all(New_Index) := Source(I);
326- end loop;
327- Free(Vector.RB.Elements);
328- Vector.RB.Elements :=
329- To_Pointer(New_Buffer.all(Index_Type'First)'Address);
330- Vector.BS := New_Buffer.all'Length;
331- end;
332- Vector.Last := Vector.Last + Index_Type(Source_Length);
333- return;
334- end if;
335- Release(Vector.RB.all, Released);
336- declare
337- New_Buffer : Array_Of_Byte_Access :=
338- new Array_Of_Byte_Type
339- (Index_Type'First ..
340- Index_Type'First + Index_Type(New_Length + Size_Delta));
341- subtype Old_Buffer_Type is Array_Of_Byte_Type
342- (Index_Type'First .. Vector.Last);
343- type Old_Buffer_Access is access Old_Buffer_Type;
344- function To_Pointer is
345- new Ada.Unchecked_Conversion
346- (System.Address, Old_Buffer_Access);
347- Old_Buffer_Ptr : Old_Buffer_Access :=
348- To_Pointer(Vector.RB.Elements.all'Address);
349- New_Index : Index_Type;
350- begin
351- for I in Old_Buffer_Ptr.all'Range loop
352- New_Buffer.all(I) := Old_Buffer_Ptr.all(I);
353- end loop;
354- for I in Source'Range loop
355- New_Index := Vector.Last + (I - Source'First + 1);
356- New_Buffer.all(New_Index) := Source(I);
357- end loop;
358- Vector.RB := new Referenced_Buffer;
359- Vector.RB.Elements :=
360- To_Pointer(New_Buffer.all(Index_Type'First)'Address);
361- Vector.BS := New_Buffer.all'Length;
362- end;
363- Vector.Last := Vector.Last + Index_Type(Source_Length);
364- return;
365- end if;
366- Create(Vector, Source);
367- end Append;
368-
369- procedure Append (Vector : in out Vector_Type;
370- Source : in out Vector_Type)
371- is
372- Source_Length : Count_Type := Length(Source);
373- Old_Length : Count_Type := Length(Vector);
374- New_Length : Count_Type := Old_Length + Source_Length;
375- Vector_Ptr : Vector_Access := Vector'Unchecked_Access;
376- Source_Ptr : Vector_Access := Source'Unchecked_Access;
377- Released : Boolean := False;
378- begin
379- if Source_Length < 1 then
380- Raise_Exception(Source_Is_Empty'Identity,
381- "Source vector for Append command is Empty!");
382- end if;
383- if Old_Length /= 0 then
384- if Is_Unique(Vector.RB.all) then
385- if Vector.RB = Source.RB then
386- if Vector_Ptr /= Source_Ptr then
387- Vector.RB := null;
388- Vector.BS := 0;
389- Vector.Last := No_Index;
390- declare
391- subtype Source_Array_Type is
392- Array_Of_Byte_Type(Index_Type'First .. Source.Last);
393- type Source_Array_Access is access all Source_Array_Type;
394- function To_Pointer is
395- new Ada.Unchecked_Conversion
396- (System.Address, Source_Array_Access);
397- Source_Array_Ptr : Source_Array_Access :=
398- To_Pointer(Source.RB.Elements.all'Address);
399- begin
400- Create(Vector, Source_Array_Ptr.all);
401- Append(Vector, Source_Array_Ptr.all);
402- end;
403- return;
404- end if;
405- end if;
406- declare
407- subtype Source_Array_Type is
408- Array_Of_Byte_Type(Index_Type'First .. Source.Last);
409- type Source_Array_Access is access all Source_Array_Type;
410- function To_Pointer is
411- new Ada.Unchecked_Conversion
412- (System.Address, Source_Array_Access);
413- Source_Array_Ptr : Source_Array_Access :=
414- To_Pointer(Source.RB.Elements.all'Address);
415- begin
416- Append(Vector, Source_Array_Ptr.all);
417- end;
418- return;
419- end if;
420- Release(Vector.RB.all, Released);
421- declare
422- subtype Target_Array_Type is
423- Array_Of_Byte_Type(Index_Type'First .. Vector.Last);
424- type Target_Array_Access is access all Target_Array_Type;
425- function To_Pointer is
426- new Ada.Unchecked_Conversion
427- (System.Address, Target_Array_Access);
428- Target_Array_Ptr : Target_Array_Access :=
429- To_Pointer(Vector.RB.Elements.all'Address);
430- subtype Source_Array_Type is
431- Array_Of_Byte_Type(Index_Type'First .. Source.Last);
432- type Source_Array_Access is access all Source_Array_Type;
433- function To_Pointer is
434- new Ada.Unchecked_Conversion
435- (System.Address, Source_Array_Access);
436- Source_Array_Ptr : Source_Array_Access :=
437- To_Pointer(Source.RB.Elements.all'Address);
438- begin
439- Vector.RB := null;
440- Vector.Last := No_Index;
441- Vector.BS := 0;
442- Create(Vector, Target_Array_Ptr.all);
443- Append(Vector, Source_Array_Ptr.all);
444- end;
445- return;
446- end if;
447- Copy(Vector, Source);
448- end Append;
449-
450- function "=" (Left, Right : Vector_Type) return Boolean
451- is
452- begin
453- if Left.RB = Right.RB then
454- return True;
455- end if;
456- if Length(Left) /= Length(Right) then
457- return False;
458- end if;
459- declare
460- subtype Array_Type is Array_Of_Byte_Type
461- (Index_Type'First .. Left.Last);
462- type Array_Access is access all Array_Type;
463- function To_Pointer is
464- new Ada.Unchecked_Conversion
465- (System.Address, Array_Access);
466- Left_Array_Ptr : Array_Access :=
467- To_Pointer(Left.RB.Elements.all'Address);
468- Right_Array_Ptr : Array_Access :=
469- To_Pointer(Right.RB.Elements.all'Address);
470- begin
471- for I in Array_Type'Range loop
472- if Left_Array_Ptr.all(I) /= Right_Array_Ptr.all(I) then
473- return False;
474- end if;
475- end loop;
476- end;
477- return True;
478- end "=";
479-
480- function To_Array(Vector : Vector_Type) return Array_Of_Byte_Type
481- is
482- begin
483- if Vector.RB = null then
484- Raise_Exception(Source_Is_Empty'Identity,
485- "Source vector for To_Array command is Empty!");
486- end if;
487- declare
488- subtype Constant_Array is Array_Of_Byte_Type
489- (Index_Type'First .. Vector.Last);
490- type Constant_Array_Access is access constant Constant_Array;
491- function To_Pointer is
492- new Ada.Unchecked_Conversion
493- (System.Address, Constant_Array_Access);
494- Constant_Array_Ptr : Constant_Array_Access :=
495- To_Pointer(Vector.RB.Elements.all'Address);
496- begin
497- return Constant_Array_Ptr.all;
498- end;
499- end To_Array;
500-
501- function To_String(Vector : Vector_Type) return String
502- is
503- begin
504- if Vector.RB = null then
505- Raise_Exception(Source_Is_Empty'Identity,
506- "Source vector for To_String command is Empty!");
507- end if;
508- declare
509- subtype Constant_Array is String
510- (Integer(Index_Type'First) .. Integer(Vector.Last));
511- type Constant_Array_Access is access constant Constant_Array;
512- function To_Pointer is
513- new Ada.Unchecked_Conversion
514- (System.Address, Constant_Array_Access);
515- Constant_Array_Ptr : Constant_Array_Access :=
516- To_Pointer(Vector.RB.Elements.all'Address);
517- begin
518- return Constant_Array_Ptr.all;
519- end;
520- end To_String;
521-
522-
523- -----------
524- -- Write --
525- -----------
526-
527- procedure Write
528- (Stream : not null access Root_Stream_Type'Class;
529- Container : Vector_Type)
530- is
531- Input_Array : Array_Of_Byte_Type := To_Array(Container);
532- begin
533- Count_Type'Base'Write (Stream, Length (Container));
534- for J in Input_Array'Range loop
535- Element_Type'Write (Stream, Input_Array(J));
536- end loop;
537- end Write;
538-
539-
540- ----------
541- -- Read --
542- ----------
543-
544- procedure Read
545- (Stream : not null access Root_Stream_Type'Class;
546- Container : out Vector_Type)
547- is
548- Length : Count_Type'Base;
549- Last : Index_Type'Base := No_Index;
550- begin
551- Clean (Container);
552- Count_Type'Base'Read (Stream, Length);
553- declare
554- Output_Array : Array_Of_Byte_Type
555- (Index_Type'First .. Index_Type'First + Index_Type(Length) - 1);
556- begin
557- for J in Count_Type range 1 .. Length loop
558- Last := Last + 1;
559- Element_Type'Read (Stream, Output_Array(Last));
560- end loop;
561- Create(Container, Output_Array);
562- end;
563- end Read;
564-
565- procedure From_Utf8_To_Utf32 (Utf32 : in out Vector_Type;
566- Utf8 : Array_Of_Byte_Type;
567- BOM, BE : Boolean := False)
568- is
569- Input_length : Count_Type := Utf8'Length;
570- Position : Index_Type := Utf8'First;
571- Last : Index_Type := Utf8'Last;
572- Byte1, Byte2, Byte3, Byte4 : Element_Type;
573- Unicode_Symbol, Aux_Symbol : Unicode_Base_Type;
574- begin
575- if Input_length < 1 then
576- Raise_Exception(Source_Is_Empty'Identity,
577- "Input array is Empty!");
578- end if;
579- Clean(Utf32);
580- if BOM then
581- if BE then
582- Append(Utf32, BOM32BE);
583- else
584- Append(Utf32, BOM32LE);
585- end if;
586- end if;
587- if Input_length >= 4 then
588- declare
589- Sub_Array : Array_Of_Byte_Type := Utf8(Position .. Position + 3);
590- begin
591- if Sub_Array = BOM32LE or else Sub_Array = BOM32BE then
592- Raise_Exception(Illegal_Input'Identity,
593- "Illegal input BOM");
594- end if;
595- end;
596- end if;
597- if Input_length >= 3 then
598- declare
599- Sub_Array : Array_Of_Byte_Type := Utf8(Position .. Position + 2);
600- begin
601- if Sub_Array = BOM8 then
602- if not BOM then
603- if BE then
604- Append(Utf32, BOM32BE);
605- else
606- Append(Utf32, BOM32LE);
607- end if;
608- end if;
609- Position := Position + 3;
610- if Position > Utf8'Last then
611- return;
612- end if;
613- end if;
614- end;
615- elsif Input_length >= 2 then
616- declare
617- Sub_Array : Array_Of_Byte_Type := Utf8(Position .. Position + 1);
618- begin
619- if Sub_Array = BOM16LE or else Sub_Array = BOM16BE then
620- Raise_Exception(Illegal_Input'Identity,
621- "Illegal input BOM");
622- end if;
623- end;
624- end if;
625- while Position <= Last loop
626- Byte1 := Utf8(Position);
627- Position := Position + 1;
628- if Byte1 < 128 then
629- if BE then
630- declare
631- Added_Array : Array_Of_Byte_Type := (0, 0, 0, Byte1);
632- begin
633- Append(Utf32, Added_Array);
634- end;
635- else
636- declare
637- Added_Array : Array_Of_Byte_Type := (Byte1, 0, 0, 0);
638- begin
639- Append(Utf32, Added_Array);
640- end;
641- end if;
642- else
643- if (Byte1 and 2#11111000#) = 2#11110000# then
644- if Position + 2 > Last then
645- Raise_Exception(Illegal_Input'Identity,
646- "Illegal length of symbol");
647- end if;
648- Byte2 := Utf8(Position);
649- if (Byte2 and Mask_First) /= Mask_Next then
650- Raise_Exception(Illegal_Input'Identity,
651- "Illegal second byte of symbol");
652- end if;
653- Position := Position + 1;
654- Byte3 := Utf8(Position);
655- if (Byte3 and Mask_First) /= Mask_Next then
656- Raise_Exception(Illegal_Input'Identity,
657- "Illegal third byte of symbol");
658- end if;
659- Position := Position + 1;
660- Byte4 := Utf8(Position);
661- if (Byte4 and Mask_First) /= Mask_Next then
662- Raise_Exception(Illegal_Input'Identity,
663- "Illegal fourth byte of symbol");
664- end if;
665- Position := Position + 1;
666- Unicode_Symbol := Unicode_Base_Type(Byte4 and Value_Mask);
667- Aux_Symbol := Unicode_Base_Type(Byte3 and Value_Mask);
668- Aux_Symbol := Shift_Left(Aux_Symbol, 6);
669- Unicode_Symbol := Unicode_Symbol or Aux_Symbol;
670- Aux_Symbol := Unicode_Base_Type(Byte2 and Value_Mask);
671- Aux_Symbol := Shift_Left(Aux_Symbol, 12);
672- Unicode_Symbol := Unicode_Symbol or Aux_Symbol;
673- Aux_Symbol := Unicode_Base_Type(Byte1 and 2#00000111#);
674- Aux_Symbol := Shift_Left(Aux_Symbol, 18);
675- Unicode_Symbol := Unicode_Symbol or Aux_Symbol;
676- elsif (Byte1 and 2#11110000#) = 2#11100000# then
677- if Position + 1 > Last then
678- Raise_Exception(Illegal_Input'Identity,
679- "Illegal length of symbol");
680- end if;
681- Byte2 := Utf8(Position);
682- if (Byte2 and Mask_First) /= Mask_Next then
683- Raise_Exception(Illegal_Input'Identity,
684- "Illegal second byte of symbol");
685- end if;
686- Position := Position + 1;
687- Byte3 := Utf8(Position);
688- if (Byte3 and Mask_First) /= Mask_Next then
689- Raise_Exception(Illegal_Input'Identity,
690- "Illegal third byte of symbol");
691- end if;
692- Position := Position + 1;
693- Unicode_Symbol := Unicode_Base_Type(Byte3 and Value_Mask);
694- Aux_Symbol := Unicode_Base_Type(Byte2 and Value_Mask);
695- Aux_Symbol := Shift_Left(Aux_Symbol, 6);
696- Unicode_Symbol := Unicode_Symbol or Aux_Symbol;
697- Aux_Symbol := Unicode_Base_Type(Byte1 and 2#00001111#);
698- Aux_Symbol := Shift_Left(Aux_Symbol, 12);
699- Unicode_Symbol := Unicode_Symbol or Aux_Symbol;
700- elsif (Byte1 and 2#11100000#) = 2#11000000# then
701- if Position > Last then
702- Raise_Exception(Illegal_Input'Identity,
703- "Illegal length of symbol");
704- end if;
705- Byte2 := Utf8(Position);
706- if (Byte2 and Mask_First) /= Mask_Next then
707- Raise_Exception(Illegal_Input'Identity,
708- "Illegal second byte of symbol");
709- end if;
710- Position := Position + 1;
711- Unicode_Symbol := Unicode_Base_Type(Byte2 and Value_Mask);
712- Aux_Symbol := Unicode_Base_Type(Byte1 and 2#00011111#);
713- Aux_Symbol := Shift_Left(Aux_Symbol, 6);
714- Unicode_Symbol := Unicode_Symbol or Aux_Symbol;
715- else
716- Raise_Exception(Illegal_Input'Identity,
717- "Illegal first byte of symbol");
718- end if;
719- if Unicode_Symbol = 2#1111_1110_1111_1111# then
720- Raise_Exception(Illegal_Input'Identity,
721- "Illegal position of BOM8");
722- end if;
723- Aux_Symbol := Unicode_Symbol and 16#FF#;
724- Byte1 := Element_Type(Aux_Symbol);
725- Unicode_Symbol := Shift_Right(Unicode_Symbol, 8);
726- Aux_Symbol := Unicode_Symbol and 16#FF#;
727- Byte2 := Element_Type(Aux_Symbol);
728- Unicode_Symbol := Shift_Right(Unicode_Symbol, 8);
729- Aux_Symbol := Unicode_Symbol and 16#FF#;
730- Byte3 := Element_Type(Aux_Symbol);
731- Unicode_Symbol := Shift_Right(Unicode_Symbol, 8);
732- Byte4 := Element_Type(Unicode_Symbol);
733- if BE then
734- declare
735- Added_Array : Array_Of_Byte_Type :=
736- (Byte4, Byte3, Byte2, Byte1);
737- begin
738- Append(Utf32, Added_Array);
739- end;
740- else
741- declare
742- Added_Array : Array_Of_Byte_Type :=
743- (Byte1, Byte2, Byte3, Byte4);
744- begin
745- Append(Utf32, Added_Array);
746- end;
747- end if;
748- end if;
749- end loop;
750- end From_Utf8_To_Utf32;
751-
752-
753- procedure Create (Vector : in out Vector_Type;
754- Source : String)
755- is
756- subtype Bounded_Array is Array_Of_Byte_Type
757- (Index_Type(Source'First) .. Index_Type(Source'Last));
758- type Bounded_Array_Access is access constant Bounded_Array;
759- function To_Pointer is
760- new Ada.Unchecked_Conversion (System.Address, Bounded_Array_Access);
761- Input_Ptr : Bounded_Array_Access :=
762- To_Pointer(Source(Source'First)'Address);
763- begin
764- Create(Vector, Input_Ptr.all);
765- end Create;
766-
767- procedure Append (Vector : in out Vector_Type;
768- Source : String)
769- is
770- subtype Bounded_Array is Array_Of_Byte_Type
771- (Index_Type(Source'First) .. Index_Type(Source'Last));
772- type Bounded_Array_Access is access constant Bounded_Array;
773- function To_Pointer is
774- new Ada.Unchecked_Conversion (System.Address, Bounded_Array_Access);
775- Input_Ptr : Bounded_Array_Access :=
776- To_Pointer(Source(Source'First)'Address);
777- begin
778- Append(Vector, Input_Ptr.all);
779- end Append;
780-
781- procedure From_Utf8_To_Utf32 (Utf32 : in out Vector_Type;
782- Utf8 : String;
783- BOM, BE : Boolean := False)
784- is
785- subtype Bounded_Array is Array_Of_Byte_Type
786- (Index_Type(Utf8'First) .. Index_Type(Utf8'Last));
787- type Bounded_Array_Access is access constant Bounded_Array;
788- function To_Pointer is
789- new Ada.Unchecked_Conversion (System.Address, Bounded_Array_Access);
790- Input_Ptr : Bounded_Array_Access :=
791- To_Pointer(Utf8(Utf8'First)'Address);
792- begin
793- From_Utf8_To_Utf32(Utf32,
794- Input_Ptr.all,
795- BOM,
796- BE);
797- end From_Utf8_To_Utf32;
798-
799-
800-end Vector_Of_Bytes;
diff -r ba93446a344d -r 8d08208bfd97 vector95fl/vector_of_bytes.ads
--- a/vector95fl/vector_of_bytes.ads Mon Oct 14 02:04:38 2019 +0400
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,130 +0,0 @@
1-
2-with System;
3-with System.Storage_Elements;
4-with Ada.Finalization; use Ada.Finalization;
5-with Referencing.Types; use Referencing.Types;
6-with Referencing.Types.Operations; use Referencing.Types.Operations;
7-with Ada.Unchecked_Deallocation;
8-with Ada.Unchecked_Conversion;
9-with Ada.Exceptions; use Ada.Exceptions;
10-with Ada.Streams; use Ada.Streams;
11-with Containers; use Containers;
12-with Interfaces; use Interfaces;
13-
14-package Vector_Of_Bytes is
15-
16- Size_Delta : constant := 1023;
17- Mask_First : constant := 2#11000000#;
18- Mask_Next : constant := 2#10000000#;
19- Value_Mask : constant := 2#00111111#;
20-
21- Source_Is_Empty : exception;
22- Illegal_Input : exception;
23-
24- subtype Unicode_Base_Type is Unsigned_32;
25-
26- type Index_Type is new Integer range 1 .. Integer'Last;
27- subtype Extended_Index is
28- Index_Type'Base range
29- Index_Type'First-1 ..
30- Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1;
31- No_Index : constant Extended_Index := Extended_Index'First;
32-
33-
34- type Element_Type is new System.Storage_Elements.Storage_Element;
35- type Elements_Access is access all Element_Type;
36- procedure Free is
37- new Ada.Unchecked_Deallocation (Element_Type, Elements_Access);
38- function To_Pointer is
39- new Ada.Unchecked_Conversion (System.Address, Elements_Access);
40-
41- type Array_Of_Byte_Type is array
42- (Index_Type range <>) of aliased Element_Type;
43- type Array_Of_Byte_Access is access all Array_Of_Byte_Type;
44-
45- BOM32LE : constant Array_Of_Byte_Type := (16#FF#, 16#FE#, 0, 0);
46- BOM32BE : constant Array_Of_Byte_Type := (0, 0, 16#FE#, 16#FF#);
47- BOM16LE : constant Array_Of_Byte_Type := (16#FF#, 16#FE#);
48- BOM16BE : constant Array_Of_Byte_Type := (16#FE#, 16#FF#);
49- BOM8 : constant Array_Of_Byte_Type := (16#EF#, 16#BB#, 16#BF#);
50-
51- type Vector_Type is tagged limited private;
52- type Vector_Access is access all Vector_Type;
53-
54- function Is_Empty (Vector : Vector_Type) return Boolean;
55- pragma Inline(Is_Empty);
56-
57- function Length (Vector : Vector_Type) return Count_Type;
58- pragma Inline(Length);
59-
60- procedure Copy (Target : in out Vector_Type; Source : Vector_Type);
61-
62- procedure Move (Target, Source : in out Vector_Type);
63-
64- procedure Clean (Vector : in out Vector_Type; Unallocate : Boolean := False);
65-
66- procedure Create (Vector : in out Vector_Type;
67- Source : Array_Of_Byte_Type);
68-
69- procedure Create (Vector : in out Vector_Type;
70- Source : String);
71-
72- procedure Append (Vector : in out Vector_Type;
73- Source : Element_Type;
74- Index : out Index_Type);
75-
76- procedure Append (Vector : in out Vector_Type;
77- Source : Array_Of_Byte_Type);
78-
79- procedure Append (Vector : in out Vector_Type;
80- Source : String);
81-
82- procedure Append (Vector : in out Vector_Type;
83- Source : in out Vector_Type);
84-
85- function "=" (Left, Right : Vector_Type) return Boolean;
86-
87- function To_Array(Vector : Vector_Type) return Array_Of_Byte_Type;
88- pragma Inline(To_Array);
89-
90- function To_String(Vector : Vector_Type) return String;
91- pragma Inline(To_String);
92-
93- procedure From_Utf8_To_Utf32 (Utf32 : in out Vector_Type;
94- Utf8 : Array_Of_Byte_Type;
95- BOM, BE : Boolean := False);
96-
97- procedure From_Utf8_To_Utf32 (Utf32 : in out Vector_Type;
98- Utf8 : String;
99- BOM, BE : Boolean := False);
100-
101-private
102-
103- type Referenced_Buffer is new Referenced with
104- record
105- Elements : Elements_Access := null;
106- end record;
107- type Referenced_Buffer_Ptr is access all Referenced_Buffer;
108- procedure Free is
109- new Ada.Unchecked_Deallocation (Referenced_Buffer, Referenced_Buffer_Ptr);
110-
111- type Vector_Type is new Limited_Controlled with record
112- RB : Referenced_Buffer_Ptr := null;
113- Last : Extended_Index := No_Index;
114- BS : Count_Type := 0;
115- end record;
116- procedure Finalize (Object : in out Vector_Type);
117- procedure Write
118- (Stream : not null access Root_Stream_Type'Class;
119- Container : Vector_Type);
120- for Vector_Type'Write use Write;
121- procedure Read
122- (Stream : not null access Root_Stream_Type'Class;
123- Container : out Vector_Type);
124- for Vector_Type'Read use Read;
125-
126- procedure Free is
127- new Ada.Unchecked_Deallocation (Vector_Type, Vector_Access);
128-
129-
130-end Vector_Of_Bytes;
Show on old repository browser