OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [a-stzmap.adb] - Blame information for rev 706

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 706 jeremybenn
------------------------------------------------------------------------------
2
--                                                                          --
3
--                         GNAT RUN-TIME COMPONENTS                         --
4
--                                                                          --
5
--           A D A . S T R I N G S . W I D E _ W I D E _ M A P S            --
6
--                                                                          --
7
--                                 B o d y                                  --
8
--                                                                          --
9
--          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
10
--                                                                          --
11
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12
-- terms of the  GNU General Public License as published  by the Free Soft- --
13
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16
-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17
--                                                                          --
18
-- As a special exception under Section 7 of GPL version 3, you are granted --
19
-- additional permissions described in the GCC Runtime Library Exception,   --
20
-- version 3.1, as published by the Free Software Foundation.               --
21
--                                                                          --
22
-- You should have received a copy of the GNU General Public License and    --
23
-- a copy of the GCC Runtime Library Exception along with this program;     --
24
-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25
-- <http://www.gnu.org/licenses/>.                                          --
26
--                                                                          --
27
-- GNAT was originally developed  by the GNAT team at  New York University. --
28
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29
--                                                                          --
30
------------------------------------------------------------------------------
31
 
32
with Ada.Unchecked_Deallocation;
33
 
34
package body Ada.Strings.Wide_Wide_Maps is
35
 
36
   ---------
37
   -- "-" --
38
   ---------
39
 
40
   function "-"
