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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [ada/] [i-cobol.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
--                     I N T E R F A C E S . C O B O L                      --
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
--  The body of Interfaces.COBOL is implementation independent (i.e. the same
33
--  version is used with all versions of GNAT). The specialization to a
34
--  particular COBOL format is completely contained in the private part of
35
--  the spec.
36
 
37
with Interfaces; use Interfaces;
38
with System;     use System;
39
with Ada.Unchecked_Conversion;
40
 
41
package body Interfaces.COBOL is
42
 
43
   -----------------------------------------------
44
   -- Declarations for External Binary Handling --
45
   -----------------------------------------------
46
 
47
   subtype B1 is Byte_Array (1 .. 1);
48
   subtype B2 is Byte_Array (1 .. 2);
49
   subtype B4 is Byte_Array (1 .. 4);
50
   subtype B8 is Byte_Array (1 .. 8);
51
   --  Representations for 1,2,4,8 byte binary values
52
 
53
   function To_B1 is new Ada.Unchecked_Conversion (Integer_8,  B1);
54
   function To_B2 is new Ada.Unchecked_Conversion (Integer_16, B2);
55
   function To_B4 is new Ada.Unchecked_Conversion (Integer_32, B4);
56
   function To_B8 is new Ada.Unchecked_Conversion (Integer_64, B8);
57
   --  Conversions from native binary to external binary
58
 
59
   function From_B1 is new Ada.Unchecked_Conversion (B1, Integer_8);
60
   function From_B2 is new Ada.Unchecked_Conversion (B2, Integer_16);
61
   function From_B4 is new Ada.Unchecked_Conversion (B4, Integer_32);
62
   function From_B8 is new Ada.Unchecked_Conversion (B8, Integer_64);
63
   --  Conversions from external binary to signed native binary
64
 
65
   function From_B1U is new Ada.Unchecked_Conversion (B1, Unsigned_8);
66
   function From_B2U is new Ada.Unchecked_Conversion (B2, Unsigned_16);
67
   function From_B4U is new Ada.Unchecked_Conversion (B4, Unsigned_32);
68
   function From_B8U is new Ada.Unchecked_Conversion (B8, Unsigned_64);
69
   --  Conversions from external binary to unsigned native binary
70
 
71
   -----------------------
72
   -- Local Subprograms --
73
   -----------------------
74
 
75
   function Binary_To_Decimal
76
     (Item   : Byte_Array;
77
      Format : Binary_Format) return Integer_64;
78
   --  This function converts a numeric value in the given format to its
79
   --  corresponding integer value. This is the non-generic implementation
80
   --  of Decimal_Conversions.To_Decimal. The generic routine does the
81
   --  final conversion to the fixed-point format.
82
 
83
   function Numeric_To_Decimal
84
     (Item   : Numeric;
85
      Format : Display_Format) return Integer_64;
86
   --  This function converts a numeric value in the given format to its
87
   --  corresponding integer value. This is the non-generic implementation
88
   --  of Decimal_Conversions.To_Decimal. The generic routine does the
89
   --  final conversion to the fixed-point format.
90
 
91
   function Packed_To_Decimal
92
     (Item   : Packed_Decimal;
93
      Format : Packed_Format) return Integer_64;
94
   --  This function converts a packed value in the given format to its
95
   --  corresponding integer value. This is the non-generic implementation
96
   --  of Decimal_Conversions.To_Decimal. The generic routine does the
97
   --  final conversion to the fixed-point format.
98
 
99
   procedure Swap (B : in out Byte_Array; F : Binary_Format);
100
   --  Swaps the bytes if required by the binary format F
101
 
102
   function To_Display
103
     (Item   : Integer_64;
104
      Format : Display_Format;
105
      Length : Natural) return Numeric;
106
   --  This function converts the given integer value into display format,
107
   --  using the given format, with the length in bytes of the result given
108
   --  by the last parameter. This is the non-generic implementation of
109
   --  Decimal_Conversions.To_Display. The conversion of the item from its
110
   --  original decimal format to Integer_64 is done by the generic routine.
111
 
112
   function To_Packed
113
     (Item   : Integer_64;
114
      Format : Packed_Format;
115
      Length : Natural) return Packed_Decimal;
116
   --  This function converts the given integer value into packed format,
117
   --  using the given format, with the length in digits of the result given
118
   --  by the last parameter. This is the non-generic implementation of
119
   --  Decimal_Conversions.To_Display. The conversion of the item from its
120
   --  original decimal format to Integer_64 is done by the generic routine.
121
 
122
   function Valid_Numeric
123
     (Item   : Numeric;
124
      Format : Display_Format) return Boolean;
125
   --  This is the non-generic implementation of Decimal_Conversions.Valid
126
   --  for the display case.
127
 
128
   function Valid_Packed
129
     (Item   : Packed_Decimal;
130
      Format : Packed_Format) return Boolean;
131
   --  This is the non-generic implementation of Decimal_Conversions.Valid
132
   --  for the packed case.
133
 
134
   -----------------------
135
   -- Binary_To_Decimal --
136
   -----------------------
137
 
138
   function Binary_To_Decimal
139
     (Item   : Byte_Array;
140
      Format : Binary_Format) return Integer_64
141
   is
142
      Len : constant Natural := Item'Length;
143
 
144
   begin
145
      if Len = 1 then
146
         if Format in Binary_Unsigned_Format then
147
            return Integer_64 (From_B1U (Item));
148
         else
149
            return Integer_64 (From_B1 (Item));
150
         end if;
151
 
152
      elsif Len = 2 then
153
         declare
154
            R : B2 := Item;
155
 
156
         begin
157
            Swap (R, Format);
158
 
159
            if Format in Binary_Unsigned_Format then
160
               return Integer_64 (From_B2U (R));
161
            else
162
               return Integer_64 (From_B2 (R));
163
            end if;
164
         end;
165
 
166
      elsif Len = 4 then
167
         declare
168
            R : B4 := Item;
169
 
170
         begin
171
            Swap (R, Format);
172
 
173
            if Format in Binary_Unsigned_Format then
174
               return Integer_64 (From_B4U (R));
175
            else
176
               return Integer_64 (From_B4 (R));
177
            end if;
178
         end;
179
 
180
      elsif Len = 8 then
181
         declare
182
            R : B8 := Item;
183
 
184
         begin
185
            Swap (R, Format);
186
 
187
            if Format in Binary_Unsigned_Format then
188
               return Integer_64 (From_B8U (R));
189
            else
190
               return Integer_64 (From_B8 (R));
191
            end if;
192
         end;
193
 
194
      --  Length is not 1, 2, 4 or 8
195
 
196
      else
197
         raise Conversion_Error;
198
      end if;
199
   end Binary_To_Decimal;
200
 
201
   ------------------------
202
   -- Numeric_To_Decimal --
203
   ------------------------
204
 
205
   --  The following assumptions are made in the coding of this routine:
206
 
207
   --    The range of COBOL_Digits is compact and the ten values
208
   --    represent the digits 0-9 in sequence
209
 
210
   --    The range of COBOL_Plus_Digits is compact and the ten values
211
   --    represent the digits 0-9 in sequence with a plus sign.
212
 
213
   --    The range of COBOL_Minus_Digits is compact and the ten values
214
   --    represent the digits 0-9 in sequence with a minus sign.
215
 
216
   --    The COBOL_Minus_Digits set is disjoint from COBOL_Digits
217
 
218
   --  These assumptions are true for all COBOL representations we know of
219
 
220
   function Numeric_To_Decimal
221
     (Item   : Numeric;
222
      Format : Display_Format) return Integer_64
223
   is
224
      pragma Unsuppress (Range_Check);
225
      Sign   : COBOL_Character := COBOL_Plus;
226
      Result : Integer_64 := 0;
227
 
228
   begin
229
      if not Valid_Numeric (Item, Format) then
230
         raise Conversion_Error;
231
      end if;
232
 
233
      for J in Item'Range loop
234
         declare
235
            K : constant COBOL_Character := Item (J);
236
 
237
         begin
238
            if K in COBOL_Digits then
239
               Result := Result * 10 +
240
                           (COBOL_Character'Pos (K) -
241
                             COBOL_Character'Pos (COBOL_Digits'First));
