File : i-cobol.adb
1 ------------------------------------------------------------------------------
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 -- --
19 -- --
20 -- --
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;