|
111
|
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 -- --
|
|
131
|
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
|
|
111
|
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 end case;
|
|
|
547
|
|
|
548 return Result;
|
|
|
549 end To_Display;
|
|
|
550
|
|
|
551 ---------------
|
|
|
552 -- To_Packed --
|
|
|
553 ---------------
|
|
|
554
|
|
|
555 function To_Packed
|
|
|
556 (Item : Integer_64;
|
|
|
557 Format : Packed_Format;
|
|
|
558 Length : Natural) return Packed_Decimal
|
|
|
559 is
|
|
|
560 Result : Packed_Decimal (1 .. Length);
|
|
|
561 Val : Integer_64;
|
|
|
562
|
|
|
563 procedure Convert (First, Last : Natural);
|
|
|
564 -- Convert the number in Val into a sequence of Decimal_Element values,
|
|
|
565 -- storing the result in Result (First .. Last). Raise Conversion_Error
|
|
|
566 -- if the value is too large to fit.
|
|
|
567
|
|
|
568 -------------
|
|
|
569 -- Convert --
|
|
|
570 -------------
|
|
|
571
|
|
|
572 procedure Convert (First, Last : Natural) is
|
|
|
573 J : Natural := Last;
|
|
|
574
|
|
|
575 begin
|
|
|
576 while J >= First loop
|
|
|
577 Result (J) := Decimal_Element (Val mod 10);
|
|
|
578
|
|
|
579 Val := Val / 10;
|
|
|
580
|
|
|
581 if Val = 0 then
|
|
|
582 for K in First .. J - 1 loop
|
|
|
583 Result (K) := 0;
|
|
|
584 end loop;
|
|
|
585
|
|
|
586 return;
|
|
|
587
|
|
|
588 else
|
|
|
589 J := J - 1;
|
|
|
590 end if;
|
|
|
591 end loop;
|
|
|
592
|
|
|
593 raise Conversion_Error;
|
|
|
594 end Convert;
|
|
|
595
|
|
|
596 -- Start of processing for To_Packed
|
|
|
597
|
|
|
598 begin
|
|
|
599 case Packed_Representation is
|
|
|
600 when IBM =>
|
|
|
601 if Format = Packed_Unsigned then
|
|
|
602 if Item < 0 then
|
|
|
603 raise Conversion_Error;
|
|
|
604 else
|
|
|
605 Result (Length) := 16#F#;
|
|
|
606 Val := Item;
|
|
|
607 end if;
|
|
|
608
|
|
|
609 elsif Item >= 0 then
|
|
|
610 Result (Length) := 16#C#;
|
|
|
611 Val := Item;
|
|
|
612
|
|
|
613 else -- Item < 0
|
|
|
614 Result (Length) := 16#D#;
|
|
|
615 Val := -Item;
|
|
|
616 end if;
|
|
|
617
|
|
|
618 Convert (1, Length - 1);
|
|
|
619 return Result;
|
|
|
620 end case;
|
|
|
621 end To_Packed;
|
|
|
622
|
|
|
623 -------------------
|
|
|
624 -- Valid_Numeric --
|
|
|
625 -------------------
|
|
|
626
|
|
|
627 function Valid_Numeric
|
|
|
628 (Item : Numeric;
|
|
|
629 Format : Display_Format) return Boolean
|
|
|
630 is
|
|
|
631 begin
|
|
|
632 if Item'Length = 0 then
|
|
|
633 return False;
|
|
|
634 end if;
|
|
|
635
|
|
|
636 -- All character positions except first and last must be Digits.
|
|
|
637 -- This is true for all the formats.
|
|
|
638
|
|
|
639 for J in Item'First + 1 .. Item'Last - 1 loop
|
|
|
640 if Item (J) not in COBOL_Digits then
|
|
|
641 return False;
|
|
|
642 end if;
|
|
|
643 end loop;
|
|
|
644
|
|
|
645 case Format is
|
|
|
646 when Unsigned =>
|
|
|
647 return Item (Item'First) in COBOL_Digits
|
|
|
648 and then Item (Item'Last) in COBOL_Digits;
|
|
|
649
|
|
|
650 when Leading_Separate =>
|
|
|
651 return (Item (Item'First) = COBOL_Plus or else
|
|
|
652 Item (Item'First) = COBOL_Minus)
|
|
|
653 and then Item (Item'Last) in COBOL_Digits;
|
|
|
654
|
|
|
655 when Trailing_Separate =>
|
|
|
656 return Item (Item'First) in COBOL_Digits
|
|
|
657 and then
|
|
|
658 (Item (Item'Last) = COBOL_Plus or else
|
|
|
659 Item (Item'Last) = COBOL_Minus);
|
|
|
660
|
|
|
661 when Leading_Nonseparate =>
|
|
|
662 return (Item (Item'First) in COBOL_Plus_Digits or else
|
|
|
663 Item (Item'First) in COBOL_Minus_Digits)
|
|
|
664 and then Item (Item'Last) in COBOL_Digits;
|
|
|
665
|
|
|
666 when Trailing_Nonseparate =>
|
|
|
667 return Item (Item'First) in COBOL_Digits
|
|
|
668 and then
|
|
|
669 (Item (Item'Last) in COBOL_Plus_Digits or else
|
|
|
670 Item (Item'Last) in COBOL_Minus_Digits);
|
|
|
671
|
|
|
672 end case;
|
|
|
673 end Valid_Numeric;
|
|
|
674
|
|
|
675 ------------------
|
|
|
676 -- Valid_Packed --
|
|
|
677 ------------------
|
|
|
678
|
|
|
679 function Valid_Packed
|
|
|
680 (Item : Packed_Decimal;
|
|
|
681 Format : Packed_Format) return Boolean
|
|
|
682 is
|
|
|
683 begin
|
|
|
684 case Packed_Representation is
|
|
|
685 when IBM =>
|
|
|
686 for J in Item'First .. Item'Last - 1 loop
|
|
|
687 if Item (J) > 9 then
|
|
|
688 return False;
|
|
|
689 end if;
|
|
|
690 end loop;
|
|
|
691
|
|
|
692 -- For unsigned, sign digit must be F
|
|
|
693
|
|
|
694 if Format = Packed_Unsigned then
|
|
|
695 return Item (Item'Last) = 16#F#;
|
|
|
696
|
|
|
697 -- For signed, accept all standard and non-standard signs
|
|
|
698
|
|
|
699 else
|
|
|
700 return Item (Item'Last) in 16#A# .. 16#F#;
|
|
|
701 end if;
|
|
|
702 end case;
|
|
|
703 end Valid_Packed;
|
|
|
704
|
|
|
705 -------------------------
|
|
|
706 -- Decimal_Conversions --
|
|
|
707 -------------------------
|
|
|
708
|
|
|
709 package body Decimal_Conversions is
|
|
|
710
|
|
|
711 ---------------------
|
|
|
712 -- Length (binary) --
|
|
|
713 ---------------------
|
|
|
714
|
|
|
715 -- Note that the tests here are all compile time tests
|
|
|
716
|
|
|
717 function Length (Format : Binary_Format) return Natural is
|
|
|
718 pragma Unreferenced (Format);
|
|
|
719 begin
|
|
|
720 if Num'Digits <= 2 then
|
|
|
721 return 1;
|
|
|
722 elsif Num'Digits <= 4 then
|
|
|
723 return 2;
|
|
|
724 elsif Num'Digits <= 9 then
|
|
|
725 return 4;
|
|
|
726 else -- Num'Digits in 10 .. 18
|
|
|
727 return 8;
|
|
|
728 end if;
|
|
|
729 end Length;
|
|
|
730
|
|
|
731 ----------------------
|
|
|
732 -- Length (display) --
|
|
|
733 ----------------------
|
|
|
734
|
|
|
735 function Length (Format : Display_Format) return Natural is
|
|
|
736 begin
|
|
|
737 if Format = Leading_Separate or else Format = Trailing_Separate then
|
|
|
738 return Num'Digits + 1;
|
|
|
739 else
|
|
|
740 return Num'Digits;
|
|
|
741 end if;
|
|
|
742 end Length;
|
|
|
743
|
|
|
744 ---------------------
|
|
|
745 -- Length (packed) --
|
|
|
746 ---------------------
|
|
|
747
|
|
|
748 -- Note that the tests here are all compile time checks
|
|
|
749
|
|
|
750 function Length
|
|
|
751 (Format : Packed_Format) return Natural
|
|
|
752 is
|
|
|
753 pragma Unreferenced (Format);
|
|
|
754 begin
|
|
|
755 case Packed_Representation is
|
|
|
756 when IBM =>
|
|
|
757 return (Num'Digits + 2) / 2 * 2;
|
|
|
758 end case;
|
|
|
759 end Length;
|
|
|
760
|
|
|
761 ---------------
|
|
|
762 -- To_Binary --
|
|
|
763 ---------------
|
|
|
764
|
|
|
765 function To_Binary
|
|
|
766 (Item : Num;
|
|
|
767 Format : Binary_Format) return Byte_Array
|
|
|
768 is
|
|
|
769 begin
|
|
|
770 -- Note: all these tests are compile time tests
|
|
|
771
|
|
|
772 if Num'Digits <= 2 then
|
|
|
773 return To_B1 (Integer_8'Integer_Value (Item));
|
|
|
774
|
|
|
775 elsif Num'Digits <= 4 then
|
|
|
776 declare
|
|
|
777 R : B2 := To_B2 (Integer_16'Integer_Value (Item));
|
|
|
778
|
|
|
779 begin
|
|
|
780 Swap (R, Format);
|
|
|
781 return R;
|
|
|
782 end;
|
|
|
783
|
|
|
784 elsif Num'Digits <= 9 then
|
|
|
785 declare
|
|
|
786 R : B4 := To_B4 (Integer_32'Integer_Value (Item));
|
|
|
787
|
|
|
788 begin
|
|
|
789 Swap (R, Format);
|
|
|
790 return R;
|
|
|
791 end;
|
|
|
792
|
|
|
793 else -- Num'Digits in 10 .. 18
|
|
|
794 declare
|
|
|
795 R : B8 := To_B8 (Integer_64'Integer_Value (Item));
|
|
|
796
|
|
|
797 begin
|
|
|
798 Swap (R, Format);
|
|
|
799 return R;
|
|
|
800 end;
|
|
|
801 end if;
|
|
|
802
|
|
|
803 exception
|
|
|
804 when Constraint_Error =>
|
|
|
805 raise Conversion_Error;
|
|
|
806 end To_Binary;
|
|
|
807
|
|
|
808 ---------------------------------
|
|
|
809 -- To_Binary (internal binary) --
|
|
|
810 ---------------------------------
|
|
|
811
|
|
|
812 function To_Binary (Item : Num) return Binary is
|
|
|
813 pragma Unsuppress (Range_Check);
|
|
|
814 begin
|
|
|
815 return Binary'Integer_Value (Item);
|
|
|
816 exception
|
|
|
817 when Constraint_Error =>
|
|
|
818 raise Conversion_Error;
|
|
|
819 end To_Binary;
|
|
|
820
|
|
|
821 -------------------------
|
|
|
822 -- To_Decimal (binary) --
|
|
|
823 -------------------------
|
|
|
824
|
|
|
825 function To_Decimal
|
|
|
826 (Item : Byte_Array;
|
|
|
827 Format : Binary_Format) return Num
|
|
|
828 is
|
|
|
829 pragma Unsuppress (Range_Check);
|
|
|
830 begin
|
|
|
831 return Num'Fixed_Value (Binary_To_Decimal (Item, Format));
|
|
|
832 exception
|
|
|
833 when Constraint_Error =>
|
|
|
834 raise Conversion_Error;
|
|
|
835 end To_Decimal;
|
|
|
836
|
|
|
837 ----------------------------------
|
|
|
838 -- To_Decimal (internal binary) --
|
|
|
839 ----------------------------------
|
|
|
840
|
|
|
841 function To_Decimal (Item : Binary) return Num is
|
|
|
842 pragma Unsuppress (Range_Check);
|
|
|
843 begin
|
|
|
844 return Num'Fixed_Value (Item);
|
|
|
845 exception
|
|
|
846 when Constraint_Error =>
|
|
|
847 raise Conversion_Error;
|
|
|
848 end To_Decimal;
|
|
|
849
|
|
|
850 --------------------------
|
|
|
851 -- To_Decimal (display) --
|
|
|
852 --------------------------
|
|
|
853
|
|
|
854 function To_Decimal
|
|
|
855 (Item : Numeric;
|
|
|
856 Format : Display_Format) return Num
|
|
|
857 is
|
|
|
858 pragma Unsuppress (Range_Check);
|
|
|
859
|
|
|
860 begin
|
|
|
861 return Num'Fixed_Value (Numeric_To_Decimal (Item, Format));
|
|
|
862 exception
|
|
|
863 when Constraint_Error =>
|
|
|
864 raise Conversion_Error;
|
|
|
865 end To_Decimal;
|
|
|
866
|
|
|
867 ---------------------------------------
|
|
|
868 -- To_Decimal (internal long binary) --
|
|
|
869 ---------------------------------------
|
|
|
870
|
|
|
871 function To_Decimal (Item : Long_Binary) return Num is
|
|
|
872 pragma Unsuppress (Range_Check);
|
|
|
873 begin
|
|
|
874 return Num'Fixed_Value (Item);
|
|
|
875 exception
|
|
|
876 when Constraint_Error =>
|
|
|
877 raise Conversion_Error;
|
|
|
878 end To_Decimal;
|
|
|
879
|
|
|
880 -------------------------
|
|
|
881 -- To_Decimal (packed) --
|
|
|
882 -------------------------
|
|
|
883
|
|
|
884 function To_Decimal
|
|
|
885 (Item : Packed_Decimal;
|
|
|
886 Format : Packed_Format) return Num
|
|
|
887 is
|
|
|
888 pragma Unsuppress (Range_Check);
|
|
|
889 begin
|
|
|
890 return Num'Fixed_Value (Packed_To_Decimal (Item, Format));
|
|
|
891 exception
|
|
|
892 when Constraint_Error =>
|
|
|
893 raise Conversion_Error;
|
|
|
894 end To_Decimal;
|
|
|
895
|
|
|
896 ----------------
|
|
|
897 -- To_Display --
|
|
|
898 ----------------
|
|
|
899
|
|
|
900 function To_Display
|
|
|
901 (Item : Num;
|
|
|
902 Format : Display_Format) return Numeric
|
|
|
903 is
|
|
|
904 pragma Unsuppress (Range_Check);
|
|
|
905 begin
|
|
|
906 return
|
|
|
907 To_Display
|
|
|
908 (Integer_64'Integer_Value (Item),
|
|
|
909 Format,
|
|
|
910 Length (Format));
|
|
|
911 exception
|
|
|
912 when Constraint_Error =>
|
|
|
913 raise Conversion_Error;
|
|
|
914 end To_Display;
|
|
|
915
|
|
|
916 --------------------
|
|
|
917 -- To_Long_Binary --
|
|
|
918 --------------------
|
|
|
919
|
|
|
920 function To_Long_Binary (Item : Num) return Long_Binary is
|
|
|
921 pragma Unsuppress (Range_Check);
|
|
|
922 begin
|
|
|
923 return Long_Binary'Integer_Value (Item);
|
|
|
924 exception
|
|
|
925 when Constraint_Error =>
|
|
|
926 raise Conversion_Error;
|
|
|
927 end To_Long_Binary;
|
|
|
928
|
|
|
929 ---------------
|
|
|
930 -- To_Packed --
|
|
|
931 ---------------
|
|
|
932
|
|
|
933 function To_Packed
|
|
|
934 (Item : Num;
|
|
|
935 Format : Packed_Format) return Packed_Decimal
|
|
|
936 is
|
|
|
937 pragma Unsuppress (Range_Check);
|
|
|
938 begin
|
|
|
939 return
|
|
|
940 To_Packed
|
|
|
941 (Integer_64'Integer_Value (Item),
|
|
|
942 Format,
|
|
|
943 Length (Format));
|
|
|
944 exception
|
|
|
945 when Constraint_Error =>
|
|
|
946 raise Conversion_Error;
|
|
|
947 end To_Packed;
|
|
|
948
|
|
|
949 --------------------
|
|
|
950 -- Valid (binary) --
|
|
|
951 --------------------
|
|
|
952
|
|
|
953 function Valid
|
|
|
954 (Item : Byte_Array;
|
|
|
955 Format : Binary_Format) return Boolean
|
|
|
956 is
|
|
|
957 Val : Num;
|
|
|
958 pragma Unreferenced (Val);
|
|
|
959 begin
|
|
|
960 Val := To_Decimal (Item, Format);
|
|
|
961 return True;
|
|
|
962 exception
|
|
|
963 when Conversion_Error =>
|
|
|
964 return False;
|
|
|
965 end Valid;
|
|
|
966
|
|
|
967 ---------------------
|
|
|
968 -- Valid (display) --
|
|
|
969 ---------------------
|
|
|
970
|
|
|
971 function Valid
|
|
|
972 (Item : Numeric;
|
|
|
973 Format : Display_Format) return Boolean
|
|
|
974 is
|
|
|
975 begin
|
|
|
976 return Valid_Numeric (Item, Format);
|
|
|
977 end Valid;
|
|
|
978
|
|
|
979 --------------------
|
|
|
980 -- Valid (packed) --
|
|
|
981 --------------------
|
|
|
982
|
|
|
983 function Valid
|
|
|
984 (Item : Packed_Decimal;
|
|
|
985 Format : Packed_Format) return Boolean
|
|
|
986 is
|
|
|
987 begin
|
|
|
988 return Valid_Packed (Item, Format);
|
|
|
989 end Valid;
|
|
|
990
|
|
|
991 end Decimal_Conversions;
|
|
|
992
|
|
|
993 end Interfaces.COBOL;
|