242
 
243
            elsif K in COBOL_Plus_Digits then
244
               Result := Result * 10 +
245
                           (COBOL_Character'Pos (K) -
246
                             COBOL_Character'Pos (COBOL_Plus_Digits'First));
247
 
248
            elsif K in COBOL_Minus_Digits then
249
               Result := Result * 10 +
250
                           (COBOL_Character'Pos (K) -
251
                             COBOL_Character'Pos (COBOL_Minus_Digits'First));
252
               Sign := COBOL_Minus;
253
 
254
            --  Only remaining possibility is COBOL_Plus or COBOL_Minus
255
 
256
            else
257
               Sign := K;
258
            end if;
259
         end;
260
      end loop;
261
 
262
      if Sign = COBOL_Plus then
263
         return Result;
264
      else
265
         return -Result;
266
      end if;
267
 
268
   exception
269
      when Constraint_Error =>
270
         raise Conversion_Error;
271
 
272
   end Numeric_To_Decimal;
273
 
274
   -----------------------
275
   -- Packed_To_Decimal --
276
   -----------------------
277
 
278
   function Packed_To_Decimal
279
     (Item   : Packed_Decimal;
280
      Format : Packed_Format) return Integer_64
281
   is
282
      pragma Unsuppress (Range_Check);
283
      Result : Integer_64 := 0;