41
     (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
42
   is
43
      LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
44
      RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
45
 
46
      Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
47
      --  Each range on the right can generate at least one more range in
48
      --  the result, by splitting one of the left operand ranges.
49
 
50
      N  : Natural := 0;
51
      R  : Natural := 1;
52
      L  : Natural := 1;
53
 
54
      Left_Low : Wide_Wide_Character;
55
      --  Left_Low is lowest character of the L'th range not yet dealt with
56
 
57
   begin
58
      if LS'Last = 0 or else RS'Last = 0 then
59
         return Left;
60
      end if;
61
 
62
      Left_Low := LS (L).Low;
63
      while R <= RS'Last loop
64
 
65
         --  If next right range is below current left range, skip it
66
 
67
         if RS (R).High < Left_Low then
68
            R := R + 1;
69
 
70
         --  If next right range above current left range, copy remainder of
71
         --  the left range to the result
72
 
73
         elsif RS (R).Low > LS (L).High then
74
            N := N + 1;
75
            Result (N).Low  := Left_Low;
76
            Result (N).High := LS (L).High;
77
            L := L + 1;
78
            exit when L > LS'Last;
79
            Left_Low := LS (L).Low;
80
 
81
         else
82
            --  Next right range overlaps bottom of left range
83
 
84
            if RS (R).Low <= Left_Low then
85
 
86
               --  Case of right range complete overlaps left range
87
 
88
               if RS (R).High >= LS (L).High then
89
                  L := L + 1;
90
                  exit when L > LS'Last;
91
                  Left_Low := LS (L).Low;
92
 
93
               --  Case of right range eats lower part of left range
94
 
95
               else
96
                  Left_Low := Wide_Wide_Character'Succ (RS (R).High);
97
                  R := R + 1;
98
               end if;
99
 
100
            --  Next right range overlaps some of left range, but not bottom
101
 
102
            else
103
               N := N + 1;
104
               Result (N).Low  := Left_Low;
105
               Result (N).High := Wide_Wide_Character'Pred (RS (R).Low);
106
 
107
               --  Case of right range splits left range
108
 
109
               if RS (R).High < LS (L).High then
110
                  Left_Low := Wide_Wide_Character'Succ (RS (R).High);
111
                  R := R + 1;
112
 
113
               --  Case of right range overlaps top of left range
114
 
115
               else
116
                  L := L + 1;
117
                  exit when L > LS'Last;
118
                  Left_Low := LS (L).Low;
119
               end if;
120
            end if;
121
         end if;
122
      end loop;
123
 
124
      --  Copy remainder of left ranges to result
125
 
126
      if L <= LS'Last then
127
         N := N + 1;
128
         Result (N).Low  := Left_Low;
129
         Result (N).High := LS (L).High;
130
 
131
         loop
132
            L := L + 1;
133
            exit when L > LS'Last;
134
            N := N + 1;
135
            Result (N) := LS (L);
136
         end loop;
137
      end if;
138
 
139
      return (AF.Controlled with
140
              Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
141
   end "-";
142
 
143
   ---------
144
   -- "=" --
145
   ---------
146
 
147
   --  The sorted, discontiguous form is canonical, so equality can be used
148
 
149
   function "=" (Left, Right : Wide_Wide_Character_Set) return Boolean is
150
   begin
151
      return Left.Set.all = Right.Set.all;
152
   end "=";
153
 
154
   -----------
155
   -- "and" --
156
   -----------
157
 
158
   function "and"
159
     (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
160
   is
161
      LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
162
      RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
163
 
164
      Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
165
      N      : Natural := 0;
166
      L, R   : Natural := 1;
167
 
168
   begin
169
      --  Loop to search for overlapping character ranges
170
 
171
      while L <= LS'Last and then R <= RS'Last loop
172
 
173
         if LS (L).High < RS (R).Low then
174
            L := L + 1;
175
 
176
         elsif RS (R).High < LS (L).Low then
177
            R := R + 1;
178
 
179
         --  Here we have LS (L).High >= RS (R).Low
180
         --           and RS (R).High >= LS (L).Low
181
         --  so we have an overlapping range
182
 
183
         else
184
            N := N + 1;
185
            Result (N).Low :=
186
              Wide_Wide_Character'Max (LS (L).Low,  RS (R).Low);
187
            Result (N).High :=
188
              Wide_Wide_Character'Min (LS (L).High, RS (R).High);
189
 
190
            if RS (R).High = LS (L).High then
191
               L := L + 1;
192
               R := R + 1;
193
            elsif RS (R).High < LS (L).High then
194
               R := R + 1;
195
            else
196
               L := L + 1;
197
            end if;
198
         end if;
199
      end loop;
200
 
201
      return (AF.Controlled with
202
              Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
203
   end "and";
204
 
205
   -----------
206
   -- "not" --
207
   -----------
208
 
209
   function "not"
210
     (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
211
   is
212
      RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
213
 
214
      Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1);
215
      N      : Natural := 0;
216
 
217
   begin
218
      if RS'Last = 0 then
219
         N := 1;
220
         Result (1) := (Low  => Wide_Wide_Character'First,
221
                        High => Wide_Wide_Character'Last);
222
 
223
      else
224
         if RS (1).Low /= Wide_Wide_Character'First then
225
            N := N + 1;
226
            Result (N).Low  := Wide_Wide_Character'First;
227
            Result (N).High := Wide_Wide_Character'Pred (RS (1).Low);
228
         end if;
229
 
230
         for K in 1 .. RS'Last - 1 loop
231
            N := N + 1;
232
            Result (N).Low  := Wide_Wide_Character'Succ (RS (K).High);
233
            Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low);
234
         end loop;
235
 
236
         if RS (RS'Last).High /= Wide_Wide_Character'Last then
237
            N := N + 1;
238
            Result (N).Low  := Wide_Wide_Character'Succ (RS (RS'Last).High);
239
            Result (N).High := Wide_Wide_Character'Last;
240
         end if;
241
      end if;
242
 
243
      return (AF.Controlled with
244
              Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
245
   end "not";
246
 
247
   ----------
248
   -- "or" --
249
   ----------
250
 
251
   function "or"
252
     (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
253
   is
254
      LS : constant Wide_Wide_Character_Ranges_Access := Left.Set;
255
      RS : constant Wide_Wide_Character_Ranges_Access := Right.Set;
256
 
257
      Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last);
258
      N      : Natural;
259
      L, R   : Natural;
260
 
261
   begin
262
      N := 0;
263
      L := 1;
264
      R := 1;
265
 
266
      --  Loop through ranges in output file
267
 
268
      loop
269
         --  If no left ranges left, copy next right range
270
 
271
         if L > LS'Last then
272
            exit when R > RS'Last;
273
            N := N + 1;
274
            Result (N) := RS (R);
275
            R := R + 1;
276
 
277
         --  If no right ranges left, copy next left range
278
 
279
         elsif R > RS'Last then
280
            N := N + 1;
281
            Result (N) := LS (L);
282
            L := L + 1;
283
 
284
         else
285
            --  We have two ranges, choose lower one
286
 
287
            N := N + 1;
288
 
289
            if LS (L).Low <= RS (R).Low then
290
               Result (N) := LS (L);
291
               L := L + 1;
292
            else
293
               Result (N) := RS (R);
294
               R := R + 1;
295
            end if;
296
 
297
            --  Loop to collapse ranges into last range
298
 
299
            loop
300
               --  Collapse next length range into current result range
301
               --  if possible.
302
 
303
               if L <= LS'Last
304
                 and then LS (L).Low <=
305
                          Wide_Wide_Character'Succ (Result (N).High)
306
               then
307
                  Result (N).High :=
308
                    Wide_Wide_Character'Max (Result (N).High, LS (L).High);
309
                  L := L + 1;
310
 
311
               --  Collapse next right range into current result range
312
               --  if possible
313
 
314
               elsif R <= RS'Last
315
                 and then RS (R).Low <=
316
                            Wide_Wide_Character'Succ (Result (N).High)
317
               then
318
                  Result (N).High :=
319
                    Wide_Wide_Character'Max (Result (N).High, RS (R).High);
320
                  R := R + 1;
321
 
322
               --  If neither range collapses, then done with this range
323
 
324
               else
325
                  exit;
326
               end if;
327
            end loop;
328
         end if;
329
      end loop;
330
 
331
      return (AF.Controlled with
332
              Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
333
   end "or";
334
 
335
   -----------
336
   -- "xor" --
337
   -----------
338
 
339
   function "xor"
340
     (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set
341
   is
342
   begin
343
      return (Left or Right) - (Left and Right);
344
   end "xor";
345
 
346
   ------------
347
   -- Adjust --
348
   ------------
349
 
350
   procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is
351
   begin
352
      Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all);
353
   end Adjust;
354
 
355
   procedure Adjust (Object : in out Wide_Wide_Character_Set) is
356
   begin
357
      Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all);
358
   end Adjust;
359
 
360
   --------------
361
   -- Finalize --
362
   --------------
363
 
364
   procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is
365
 
366
      procedure Free is new Ada.Unchecked_Deallocation
367
        (Wide_Wide_Character_Mapping_Values,
368
         Wide_Wide_Character_Mapping_Values_Access);
369
 
370
   begin
371
      if Object.Map /=  Null_Map'Unrestricted_Access then
372
         Free (Object.Map);
373
      end if;
374
   end Finalize;
375
 
376
   procedure Finalize (Object : in out Wide_Wide_Character_Set) is
377
 
378
      procedure Free is new Ada.Unchecked_Deallocation
379
        (Wide_Wide_Character_Ranges,
380
         Wide_Wide_Character_Ranges_Access);
381
 
382
   begin
383
      if Object.Set /= Null_Range'Unrestricted_Access then
384
         Free (Object.Set);
385
      end if;
386
   end Finalize;
387
 
388
   ----------------
389
   -- Initialize --
390
   ----------------
391
 
392
   procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is
393
   begin
394
      Object := Identity;
395
   end Initialize;
396
 
397
   procedure Initialize (Object : in out Wide_Wide_Character_Set) is
398
   begin
399
      Object := Null_Set;
400
   end Initialize;
401
 
402
   -----------
403
   -- Is_In --
404
   -----------
405
 
406
   function Is_In
407
     (Element : Wide_Wide_Character;
408
      Set     : Wide_Wide_Character_Set) return Boolean
409
   is
410
      L, R, M : Natural;
411
      SS      : constant Wide_Wide_Character_Ranges_Access := Set.Set;
412
 
413
   begin
414
      L := 1;
415
      R := SS'Last;
416
 
417
      --  Binary search loop. The invariant is that if Element is in any of
418
      --  of the constituent ranges it is in one between Set (L) and Set (R).
419
 
420
      loop
421
         if L > R then
422
            return False;
423
 
424
         else
425
            M := (L + R) / 2;
426
 
427
            if Element > SS (M).High then
428
               L := M + 1;
429
            elsif Element < SS (M).Low then
430
               R := M - 1;
431
            else
432
               return True;
433
            end if;
434
         end if;
435
      end loop;
436
   end Is_In;
437
 
438
   ---------------
439
   -- Is_Subset --
440
   ---------------
441
 
442
   function Is_Subset
443
     (Elements : Wide_Wide_Character_Set;
444
      Set      : Wide_Wide_Character_Set) return Boolean
445
   is
446
      ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set;
447
      SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
448
 
449
      S  : Positive := 1;
450
      E  : Positive := 1;
451
 
452
   begin
453
      loop
454
         --  If no more element ranges, done, and result is true
455
 
456
         if E > ES'Last then
457
            return True;
458
 
459
         --  If more element ranges, but no more set ranges, result is false
460
 
461
         elsif S > SS'Last then
462
            return False;
463
 
464
         --  Remove irrelevant set range
465
 
466
         elsif SS (S).High < ES (E).Low then
467
            S := S + 1;
468
 
469
         --  Get rid of element range that is properly covered by set
470
 
471
         elsif SS (S).Low <= ES (E).Low
472
            and then ES (E).High <= SS (S).High
473
         then
474
            E := E + 1;
475
 
476
         --  Otherwise we have a non-covered element range, result is false
477
 
478
         else
479
            return False;
480
         end if;
481
      end loop;
482
   end Is_Subset;
483
 
484
   ---------------
485
   -- To_Domain --
486
   ---------------
487
 
488
   function To_Domain
489
     (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
490
   is
491
   begin
492
      return Map.Map.Domain;
493
   end To_Domain;
494
 
495
   ----------------
496
   -- To_Mapping --
497
   ----------------
498
 
499
   function To_Mapping
500
     (From, To : Wide_Wide_Character_Sequence)
501
     return Wide_Wide_Character_Mapping
502
   is
503
      Domain : Wide_Wide_Character_Sequence (1 .. From'Length);
504
      Rangev : Wide_Wide_Character_Sequence (1 .. To'Length);
505
      N      : Natural := 0;
506
 
507
   begin
508
      if From'Length /= To'Length then
509
         raise Translation_Error;
510
 
511
      else
512
         pragma Warnings (Off); -- apparent uninit use of Domain
513
 
514
         for J in From'Range loop
515
            for M in 1 .. N loop
516
               if From (J) = Domain (M) then
517
                  raise Translation_Error;
518
               elsif From (J) < Domain (M) then
519
                  Domain (M + 1 .. N + 1) := Domain (M .. N);
520
                  Rangev (M + 1 .. N + 1) := Rangev (M .. N);
521
                  Domain (M) := From (J);
522
                  Rangev (M) := To   (J);
523
                  goto Continue;
524
               end if;
525
            end loop;
526
 
527
            Domain (N + 1) := From (J);
528
            Rangev (N + 1) := To   (J);
529
 
530
            <<Continue>>
531
               N := N + 1;
532
         end loop;
533
 
534
         pragma Warnings (On);
535
 
536
         return (AF.Controlled with
537
                 Map => new Wide_Wide_Character_Mapping_Values'(
538
                          Length => N,
539
                          Domain => Domain (1 .. N),
540
                          Rangev => Rangev (1 .. N)));
541
      end if;
542
   end To_Mapping;
543
 
544
   --------------
545
   -- To_Range --
546
   --------------
547
 
548
   function To_Range
549
     (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence
550
   is
551
   begin
552
      return Map.Map.Rangev;
553
   end To_Range;
554
 
555
   ---------------
556
   -- To_Ranges --
557
   ---------------
558
 
559
   function To_Ranges
560
     (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges
561
   is
562
   begin
563
      return Set.Set.all;
564
   end To_Ranges;
565
 
566
   -----------------
567
   -- To_Sequence --
568
   -----------------
569
 
570
   function To_Sequence
571
     (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence
572
   is
573
      SS : constant Wide_Wide_Character_Ranges_Access := Set.Set;
574
 
575
      Result : Wide_Wide_String (Positive range 1 .. 2 ** 16);
576
      N      : Natural := 0;
577
 
578
   begin
579
      for J in SS'Range loop
580
         for K in SS (J).Low .. SS (J).High loop
581
            N := N + 1;
582
            Result (N) := K;
583
         end loop;
584
      end loop;
585
 
586
      return Result (1 .. N);
587
   end To_Sequence;
588
 
589
   ------------
590
   -- To_Set --
591
   ------------
592
 
593
   --  Case of multiple range input
594
 
595
   function To_Set
596
     (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set
597
   is
598
      Result : Wide_Wide_Character_Ranges (Ranges'Range);
599
      N      : Natural := 0;
600
      J      : Natural;
601
 
602
   begin
603
      --  The output of To_Set is required to be sorted by increasing Low
604
      --  values, and discontiguous, so first we sort them as we enter them,
605
      --  using a simple insertion sort.
606
 
607
      pragma Warnings (Off);
608
      --  Kill bogus warning on Result being uninitialized
609
 
610
      for J in Ranges'Range loop
611
         for K in 1 .. N loop
612
            if Ranges (J).Low < Result (K).Low then
613
               Result (K + 1 .. N + 1) := Result (K .. N);
614
               Result (K) := Ranges (J);
615
               goto Continue;
616
            end if;
617
         end loop;
618
 
619
         Result (N + 1) := Ranges (J);
620
 
621
         <<Continue>>
622
            N := N + 1;
623
      end loop;
624
 
625
      pragma Warnings (On);
626
 
627
      --  Now collapse any contiguous or overlapping ranges
628
 
629
      J := 1;
630
      while J < N loop
631
         if Result (J).High < Result (J).Low then
632
            N := N - 1;
633
            Result (J .. N) := Result (J + 1 .. N + 1);
634
 
635
         elsif Wide_Wide_Character'Succ (Result (J).High) >=
636
           Result (J + 1).Low
637
         then
638
            Result (J).High :=
639
              Wide_Wide_Character'Max (Result (J).High, Result (J + 1).High);
640
 
641
            N := N - 1;
642
            Result (J + 1 .. N) := Result (J + 2 .. N + 1);
643
 
644
         else
645
            J := J + 1;
646
         end if;
647
      end loop;
648
 
649
      if Result (N).High < Result (N).Low then
650
         N := N - 1;
651
      end if;
652
 
653
      return (AF.Controlled with
654
              Set => new Wide_Wide_Character_Ranges'(Result (1 .. N)));
655
   end To_Set;
656
 
657
   --  Case of single range input
658
 
659
   function To_Set
660
     (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set
661
   is
662
   begin
663
      if Span.Low > Span.High then
664
         return Null_Set;
665
         --  This is safe, because there is no procedure with parameter
666
         --  Wide_Wide_Character_Set of mode "out" or "in out".
667
 
668
      else
669
         return (AF.Controlled with
670
                 Set => new Wide_Wide_Character_Ranges'(1 => Span));
671
      end if;
672
   end To_Set;
673
 
674
   --  Case of wide string input
675
 
676
   function To_Set
677
     (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set
678
   is
679
      R : Wide_Wide_Character_Ranges (1 .. Sequence'Length);
680
 
681
   begin
682
      for J in R'Range loop
683
         R (J) := (Sequence (J), Sequence (J));
684
      end loop;
685
 
686
      return To_Set (R);
687
   end To_Set;
688
 
689
   --  Case of single wide character input
690
 
691
   function To_Set
692
     (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set
693
   is
694
   begin
695
      return
696
        (AF.Controlled with
697
         Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton)));
698
   end To_Set;
699
 
700
   -----------
701
   -- Value --
702
   -----------
703
 
704
   function Value
705
     (Map     : Wide_Wide_Character_Mapping;
706
      Element : Wide_Wide_Character) return Wide_Wide_Character
707
   is
708
      L, R, M : Natural;
709
 
710
      MV : constant Wide_Wide_Character_Mapping_Values_Access := Map.Map;
711
 
712
   begin
713
      L := 1;
714
      R := MV.Domain'Last;
715
 
716
      --  Binary search loop
717
 
718
      loop
719
         --  If not found, identity
720
 
721
         if L > R then
722
            return Element;
723
 
724
         --  Otherwise do binary divide
725
 
726
         else
727
            M := (L + R) / 2;
728
 
729
            if Element < MV.Domain (M) then
730
               R := M - 1;
731
 
732
            elsif Element > MV.Domain (M) then
733
               L := M + 1;
734
 
735
            else --  Element = MV.Domain (M) then
736
               return MV.Rangev (M);
737
            end if;
738
         end if;
739
      end loop;
740
   end Value;
741
 
742
end Ada.Strings.Wide_Wide_Maps;

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.