284
      Sign   : constant Decimal_Element := Item (Item'Last);
285
 
286
   begin
287
      if not Valid_Packed (Item, Format) then
288
         raise Conversion_Error;
289
      end if;
290
 
291
      case Packed_Representation is
292
         when IBM =>
293
            for J in Item'First .. Item'Last - 1 loop
294
               Result := Result * 10 + Integer_64 (Item (J));
295
            end loop;
296
 
297
            if Sign = 16#0B# or else Sign = 16#0D# then
298
               return -Result;
299
            else
300
               return +Result;
301
            end if;
302
      end case;
303
 
304
   exception
305
      when Constraint_Error =>
306
         raise Conversion_Error;
307
   end Packed_To_Decimal;
308
 
309
   ----------
310
   -- Swap --
311
   ----------
312
 
313
   procedure Swap (B : in out Byte_Array; F : Binary_Format) is
314
      Little_Endian : constant Boolean :=
315
                        System.Default_Bit_Order = System.Low_Order_First;
316
 
317
   begin
318
      --  Return if no swap needed
319
 
320
      case F is
321
         when H | HU =>
322
            if not Little_Endian then
323
               return;
324
            end if;
325
 
326
         when L | LU =>
327
            if Little_Endian then
328
               return;
329
            end if;
330
 
331
         when N | NU =>
332
            return;
333
      end case;
334
 
335
      --  Here a swap is needed
336
 
337
      declare
338
         Len : constant Natural := B'Length;
339
 
340
      begin
341
         for J in 1 .. Len / 2 loop
342
            declare
343
               Temp : constant Byte := B (J);
344
 
345
            begin
346
               B (J) := B (Len + 1 - J);
347
               B (Len + 1 - J) := Temp;
348
            end;
349
         end loop;
350
      end;
351
   end Swap;
352
 
353
   -----------------------
354
   -- To_Ada (function) --
355
   -----------------------
356
 
357
   function To_Ada (Item : Alphanumeric) return String is
358
      Result : String (Item'Range);
359
 
360
   begin
361
      for J in Item'Range loop
362
         Result (J) := COBOL_To_Ada (Item (J));
363
      end loop;
364
 
365
      return Result;
366
   end To_Ada;
367
 
368
   ------------------------
369
   -- To_Ada (procedure) --
370
   ------------------------
371
 
372
   procedure To_Ada
373
     (Item   : Alphanumeric;
374
      Target : out String;
375
      Last   : out Natural)
376
   is
377
      Last_Val : Integer;
378
 
379
   begin
380
      if Item'Length > Target'Length then
381
         raise Constraint_Error;
382
      end if;
383
 
384
      Last_Val := Target'First - 1;
385
      for J in Item'Range loop
386
         Last_Val := Last_Val + 1;
387
         Target (Last_Val) := COBOL_To_Ada (Item (J));
388
      end loop;
389
 
390
      Last := Last_Val;
391
   end To_Ada;
392
 
393
   -------------------------
394
   -- To_COBOL (function) --
395
   -------------------------
396
 
397
   function To_COBOL (Item : String) return Alphanumeric is
398
      Result : Alphanumeric (Item'Range);
399
 
400
   begin
401
      for J in Item'Range loop
402
         Result (J) := Ada_To_COBOL (Item (J));
403
      end loop;
404
 
405
      return Result;
406
   end To_COBOL;
407
 
408
   --------------------------
409
   -- To_COBOL (procedure) --
410
   --------------------------
411
 
412
   procedure To_COBOL
413
     (Item   : String;
414
      Target : out Alphanumeric;
415
      Last   : out Natural)
416
   is
417
      Last_Val : Integer;
418
 
419
   begin
420
      if Item'Length > Target'Length then
421
         raise Constraint_Error;
422
      end if;
423
 
424
      Last_Val := Target'First - 1;
425
      for J in Item'Range loop
426
         Last_Val := Last_Val + 1;
427
         Target (Last_Val) := Ada_To_COBOL (Item (J));
428
      end loop;
429
 
430
      Last := Last_Val;
431
   end To_COBOL;
432
 
433
   ----------------
434
   -- To_Display --
435
   ----------------
436
 
437
   function To_Display
438
     (Item   : Integer_64;
439
      Format : Display_Format;
440
      Length : Natural) return Numeric
441
   is
442
      Result : Numeric (1 .. Length);
443
      Val    : Integer_64 := Item;
444
 
445
      procedure Convert (First, Last : Natural);
446
      --  Convert the number in Val into COBOL_Digits, storing the result
447
      --  in Result (First .. Last). Raise Conversion_Error if too large.
448
 
449
      procedure Embed_Sign (Loc : Natural);
450
      --  Used for the nonseparate formats to embed the appropriate sign
451
      --  at the specified location (i.e. at Result (Loc))
452
 
453
      -------------
454
      -- Convert --
455
      -------------
456
 
457
      procedure Convert (First, Last : Natural) is
458
         J : Natural;
459
 
460
      begin
461
         J := Last;
462
         while J >= First loop
463
            Result (J) :=
464
              COBOL_Character'Val
465
                (COBOL_Character'Pos (COBOL_Digits'First) +
466
                                                   Integer (Val mod 10));
467
            Val := Val / 10;
468
 
469
            if Val = 0 then
470
               for K in First .. J - 1 loop
471
                  Result (J) := COBOL_Digits'First;
472
               end loop;
473
 
474
               return;
475
 
476
            else
477
               J := J - 1;
478
            end if;
479
         end loop;
480
 
481
         raise Conversion_Error;
482
      end Convert;
483
 
484
      ----------------
485
      -- Embed_Sign --
486
      ----------------
487
 
488
      procedure Embed_Sign (Loc : Natural) is
489
         Digit : Natural range 0 .. 9;
490
 
491
      begin
492
         Digit := COBOL_Character'Pos (Result (Loc)) -
493
                  COBOL_Character'Pos (COBOL_Digits'First);
494
 
495
         if Item >= 0 then
496
            Result (Loc) :=
497
              COBOL_Character'Val
498
                (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit);
499
         else
500
            Result (Loc) :=
501
              COBOL_Character'Val
502
                (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit);
503
         end if;
504
      end Embed_Sign;
505
 
506
   --  Start of processing for To_Display
507
 
508
   begin
509
      case Format is
510
         when Unsigned =>
511
            if Val < 0 then
512
               raise Conversion_Error;
513
            else
514
               Convert (1, Length);
515
            end if;
516
 
517
         when Leading_Separate =>
518
            if Val < 0 then
519
               Result (1) := COBOL_Minus;
520
               Val := -Val;
521
            else
522
               Result (1) := COBOL_Plus;
523
            end if;
524
 
525
            Convert (2, Length);
526
 
527
         when Trailing_Separate =>
528
            if Val < 0 then
529
               Result (Length) := COBOL_Minus;
530
               Val := -Val;
531
            else
532
               Result (Length) := COBOL_Plus;
533
            end if;
534
 
535
            Convert (1, Length - 1);
536
 
537
         when Leading_Nonseparate =>
538
            Val := abs Val;
539
            Convert (1, Length);
540
            Embed_Sign (1);
541
 
542
         when Trailing_Nonseparate =>
543
            Val := abs Val;
544
            Convert (1, Length);
545
            Embed_Sign (Length);
546
 
547
      end case;
548
 
549
      return Result;
550
   end To_Display;
551
 
552
   ---------------
553
   -- To_Packed --
554
   ---------------
555
 
556
   function To_Packed
557
     (Item   : Integer_64;
558
      Format : Packed_Format;
559
      Length : Natural) return Packed_Decimal
560
   is
561
      Result : Packed_Decimal (1 .. Length);
562
      Val    : Integer_64;
563
 
564
      procedure Convert (First, Last : Natural);
565
      --  Convert the number in Val into a sequence of Decimal_Element values,
566
      --  storing the result in Result (First .. Last). Raise Conversion_Error
567
      --  if the value is too large to fit.
568
 
569
      -------------
570
      -- Convert --
571
      -------------
572
 
573
      procedure Convert (First, Last : Natural) is
574
         J : Natural := Last;
575
 
576
      begin
577
         while J >= First loop
578
            Result (J) := Decimal_Element (Val mod 10);
579
 
580
            Val := Val / 10;
581
 
582
            if Val = 0 then
583
               for K in First .. J - 1 loop
584
                  Result (K) := 0;
585
               end loop;
586
 
587
               return;
588
 
589
            else
590
               J := J - 1;
591
            end if;
592
         end loop;
593
 
594
         raise Conversion_Error;
595
      end Convert;
596
 
597
   --  Start of processing for To_Packed
598
 
599
   begin
600
      case Packed_Representation is
601
         when IBM =>
602
            if Format = Packed_Unsigned then
603
               if Item < 0 then
604
                  raise Conversion_Error;
605
               else
606
                  Result (Length) := 16#F#;
607
                  Val := Item;
608
               end if;
609
 
610
            elsif Item >= 0 then
611
               Result (Length) := 16#C#;
612
               Val := Item;
613
 
614
            else -- Item < 0
615
               Result (Length) := 16#D#;
616
               Val := -Item;
617
            end if;
618
 
619
            Convert (1, Length - 1);
620
            return Result;
621
      end case;
622
   end To_Packed;
623
 
624
   -------------------
625
   -- Valid_Numeric --
626
   -------------------
627
 
628
   function Valid_Numeric
629
     (Item   : Numeric;
630
      Format : Display_Format) return Boolean
631
   is
632
   begin
633
      if Item'Length = 0 then
634
         return False;
635
      end if;
636
 
637
      --  All character positions except first and last must be Digits.
638
      --  This is true for all the formats.
639
 
640
      for J in Item'First + 1 .. Item'Last - 1 loop
641
         if Item (J) not in COBOL_Digits then
642
            return False;
643
         end if;
644
      end loop;
645
 
646
      case Format is
647
         when Unsigned =>
648
            return Item (Item'First) in COBOL_Digits
649
              and then Item (Item'Last) in COBOL_Digits;
650
 
651
         when Leading_Separate =>
652
            return (Item (Item'First) = COBOL_Plus or else
653
                    Item (Item'First) = COBOL_Minus)
654
              and then Item (Item'Last) in COBOL_Digits;
655
 
656
         when Trailing_Separate =>
657
            return Item (Item'First) in COBOL_Digits
658
              and then
659
                (Item (Item'Last) = COBOL_Plus or else
660
                 Item (Item'Last) = COBOL_Minus);
661
 
662
         when Leading_Nonseparate =>
663
            return (Item (Item'First) in COBOL_Plus_Digits or else
664
                    Item (Item'First) in COBOL_Minus_Digits)
665
              and then Item (Item'Last) in COBOL_Digits;
666
 
667
         when Trailing_Nonseparate =>
668
            return Item (Item'First) in COBOL_Digits
669
              and then
670
                (Item (Item'Last) in COBOL_Plus_Digits or else
671
                 Item (Item'Last) in COBOL_Minus_Digits);
672
 
673
      end case;
674
   end Valid_Numeric;
675
 
676
   ------------------
677
   -- Valid_Packed --
678
   ------------------
679
 
680
   function Valid_Packed
681
     (Item   : Packed_Decimal;
682
      Format : Packed_Format) return Boolean
683
   is
684
   begin
685
      case Packed_Representation is
686
         when IBM =>
687
            for J in Item'First .. Item'Last - 1 loop
688
               if Item (J) > 9 then
689
                  return False;
690
               end if;
691
            end loop;
692
 
693
            --  For unsigned, sign digit must be F
694
 
695
            if Format = Packed_Unsigned then
696
               return Item (Item'Last) = 16#F#;
697
 
698
            --  For signed, accept all standard and non-standard signs
699
 
700
            else
701
               return Item (Item'Last) in 16#A# .. 16#F#;
702
            end if;
703
      end case;
704
   end Valid_Packed;
705
 
706
   -------------------------
707
   -- Decimal_Conversions --
708
   -------------------------
709
 
710
   package body Decimal_Conversions is
711
 
712
      ---------------------
713
      -- Length (binary) --
714
      ---------------------
715
 
716
      --  Note that the tests here are all compile time tests
717
 
718
      function Length (Format : Binary_Format) return Natural is
719
         pragma Unreferenced (Format);
720
      begin
721
         if Num'Digits <= 2 then
722
            return 1;
723
         elsif Num'Digits <= 4 then
724
            return 2;
725
         elsif Num'Digits <= 9 then
726
            return 4;
727
         else -- Num'Digits in 10 .. 18
728
            return 8;
729
         end if;
730
      end Length;
731
 
732
      ----------------------
733
      -- Length (display) --
734
      ----------------------
735
 
736
      function Length (Format : Display_Format) return Natural is
737
      begin
738
         if Format = Leading_Separate or else Format = Trailing_Separate then
739
            return Num'Digits + 1;
740
         else
741
            return Num'Digits;
742
         end if;
743
      end Length;
744
 
745
      ---------------------
746
      -- Length (packed) --
747
      ---------------------
748
 
749
      --  Note that the tests here are all compile time checks
750
 
751
      function Length
752
        (Format : Packed_Format) return Natural
753
      is
754
         pragma Unreferenced (Format);
755
      begin
756
         case Packed_Representation is
757
            when IBM =>
758
               return (Num'Digits + 2) / 2 * 2;
759
         end case;
760
      end Length;
761
 
762
      ---------------
763
      -- To_Binary --
764
      ---------------
765
 
766
      function To_Binary
767
        (Item   : Num;
768
         Format : Binary_Format) return Byte_Array
769
      is
770
      begin
771
         --  Note: all these tests are compile time tests
772
 
773
         if Num'Digits <= 2 then
774
            return To_B1 (Integer_8'Integer_Value (Item));
775
 
776
         elsif Num'Digits <= 4 then
777
            declare
778
               R : B2 := To_B2 (Integer_16'Integer_Value (Item));
779
 
780
            begin
781
               Swap (R, Format);
782
               return R;
783
            end;
784
 
785
         elsif Num'Digits <= 9 then
786
            declare
787
               R : B4 := To_B4 (Integer_32'Integer_Value (Item));
788
 
789
            begin
790
               Swap (R, Format);
791
               return R;
792
            end;
793
 
794
         else -- Num'Digits in 10 .. 18
795
            declare
796
               R : B8 := To_B8 (Integer_64'Integer_Value (Item));
797
 
798
            begin
799
               Swap (R, Format);
800
               return R;
801
            end;
802
         end if;
803
 
804
      exception
805
         when Constraint_Error =>
806
            raise Conversion_Error;
807
      end To_Binary;
808
 
809
      ---------------------------------
810
      -- To_Binary (internal binary) --
811
      ---------------------------------
812
 
813
      function To_Binary (Item : Num) return Binary is
814
         pragma Unsuppress (Range_Check);
815
      begin
816
         return Binary'Integer_Value (Item);
817
      exception
818
         when Constraint_Error =>
819
            raise Conversion_Error;
820
      end To_Binary;
821
 
822
      -------------------------
823
      -- To_Decimal (binary) --
824
      -------------------------
825
 
826
      function To_Decimal
827
        (Item   : Byte_Array;
828
         Format : Binary_Format) return Num
829
      is
830
         pragma Unsuppress (Range_Check);
831
      begin
832
         return Num'Fixed_Value (Binary_To_Decimal (Item, Format));
833
      exception
834
         when Constraint_Error =>
835
            raise Conversion_Error;
836
      end To_Decimal;
837
 
838
      ----------------------------------
839
      -- To_Decimal (internal binary) --
840
      ----------------------------------
841
 
842
      function To_Decimal (Item : Binary) return Num is
843
         pragma Unsuppress (Range_Check);
844
      begin
845
         return Num'Fixed_Value (Item);
846
      exception
847
         when Constraint_Error =>
848
            raise Conversion_Error;
849
      end To_Decimal;
850
 
851
      --------------------------
852
      -- To_Decimal (display) --
853
      --------------------------
854
 
855
      function To_Decimal
856
        (Item   : Numeric;
857
         Format : Display_Format) return Num
858
      is
859
         pragma Unsuppress (Range_Check);
860
 
861
      begin
862
         return Num'Fixed_Value (Numeric_To_Decimal (Item, Format));
863
      exception
864
         when Constraint_Error =>
865
            raise Conversion_Error;
866
      end To_Decimal;
867
 
868
      ---------------------------------------
869
      -- To_Decimal (internal long binary) --
870
      ---------------------------------------
871
 
872
      function To_Decimal (Item : Long_Binary) return Num is
873
         pragma Unsuppress (Range_Check);
874
      begin
875
         return Num'Fixed_Value (Item);
876
      exception
877
         when Constraint_Error =>
878
            raise Conversion_Error;
879
      end To_Decimal;
880
 
881
      -------------------------
882
      -- To_Decimal (packed) --
883
      -------------------------
884
 
885
      function To_Decimal
886
        (Item   : Packed_Decimal;
887
         Format : Packed_Format) return Num
888
      is
889
         pragma Unsuppress (Range_Check);
890
      begin
891
         return Num'Fixed_Value (Packed_To_Decimal (Item, Format));
892
      exception
893
         when Constraint_Error =>
894
            raise Conversion_Error;
895
      end To_Decimal;
896
 
897
      ----------------
898
      -- To_Display --
899
      ----------------
900
 
901
      function To_Display
902
        (Item   : Num;
903
         Format : Display_Format) return Numeric
904
      is
905
         pragma Unsuppress (Range_Check);
906
      begin
907
         return
908
           To_Display
909
             (Integer_64'Integer_Value (Item),
910
              Format,
911
              Length (Format));
912
      exception
913
         when Constraint_Error =>
914
            raise Conversion_Error;
915
      end To_Display;
916
 
917
      --------------------
918
      -- To_Long_Binary --
919
      --------------------
920
 
921
      function To_Long_Binary (Item : Num) return Long_Binary is
922
         pragma Unsuppress (Range_Check);
923
      begin
924
         return Long_Binary'Integer_Value (Item);
925
      exception
926
         when Constraint_Error =>
927
            raise Conversion_Error;
928
      end To_Long_Binary;
929
 
930
      ---------------
931
      -- To_Packed --
932
      ---------------
933
 
934
      function To_Packed
935
        (Item   : Num;
936
         Format : Packed_Format) return Packed_Decimal
937
      is
938
         pragma Unsuppress (Range_Check);
939
      begin
940
         return
941
           To_Packed
942
             (Integer_64'Integer_Value (Item),
943
              Format,
944
              Length (Format));
945
      exception
946
         when Constraint_Error =>
947
            raise Conversion_Error;
948
      end To_Packed;
949
 
950
      --------------------
951
      -- Valid (binary) --
952
      --------------------
953
 
954
      function Valid
955
        (Item   : Byte_Array;
956
         Format : Binary_Format) return Boolean
957
      is
958
         Val : Num;
959
         pragma Unreferenced (Val);
960
      begin
961
         Val := To_Decimal (Item, Format);
962
         return True;
963
      exception
964
         when Conversion_Error =>
965
            return False;
966
      end Valid;
967
 
968
      ---------------------
969
      -- Valid (display) --
970
      ---------------------
971
 
972
      function Valid
973
        (Item   : Numeric;
974
         Format : Display_Format) return Boolean
975
      is
976
      begin
977
         return Valid_Numeric (Item, Format);
978
      end Valid;
979
 
980
      --------------------
981
      -- Valid (packed) --
982
      --------------------
983
 
984
      function Valid
985
        (Item   : Packed_Decimal;
986
         Format : Packed_Format) return Boolean
987
      is
988
      begin
989
         return Valid_Packed (Item, Format);
990
      end Valid;
991
 
992
   end Decimal_Conversions;
993
 
994
end Interfaces.COBOL;

powered by: WebSVN 2.1.0

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