|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- A D A . W I D E _ T E X T _ I O . E D I T I N G --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
145
|
9 -- Copyright (C) 1992-2019, 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 with Ada.Strings.Fixed;
|
|
|
33 with Ada.Strings.Wide_Fixed;
|
|
|
34
|
|
|
35 package body Ada.Wide_Text_IO.Editing is
|
|
|
36
|
|
|
37 package Strings renames Ada.Strings;
|
|
|
38 package Strings_Fixed renames Ada.Strings.Fixed;
|
|
|
39 package Strings_Wide_Fixed renames Ada.Strings.Wide_Fixed;
|
|
|
40 package Wide_Text_IO renames Ada.Wide_Text_IO;
|
|
|
41
|
|
|
42 -----------------------
|
|
|
43 -- Local_Subprograms --
|
|
|
44 -----------------------
|
|
|
45
|
|
|
46 function To_Wide (C : Character) return Wide_Character;
|
|
|
47 pragma Inline (To_Wide);
|
|
|
48 -- Convert Character to corresponding Wide_Character
|
|
|
49
|
|
|
50 ---------------------
|
|
|
51 -- Blank_When_Zero --
|
|
|
52 ---------------------
|
|
|
53
|
|
|
54 function Blank_When_Zero (Pic : Picture) return Boolean is
|
|
|
55 begin
|
|
|
56 return Pic.Contents.Original_BWZ;
|
|
|
57 end Blank_When_Zero;
|
|
|
58
|
|
|
59 --------------------
|
|
|
60 -- Decimal_Output --
|
|
|
61 --------------------
|
|
|
62
|
|
|
63 package body Decimal_Output is
|
|
|
64
|
|
|
65 -----------
|
|
|
66 -- Image --
|
|
|
67 -----------
|
|
|
68
|
|
|
69 function Image
|
|
|
70 (Item : Num;
|
|
|
71 Pic : Picture;
|
|
|
72 Currency : Wide_String := Default_Currency;
|
|
|
73 Fill : Wide_Character := Default_Fill;
|
|
|
74 Separator : Wide_Character := Default_Separator;
|
|
|
75 Radix_Mark : Wide_Character := Default_Radix_Mark) return Wide_String
|
|
|
76 is
|
|
|
77 begin
|
|
|
78 return Format_Number
|
|
|
79 (Pic.Contents, Num'Image (Item),
|
|
|
80 Currency, Fill, Separator, Radix_Mark);
|
|
|
81 end Image;
|
|
|
82
|
|
|
83 ------------
|
|
|
84 -- Length --
|
|
|
85 ------------
|
|
|
86
|
|
|
87 function Length
|
|
|
88 (Pic : Picture;
|
|
|
89 Currency : Wide_String := Default_Currency) return Natural
|
|
|
90 is
|
|
|
91 Picstr : constant String := Pic_String (Pic);
|
|
|
92 V_Adjust : Integer := 0;
|
|
|
93 Cur_Adjust : Integer := 0;
|
|
|
94
|
|
|
95 begin
|
|
|
96 -- Check if Picstr has 'V' or '$'
|
|
|
97
|
|
|
98 -- If 'V', then length is 1 less than otherwise
|
|
|
99
|
|
|
100 -- If '$', then length is Currency'Length-1 more than otherwise
|
|
|
101
|
|
|
102 -- This should use the string handling package ???
|
|
|
103
|
|
|
104 for J in Picstr'Range loop
|
|
|
105 if Picstr (J) = 'V' then
|
|
|
106 V_Adjust := -1;
|
|
|
107
|
|
|
108 elsif Picstr (J) = '$' then
|
|
|
109 Cur_Adjust := Currency'Length - 1;
|
|
|
110 end if;
|
|
|
111 end loop;
|
|
|
112
|
|
|
113 return Picstr'Length - V_Adjust + Cur_Adjust;
|
|
|
114 end Length;
|
|
|
115
|
|
|
116 ---------
|
|
|
117 -- Put --
|
|
|
118 ---------
|
|
|
119
|
|
|
120 procedure Put
|
|
|
121 (File : Wide_Text_IO.File_Type;
|
|
|
122 Item : Num;
|
|
|
123 Pic : Picture;
|
|
|
124 Currency : Wide_String := Default_Currency;
|
|
|
125 Fill : Wide_Character := Default_Fill;
|
|
|
126 Separator : Wide_Character := Default_Separator;
|
|
|
127 Radix_Mark : Wide_Character := Default_Radix_Mark)
|
|
|
128 is
|
|
|
129 begin
|
|
|
130 Wide_Text_IO.Put (File, Image (Item, Pic,
|
|
|
131 Currency, Fill, Separator, Radix_Mark));
|
|
|
132 end Put;
|
|
|
133
|
|
|
134 procedure Put
|
|
|
135 (Item : Num;
|
|
|
136 Pic : Picture;
|
|
|
137 Currency : Wide_String := Default_Currency;
|
|
|
138 Fill : Wide_Character := Default_Fill;
|
|
|
139 Separator : Wide_Character := Default_Separator;
|
|
|
140 Radix_Mark : Wide_Character := Default_Radix_Mark)
|
|
|
141 is
|
|
|
142 begin
|
|
|
143 Wide_Text_IO.Put (Image (Item, Pic,
|
|
|
144 Currency, Fill, Separator, Radix_Mark));
|
|
|
145 end Put;
|
|
|
146
|
|
|
147 procedure Put
|
|
|
148 (To : out Wide_String;
|
|
|
149 Item : Num;
|
|
|
150 Pic : Picture;
|
|
|
151 Currency : Wide_String := Default_Currency;
|
|
|
152 Fill : Wide_Character := Default_Fill;
|
|
|
153 Separator : Wide_Character := Default_Separator;
|
|
|
154 Radix_Mark : Wide_Character := Default_Radix_Mark)
|
|
|
155 is
|
|
|
156 Result : constant Wide_String :=
|
|
|
157 Image (Item, Pic, Currency, Fill, Separator, Radix_Mark);
|
|
|
158
|
|
|
159 begin
|
|
|
160 if Result'Length > To'Length then
|
|
|
161 raise Wide_Text_IO.Layout_Error;
|
|
|
162 else
|
|
|
163 Strings_Wide_Fixed.Move (Source => Result, Target => To,
|
|
|
164 Justify => Strings.Right);
|
|
|
165 end if;
|
|
|
166 end Put;
|
|
|
167
|
|
|
168 -----------
|
|
|
169 -- Valid --
|
|
|
170 -----------
|
|
|
171
|
|
|
172 function Valid
|
|
|
173 (Item : Num;
|
|
|
174 Pic : Picture;
|
|
|
175 Currency : Wide_String := Default_Currency) return Boolean
|
|
|
176 is
|
|
|
177 begin
|
|
|
178 declare
|
|
|
179 Temp : constant Wide_String := Image (Item, Pic, Currency);
|
|
|
180 pragma Warnings (Off, Temp);
|
|
|
181 begin
|
|
|
182 return True;
|
|
|
183 end;
|
|
|
184
|
|
|
185 exception
|
|
|
186 when Layout_Error => return False;
|
|
|
187
|
|
|
188 end Valid;
|
|
|
189 end Decimal_Output;
|
|
|
190
|
|
|
191 ------------
|
|
|
192 -- Expand --
|
|
|
193 ------------
|
|
|
194
|
|
|
195 function Expand (Picture : String) return String is
|
|
|
196 Result : String (1 .. MAX_PICSIZE);
|
|
|
197 Picture_Index : Integer := Picture'First;
|
|
|
198 Result_Index : Integer := Result'First;
|
|
|
199 Count : Natural;
|
|
|
200 Last : Integer;
|
|
|
201
|
|
|
202 begin
|
|
|
203 if Picture'Length < 1 then
|
|
|
204 raise Picture_Error;
|
|
|
205 end if;
|
|
|
206
|
|
|
207 if Picture (Picture'First) = '(' then
|
|
|
208 raise Picture_Error;
|
|
|
209 end if;
|
|
|
210
|
|
|
211 loop
|
|
|
212 case Picture (Picture_Index) is
|
|
|
213 when '(' =>
|
|
|
214
|
|
|
215 -- We now need to scan out the count after a left paren. In
|
|
|
216 -- the non-wide version we used Integer_IO.Get, but that is
|
|
|
217 -- not convenient here, since we don't want to drag in normal
|
|
|
218 -- Text_IO just for this purpose. So we do the scan ourselves,
|
|
|
219 -- with the normal validity checks.
|
|
|
220
|
|
|
221 Last := Picture_Index + 1;
|
|
|
222 Count := 0;
|
|
|
223
|
|
|
224 if Picture (Last) not in '0' .. '9' then
|
|
|
225 raise Picture_Error;
|
|
|
226 end if;
|
|
|
227
|
|
|
228 Count := Character'Pos (Picture (Last)) - Character'Pos ('0');
|
|
|
229 Last := Last + 1;
|
|
|
230
|
|
|
231 loop
|
|
|
232 if Last > Picture'Last then
|
|
|
233 raise Picture_Error;
|
|
|
234 end if;
|
|
|
235
|
|
|
236 if Picture (Last) = '_' then
|
|
|
237 if Picture (Last - 1) = '_' then
|
|
|
238 raise Picture_Error;
|
|
|
239 end if;
|
|
|
240
|
|
|
241 elsif Picture (Last) = ')' then
|
|
|
242 exit;
|
|
|
243
|
|
|
244 elsif Picture (Last) not in '0' .. '9' then
|
|
|
245 raise Picture_Error;
|
|
|
246
|
|
|
247 else
|
|
|
248 Count := Count * 10
|
|
|
249 + Character'Pos (Picture (Last)) -
|
|
|
250 Character'Pos ('0');
|
|
|
251 end if;
|
|
|
252
|
|
|
253 Last := Last + 1;
|
|
|
254 end loop;
|
|
|
255
|
|
|
256 -- In what follows note that one copy of the repeated
|
|
|
257 -- character has already been made, so a count of one is
|
|
|
258 -- no-op, and a count of zero erases a character.
|
|
|
259
|
|
|
260 for J in 2 .. Count loop
|
|
|
261 Result (Result_Index + J - 2) := Picture (Picture_Index - 1);
|
|
|
262 end loop;
|
|
|
263
|
|
|
264 Result_Index := Result_Index + Count - 1;
|
|
|
265
|
|
|
266 -- Last was a ')' throw it away too
|
|
|
267
|
|
|
268 Picture_Index := Last + 1;
|
|
|
269
|
|
|
270 when ')' =>
|
|
|
271 raise Picture_Error;
|
|
|
272
|
|
|
273 when others =>
|
|
|
274 Result (Result_Index) := Picture (Picture_Index);
|
|
|
275 Picture_Index := Picture_Index + 1;
|
|
|
276 Result_Index := Result_Index + 1;
|
|
|
277 end case;
|
|
|
278
|
|
|
279 exit when Picture_Index > Picture'Last;
|
|
|
280 end loop;
|
|
|
281
|
|
|
282 return Result (1 .. Result_Index - 1);
|
|
|
283
|
|
|
284 exception
|
|
|
285 when others =>
|
|
|
286 raise Picture_Error;
|
|
|
287 end Expand;
|
|
|
288
|
|
|
289 -------------------
|
|
|
290 -- Format_Number --
|
|
|
291 -------------------
|
|
|
292
|
|
|
293 function Format_Number
|
|
|
294 (Pic : Format_Record;
|
|
|
295 Number : String;
|
|
|
296 Currency_Symbol : Wide_String;
|
|
|
297 Fill_Character : Wide_Character;
|
|
|
298 Separator_Character : Wide_Character;
|
|
|
299 Radix_Point : Wide_Character) return Wide_String
|
|
|
300 is
|
|
|
301 Attrs : Number_Attributes := Parse_Number_String (Number);
|
|
|
302 Position : Integer;
|
|
|
303 Rounded : String := Number;
|
|
|
304
|
|
|
305 Sign_Position : Integer := Pic.Sign_Position; -- may float.
|
|
|
306
|
|
|
307 Answer : Wide_String (1 .. Pic.Picture.Length);
|
|
|
308 Last : Integer;
|
|
|
309 Currency_Pos : Integer := Pic.Start_Currency;
|
|
|
310
|
|
|
311 Dollar : Boolean := False;
|
|
|
312 -- Overridden immediately if necessary
|
|
|
313
|
|
|
314 Zero : Boolean := True;
|
|
|
315 -- Set to False when a non-zero digit is output
|
|
|
316
|
|
|
317 begin
|
|
|
318
|
|
|
319 -- If the picture has fewer decimal places than the number, the image
|
|
|
320 -- must be rounded according to the usual rules.
|
|
|
321
|
|
|
322 if Attrs.Has_Fraction then
|
|
|
323 declare
|
|
|
324 R : constant Integer :=
|
|
|
325 (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1)
|
|
|
326 - Pic.Max_Trailing_Digits;
|
|
|
327 R_Pos : Integer;
|
|
|
328
|
|
|
329 begin
|
|
|
330 if R > 0 then
|
|
|
331 R_Pos := Rounded'Length - R;
|
|
|
332
|
|
|
333 if Rounded (R_Pos + 1) > '4' then
|
|
|
334
|
|
|
335 if Rounded (R_Pos) = '.' then
|
|
|
336 R_Pos := R_Pos - 1;
|
|
|
337 end if;
|
|
|
338
|
|
|
339 if Rounded (R_Pos) /= '9' then
|
|
|
340 Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
|
|
|
341 else
|
|
|
342 Rounded (R_Pos) := '0';
|
|
|
343 R_Pos := R_Pos - 1;
|
|
|
344
|
|
|
345 while R_Pos > 1 loop
|
|
|
346 if Rounded (R_Pos) = '.' then
|
|
|
347 R_Pos := R_Pos - 1;
|
|
|
348 end if;
|
|
|
349
|
|
|
350 if Rounded (R_Pos) /= '9' then
|
|
|
351 Rounded (R_Pos) := Character'Succ (Rounded (R_Pos));
|
|
|
352 exit;
|
|
|
353 else
|
|
|
354 Rounded (R_Pos) := '0';
|
|
|
355 R_Pos := R_Pos - 1;
|
|
|
356 end if;
|
|
|
357 end loop;
|
|
|
358
|
|
|
359 -- The rounding may add a digit in front. Either the
|
|
|
360 -- leading blank or the sign (already captured) can be
|
|
|
361 -- overwritten.
|
|
|
362
|
|
|
363 if R_Pos = 1 then
|
|
|
364 Rounded (R_Pos) := '1';
|
|
|
365 Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1;
|
|
|
366 end if;
|
|
|
367 end if;
|
|
|
368 end if;
|
|
|
369 end if;
|
|
|
370 end;
|
|
|
371 end if;
|
|
|
372
|
|
|
373 for J in Answer'Range loop
|
|
|
374 Answer (J) := To_Wide (Pic.Picture.Expanded (J));
|
|
|
375 end loop;
|
|
|
376
|
|
|
377 if Pic.Start_Currency /= Invalid_Position then
|
|
|
378 Dollar := Answer (Pic.Start_Currency) = '$';
|
|
|
379 end if;
|
|
|
380
|
|
|
381 -- Fix up "direct inserts" outside the playing field. Set up as one
|
|
|
382 -- loop to do the beginning, one (reverse) loop to do the end.
|
|
|
383
|
|
|
384 Last := 1;
|
|
|
385 loop
|
|
|
386 exit when Last = Pic.Start_Float;
|
|
|
387 exit when Last = Pic.Radix_Position;
|
|
|
388 exit when Answer (Last) = '9';
|
|
|
389
|
|
|
390 case Answer (Last) is
|
|
|
391 when '_' =>
|
|
|
392 Answer (Last) := Separator_Character;
|
|
|
393
|
|
|
394 when 'b' =>
|
|
|
395 Answer (Last) := ' ';
|
|
|
396
|
|
|
397 when others =>
|
|
|
398 null;
|
|
|
399 end case;
|
|
|
400
|
|
|
401 exit when Last = Answer'Last;
|
|
|
402
|
|
|
403 Last := Last + 1;
|
|
|
404 end loop;
|
|
|
405
|
|
|
406 -- Now for the end...
|
|
|
407
|
|
|
408 for J in reverse Last .. Answer'Last loop
|
|
|
409 exit when J = Pic.Radix_Position;
|
|
|
410
|
|
|
411 -- Do this test First, Separator_Character can equal Pic.Floater
|
|
|
412
|
|
|
413 if Answer (J) = Pic.Floater then
|
|
|
414 exit;
|
|
|
415 end if;
|
|
|
416
|
|
|
417 case Answer (J) is
|
|
|
418 when '_' =>
|
|
|
419 Answer (J) := Separator_Character;
|
|
|
420
|
|
|
421 when 'b' =>
|
|
|
422 Answer (J) := ' ';
|
|
|
423
|
|
|
424 when '9' =>
|
|
|
425 exit;
|
|
|
426
|
|
|
427 when others =>
|
|
|
428 null;
|
|
|
429 end case;
|
|
|
430 end loop;
|
|
|
431
|
|
|
432 -- Non-floating sign
|
|
|
433
|
|
|
434 if Pic.Start_Currency /= -1
|
|
|
435 and then Answer (Pic.Start_Currency) = '#'
|
|
|
436 and then Pic.Floater /= '#'
|
|
|
437 then
|
|
|
438 if Currency_Symbol'Length >
|
|
|
439 Pic.End_Currency - Pic.Start_Currency + 1
|
|
|
440 then
|
|
|
441 raise Picture_Error;
|
|
|
442
|
|
|
443 elsif Currency_Symbol'Length =
|
|
|
444 Pic.End_Currency - Pic.Start_Currency + 1
|
|
|
445 then
|
|
|
446 Answer (Pic.Start_Currency .. Pic.End_Currency) :=
|
|
|
447 Currency_Symbol;
|
|
|
448
|
|
|
449 elsif Pic.Radix_Position = Invalid_Position
|
|
|
450 or else Pic.Start_Currency < Pic.Radix_Position
|
|
|
451 then
|
|
|
452 Answer (Pic.Start_Currency .. Pic.End_Currency) :=
|
|
|
453 (others => ' ');
|
|
|
454 Answer (Pic.End_Currency - Currency_Symbol'Length + 1 ..
|
|
|
455 Pic.End_Currency) := Currency_Symbol;
|
|
|
456
|
|
|
457 else
|
|
|
458 Answer (Pic.Start_Currency .. Pic.End_Currency) :=
|
|
|
459 (others => ' ');
|
|
|
460 Answer (Pic.Start_Currency ..
|
|
|
461 Pic.Start_Currency + Currency_Symbol'Length - 1) :=
|
|
|
462 Currency_Symbol;
|
|
|
463 end if;
|
|
|
464 end if;
|
|
|
465
|
|
|
466 -- Fill in leading digits
|
|
|
467
|
|
|
468 if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 >
|
|
|
469 Pic.Max_Leading_Digits
|
|
|
470 then
|
|
|
471 raise Layout_Error;
|
|
|
472 end if;
|
|
|
473
|
|
|
474 Position :=
|
|
|
475 (if Pic.Radix_Position = Invalid_Position then Answer'Last
|
|
|
476 else Pic.Radix_Position - 1);
|
|
|
477
|
|
|
478 for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop
|
|
|
479 while Answer (Position) /= '9'
|
|
|
480 and then
|
|
|
481 Answer (Position) /= Pic.Floater
|
|
|
482 loop
|
|
|
483 if Answer (Position) = '_' then
|
|
|
484 Answer (Position) := Separator_Character;
|
|
|
485 elsif Answer (Position) = 'b' then
|
|
|
486 Answer (Position) := ' ';
|
|
|
487 end if;
|
|
|
488
|
|
|
489 Position := Position - 1;
|
|
|
490 end loop;
|
|
|
491
|
|
|
492 Answer (Position) := To_Wide (Rounded (J));
|
|
|
493
|
|
|
494 if Rounded (J) /= '0' then
|
|
|
495 Zero := False;
|
|
|
496 end if;
|
|
|
497
|
|
|
498 Position := Position - 1;
|
|
|
499 end loop;
|
|
|
500
|
|
|
501 -- Do lead float
|
|
|
502
|
|
|
503 if Pic.Start_Float = Invalid_Position then
|
|
|
504
|
|
|
505 -- No leading floats, but need to change '9' to '0', '_' to
|
|
|
506 -- Separator_Character and 'b' to ' '.
|
|
|
507
|
|
|
508 for J in Last .. Position loop
|
|
|
509
|
|
|
510 -- Last set when fixing the "uninteresting" leaders above.
|
|
|
511 -- Don't duplicate the work.
|
|
|
512
|
|
|
513 if Answer (J) = '9' then
|
|
|
514 Answer (J) := '0';
|
|
|
515
|
|
|
516 elsif Answer (J) = '_' then
|
|
|
517 Answer (J) := Separator_Character;
|
|
|
518
|
|
|
519 elsif Answer (J) = 'b' then
|
|
|
520 Answer (J) := ' ';
|
|
|
521
|
|
|
522 end if;
|
|
|
523
|
|
|
524 end loop;
|
|
|
525
|
|
|
526 elsif Pic.Floater = '<'
|
|
|
527 or else
|
|
|
528 Pic.Floater = '+'
|
|
|
529 or else
|
|
|
530 Pic.Floater = '-'
|
|
|
531 then
|
|
|
532 for J in Pic.End_Float .. Position loop -- May be null range
|
|
|
533 if Answer (J) = '9' then
|
|
|
534 Answer (J) := '0';
|
|
|
535
|
|
|
536 elsif Answer (J) = '_' then
|
|
|
537 Answer (J) := Separator_Character;
|
|
|
538
|
|
|
539 elsif Answer (J) = 'b' then
|
|
|
540 Answer (J) := ' ';
|
|
|
541
|
|
|
542 end if;
|
|
|
543 end loop;
|
|
|
544
|
|
|
545 if Position > Pic.End_Float then
|
|
|
546 Position := Pic.End_Float;
|
|
|
547 end if;
|
|
|
548
|
|
|
549 for J in Pic.Start_Float .. Position - 1 loop
|
|
|
550 Answer (J) := ' ';
|
|
|
551 end loop;
|
|
|
552
|
|
|
553 Answer (Position) := Pic.Floater;
|
|
|
554 Sign_Position := Position;
|
|
|
555
|
|
|
556 elsif Pic.Floater = '$' then
|
|
|
557
|
|
|
558 for J in Pic.End_Float .. Position loop -- May be null range
|
|
|
559 if Answer (J) = '9' then
|
|
|
560 Answer (J) := '0';
|
|
|
561
|
|
|
562 elsif Answer (J) = '_' then
|
|
|
563 Answer (J) := ' '; -- no separator before leftmost digit
|
|
|
564
|
|
|
565 elsif Answer (J) = 'b' then
|
|
|
566 Answer (J) := ' ';
|
|
|
567 end if;
|
|
|
568 end loop;
|
|
|
569
|
|
|
570 if Position > Pic.End_Float then
|
|
|
571 Position := Pic.End_Float;
|
|
|
572 end if;
|
|
|
573
|
|
|
574 for J in Pic.Start_Float .. Position - 1 loop
|
|
|
575 Answer (J) := ' ';
|
|
|
576 end loop;
|
|
|
577
|
|
|
578 Answer (Position) := Pic.Floater;
|
|
|
579 Currency_Pos := Position;
|
|
|
580
|
|
|
581 elsif Pic.Floater = '*' then
|
|
|
582
|
|
|
583 for J in Pic.End_Float .. Position loop -- May be null range
|
|
|
584 if Answer (J) = '9' then
|
|
|
585 Answer (J) := '0';
|
|
|
586
|
|
|
587 elsif Answer (J) = '_' then
|
|
|
588 Answer (J) := Separator_Character;
|
|
|
589
|
|
|
590 elsif Answer (J) = 'b' then
|
|
|
591 Answer (J) := '*';
|
|
|
592 end if;
|
|
|
593 end loop;
|
|
|
594
|
|
|
595 if Position > Pic.End_Float then
|
|
|
596 Position := Pic.End_Float;
|
|
|
597 end if;
|
|
|
598
|
|
|
599 for J in Pic.Start_Float .. Position loop
|
|
|
600 Answer (J) := '*';
|
|
|
601 end loop;
|
|
|
602
|
|
|
603 else
|
|
|
604 if Pic.Floater = '#' then
|
|
|
605 Currency_Pos := Currency_Symbol'Length;
|
|
|
606 end if;
|
|
|
607
|
|
|
608 for J in reverse Pic.Start_Float .. Position loop
|
|
|
609 case Answer (J) is
|
|
|
610 when '*' =>
|
|
|
611 Answer (J) := Fill_Character;
|
|
|
612
|
|
|
613 when 'Z' | 'b' | '/' | '0' =>
|
|
|
614 Answer (J) := ' ';
|
|
|
615
|
|
|
616 when '9' =>
|
|
|
617 Answer (J) := '0';
|
|
|
618
|
|
|
619 when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' =>
|
|
|
620 null;
|
|
|
621
|
|
|
622 when '#' =>
|
|
|
623 if Currency_Pos = 0 then
|
|
|
624 Answer (J) := ' ';
|
|
|
625 else
|
|
|
626 Answer (J) := Currency_Symbol (Currency_Pos);
|
|
|
627 Currency_Pos := Currency_Pos - 1;
|
|
|
628 end if;
|
|
|
629
|
|
|
630 when '_' =>
|
|
|
631 case Pic.Floater is
|
|
|
632 when '*' =>
|
|
|
633 Answer (J) := Fill_Character;
|
|
|
634
|
|
|
635 when 'Z' | 'b' =>
|
|
|
636 Answer (J) := ' ';
|
|
|
637
|
|
|
638 when '#' =>
|
|
|
639 if Currency_Pos = 0 then
|
|
|
640 Answer (J) := ' ';
|
|
|
641
|
|
|
642 else
|
|
|
643 Answer (J) := Currency_Symbol (Currency_Pos);
|
|
|
644 Currency_Pos := Currency_Pos - 1;
|
|
|
645 end if;
|
|
|
646
|
|
|
647 when others =>
|
|
|
648 null;
|
|
|
649 end case;
|
|
|
650
|
|
|
651 when others =>
|
|
|
652 null;
|
|
|
653 end case;
|
|
|
654 end loop;
|
|
|
655
|
|
|
656 if Pic.Floater = '#' and then Currency_Pos /= 0 then
|
|
|
657 raise Layout_Error;
|
|
|
658 end if;
|
|
|
659 end if;
|
|
|
660
|
|
|
661 -- Do sign
|
|
|
662
|
|
|
663 if Sign_Position = Invalid_Position then
|
|
|
664 if Attrs.Negative then
|
|
|
665 raise Layout_Error;
|
|
|
666 end if;
|
|
|
667
|
|
|
668 else
|
|
|
669 if Attrs.Negative then
|
|
|
670 case Answer (Sign_Position) is
|
|
|
671 when 'C' | 'D' | '-' =>
|
|
|
672 null;
|
|
|
673
|
|
|
674 when '+' =>
|
|
|
675 Answer (Sign_Position) := '-';
|
|
|
676
|
|
|
677 when '<' =>
|
|
|
678 Answer (Sign_Position) := '(';
|
|
|
679 Answer (Pic.Second_Sign) := ')';
|
|
|
680
|
|
|
681 when others =>
|
|
|
682 raise Picture_Error;
|
|
|
683 end case;
|
|
|
684
|
|
|
685 else -- positive
|
|
|
686
|
|
|
687 case Answer (Sign_Position) is
|
|
|
688 when '-' =>
|
|
|
689 Answer (Sign_Position) := ' ';
|
|
|
690
|
|
|
691 when '<' | 'C' | 'D' =>
|
|
|
692 Answer (Sign_Position) := ' ';
|
|
|
693 Answer (Pic.Second_Sign) := ' ';
|
|
|
694
|
|
|
695 when '+' =>
|
|
|
696 null;
|
|
|
697
|
|
|
698 when others =>
|
|
|
699 raise Picture_Error;
|
|
|
700 end case;
|
|
|
701 end if;
|
|
|
702 end if;
|
|
|
703
|
|
|
704 -- Fill in trailing digits
|
|
|
705
|
|
|
706 if Pic.Max_Trailing_Digits > 0 then
|
|
|
707
|
|
|
708 if Attrs.Has_Fraction then
|
|
|
709 Position := Attrs.Start_Of_Fraction;
|
|
|
710 Last := Pic.Radix_Position + 1;
|
|
|
711
|
|
|
712 for J in Last .. Answer'Last loop
|
|
|
713 if Answer (J) = '9' or else Answer (J) = Pic.Floater then
|
|
|
714 Answer (J) := To_Wide (Rounded (Position));
|
|
|
715
|
|
|
716 if Rounded (Position) /= '0' then
|
|
|
717 Zero := False;
|
|
|
718 end if;
|
|
|
719
|
|
|
720 Position := Position + 1;
|
|
|
721 Last := J + 1;
|
|
|
722
|
|
|
723 -- Used up fraction but remember place in Answer
|
|
|
724
|
|
|
725 exit when Position > Attrs.End_Of_Fraction;
|
|
|
726
|
|
|
727 elsif Answer (J) = 'b' then
|
|
|
728 Answer (J) := ' ';
|
|
|
729
|
|
|
730 elsif Answer (J) = '_' then
|
|
|
731 Answer (J) := Separator_Character;
|
|
|
732
|
|
|
733 end if;
|
|
|
734
|
|
|
735 Last := J + 1;
|
|
|
736 end loop;
|
|
|
737
|
|
|
738 Position := Last;
|
|
|
739
|
|
|
740 else
|
|
|
741 Position := Pic.Radix_Position + 1;
|
|
|
742 end if;
|
|
|
743
|
|
|
744 -- Now fill remaining 9's with zeros and _ with separators
|
|
|
745
|
|
|
746 Last := Answer'Last;
|
|
|
747
|
|
|
748 for J in Position .. Last loop
|
|
|
749 if Answer (J) = '9' then
|
|
|
750 Answer (J) := '0';
|
|
|
751
|
|
|
752 elsif Answer (J) = Pic.Floater then
|
|
|
753 Answer (J) := '0';
|
|
|
754
|
|
|
755 elsif Answer (J) = '_' then
|
|
|
756 Answer (J) := Separator_Character;
|
|
|
757
|
|
|
758 elsif Answer (J) = 'b' then
|
|
|
759 Answer (J) := ' ';
|
|
|
760
|
|
|
761 end if;
|
|
|
762 end loop;
|
|
|
763
|
|
|
764 Position := Last + 1;
|
|
|
765
|
|
|
766 else
|
|
|
767 if Pic.Floater = '#' and then Currency_Pos /= 0 then
|
|
|
768 raise Layout_Error;
|
|
|
769 end if;
|
|
|
770
|
|
|
771 -- No trailing digits, but now J may need to stick in a currency
|
|
|
772 -- symbol or sign.
|
|
|
773
|
|
|
774 Position :=
|
|
|
775 (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1
|
|
|
776 else Pic.Start_Currency);
|
|
|
777 end if;
|
|
|
778
|
|
|
779 for J in Position .. Answer'Last loop
|
|
|
780 if Pic.Start_Currency /= Invalid_Position
|
|
|
781 and then Answer (Pic.Start_Currency) = '#'
|
|
|
782 then
|
|
|
783 Currency_Pos := 1;
|
|
|
784 end if;
|
|
|
785
|
|
|
786 -- Note: There are some weird cases J can imagine with 'b' or '#' in
|
|
|
787 -- currency strings where the following code will cause glitches. The
|
|
|
788 -- trick is to tell when the character in the answer should be
|
|
|
789 -- checked, and when to look at the original string. Some other time.
|
|
|
790 -- RIE 11/26/96 ???
|
|
|
791
|
|
|
792 case Answer (J) is
|
|
|
793 when '*' =>
|
|
|
794 Answer (J) := Fill_Character;
|
|
|
795
|
|
|
796 when 'b' =>
|
|
|
797 Answer (J) := ' ';
|
|
|
798
|
|
|
799 when '#' =>
|
|
|
800 if Currency_Pos > Currency_Symbol'Length then
|
|
|
801 Answer (J) := ' ';
|
|
|
802
|
|
|
803 else
|
|
|
804 Answer (J) := Currency_Symbol (Currency_Pos);
|
|
|
805 Currency_Pos := Currency_Pos + 1;
|
|
|
806 end if;
|
|
|
807
|
|
|
808 when '_' =>
|
|
|
809 case Pic.Floater is
|
|
|
810
|
|
|
811 when '*' =>
|
|
|
812 Answer (J) := Fill_Character;
|
|
|
813
|
|
|
814 when 'Z' | 'z' =>
|
|
|
815 Answer (J) := ' ';
|
|
|
816
|
|
|
817 when '#' =>
|
|
|
818 if Currency_Pos > Currency_Symbol'Length then
|
|
|
819 Answer (J) := ' ';
|
|
|
820 else
|
|
|
821 Answer (J) := Currency_Symbol (Currency_Pos);
|
|
|
822 Currency_Pos := Currency_Pos + 1;
|
|
|
823 end if;
|
|
|
824
|
|
|
825 when others =>
|
|
|
826 null;
|
|
|
827 end case;
|
|
|
828
|
|
|
829 when others =>
|
|
|
830 exit;
|
|
|
831 end case;
|
|
|
832 end loop;
|
|
|
833
|
|
|
834 -- Now get rid of Blank_when_Zero and complete Star fill
|
|
|
835
|
|
|
836 if Zero and then Pic.Blank_When_Zero then
|
|
|
837
|
|
|
838 -- Value is zero, and blank it
|
|
|
839
|
|
|
840 Last := Answer'Last;
|
|
|
841
|
|
|
842 if Dollar then
|
|
|
843 Last := Last - 1 + Currency_Symbol'Length;
|
|
|
844 end if;
|
|
|
845
|
|
|
846 if Pic.Radix_Position /= Invalid_Position
|
|
|
847 and then Answer (Pic.Radix_Position) = 'V'
|
|
|
848 then
|
|
|
849 Last := Last - 1;
|
|
|
850 end if;
|
|
|
851
|
|
|
852 return Wide_String'(1 .. Last => ' ');
|
|
|
853
|
|
|
854 elsif Zero and then Pic.Star_Fill then
|
|
|
855 Last := Answer'Last;
|
|
|
856
|
|
|
857 if Dollar then
|
|
|
858 Last := Last - 1 + Currency_Symbol'Length;
|
|
|
859 end if;
|
|
|
860
|
|
|
861 if Pic.Radix_Position /= Invalid_Position then
|
|
|
862
|
|
|
863 if Answer (Pic.Radix_Position) = 'V' then
|
|
|
864 Last := Last - 1;
|
|
|
865
|
|
|
866 elsif Dollar then
|
|
|
867 if Pic.Radix_Position > Pic.Start_Currency then
|
|
|
868 return Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
|
|
|
869 Radix_Point &
|
|
|
870 Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
|
|
|
871
|
|
|
872 else
|
|
|
873 return
|
|
|
874 Wide_String'
|
|
|
875 (1 ..
|
|
|
876 Pic.Radix_Position + Currency_Symbol'Length - 2
|
|
|
877 => '*') &
|
|
|
878 Radix_Point &
|
|
|
879 Wide_String'
|
|
|
880 (Pic.Radix_Position + Currency_Symbol'Length .. Last
|
|
|
881 => '*');
|
|
|
882 end if;
|
|
|
883
|
|
|
884 else
|
|
|
885 return
|
|
|
886 Wide_String'(1 .. Pic.Radix_Position - 1 => '*') &
|
|
|
887 Radix_Point &
|
|
|
888 Wide_String'(Pic.Radix_Position + 1 .. Last => '*');
|
|
|
889 end if;
|
|
|
890 end if;
|
|
|
891
|
|
|
892 return Wide_String'(1 .. Last => '*');
|
|
|
893 end if;
|
|
|
894
|
|
|
895 -- This was once a simple return statement, now there are nine
|
|
|
896 -- different return cases. Not to mention the five above to deal
|
|
|
897 -- with zeros. Why not split things out?
|
|
|
898
|
|
|
899 -- Processing the radix and sign expansion separately would require
|
|
|
900 -- lots of copying--the string and some of its indexes--without
|
|
|
901 -- really simplifying the logic. The cases are:
|
|
|
902
|
|
|
903 -- 1) Expand $, replace '.' with Radix_Point
|
|
|
904 -- 2) No currency expansion, replace '.' with Radix_Point
|
|
|
905 -- 3) Expand $, radix blanked
|
|
|
906 -- 4) No currency expansion, radix blanked
|
|
|
907 -- 5) Elide V
|
|
|
908 -- 6) Expand $, Elide V
|
|
|
909 -- 7) Elide V, Expand $ (Two cases depending on order.)
|
|
|
910 -- 8) No radix, expand $
|
|
|
911 -- 9) No radix, no currency expansion
|
|
|
912
|
|
|
913 if Pic.Radix_Position /= Invalid_Position then
|
|
|
914
|
|
|
915 if Answer (Pic.Radix_Position) = '.' then
|
|
|
916 Answer (Pic.Radix_Position) := Radix_Point;
|
|
|
917
|
|
|
918 if Dollar then
|
|
|
919
|
|
|
920 -- 1) Expand $, replace '.' with Radix_Point
|
|
|
921
|
|
|
922 return
|
|
|
923 Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
|
|
|
924 Answer (Currency_Pos + 1 .. Answer'Last);
|
|
|
925
|
|
|
926 else
|
|
|
927 -- 2) No currency expansion, replace '.' with Radix_Point
|
|
|
928
|
|
|
929 return Answer;
|
|
|
930 end if;
|
|
|
931
|
|
|
932 elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix.
|
|
|
933 if Dollar then
|
|
|
934
|
|
|
935 -- 3) Expand $, radix blanked
|
|
|
936
|
|
|
937 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
|
|
|
938 Answer (Currency_Pos + 1 .. Answer'Last);
|
|
|
939
|
|
|
940 else
|
|
|
941 -- 4) No expansion, radix blanked
|
|
|
942
|
|
|
943 return Answer;
|
|
|
944 end if;
|
|
|
945
|
|
|
946 -- V cases
|
|
|
947
|
|
|
948 else
|
|
|
949 if not Dollar then
|
|
|
950
|
|
|
951 -- 5) Elide V
|
|
|
952
|
|
|
953 return Answer (1 .. Pic.Radix_Position - 1) &
|
|
|
954 Answer (Pic.Radix_Position + 1 .. Answer'Last);
|
|
|
955
|
|
|
956 elsif Currency_Pos < Pic.Radix_Position then
|
|
|
957
|
|
|
958 -- 6) Expand $, Elide V
|
|
|
959
|
|
|
960 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
|
|
|
961 Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) &
|
|
|
962 Answer (Pic.Radix_Position + 1 .. Answer'Last);
|
|
|
963
|
|
|
964 else
|
|
|
965 -- 7) Elide V, Expand $
|
|
|
966
|
|
|
967 return Answer (1 .. Pic.Radix_Position - 1) &
|
|
|
968 Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) &
|
|
|
969 Currency_Symbol &
|
|
|
970 Answer (Currency_Pos + 1 .. Answer'Last);
|
|
|
971 end if;
|
|
|
972 end if;
|
|
|
973
|
|
|
974 elsif Dollar then
|
|
|
975
|
|
|
976 -- 8) No radix, expand $
|
|
|
977
|
|
|
978 return Answer (1 .. Currency_Pos - 1) & Currency_Symbol &
|
|
|
979 Answer (Currency_Pos + 1 .. Answer'Last);
|
|
|
980
|
|
|
981 else
|
|
|
982 -- 9) No radix, no currency expansion
|
|
|
983
|
|
|
984 return Answer;
|
|
|
985 end if;
|
|
|
986 end Format_Number;
|
|
|
987
|
|
|
988 -------------------------
|
|
|
989 -- Parse_Number_String --
|
|
|
990 -------------------------
|
|
|
991
|
|
|
992 function Parse_Number_String (Str : String) return Number_Attributes is
|
|
|
993 Answer : Number_Attributes;
|
|
|
994
|
|
|
995 begin
|
|
|
996 for J in Str'Range loop
|
|
|
997 case Str (J) is
|
|
|
998 when ' ' =>
|
|
|
999 null; -- ignore
|
|
|
1000
|
|
|
1001 when '1' .. '9' =>
|
|
|
1002
|
|
|
1003 -- Decide if this is the start of a number.
|
|
|
1004 -- If so, figure out which one...
|
|
|
1005
|
|
|
1006 if Answer.Has_Fraction then
|
|
|
1007 Answer.End_Of_Fraction := J;
|
|
|
1008 else
|
|
|
1009 if Answer.Start_Of_Int = Invalid_Position then
|
|
|
1010 -- start integer
|
|
|
1011 Answer.Start_Of_Int := J;
|
|
|
1012 end if;
|
|
|
1013 Answer.End_Of_Int := J;
|
|
|
1014 end if;
|
|
|
1015
|
|
|
1016 when '0' =>
|
|
|
1017
|
|
|
1018 -- Only count a zero before the decimal point if it follows a
|
|
|
1019 -- non-zero digit. After the decimal point, zeros will be
|
|
|
1020 -- counted if followed by a non-zero digit.
|
|
|
1021
|
|
|
1022 if not Answer.Has_Fraction then
|
|
|
1023 if Answer.Start_Of_Int /= Invalid_Position then
|
|
|
1024 Answer.End_Of_Int := J;
|
|
|
1025 end if;
|
|
|
1026 end if;
|
|
|
1027
|
|
|
1028 when '-' =>
|
|
|
1029
|
|
|
1030 -- Set negative
|
|
|
1031
|
|
|
1032 Answer.Negative := True;
|
|
|
1033
|
|
|
1034 when '.' =>
|
|
|
1035
|
|
|
1036 -- Close integer, start fraction
|
|
|
1037
|
|
|
1038 if Answer.Has_Fraction then
|
|
|
1039 raise Picture_Error;
|
|
|
1040 end if;
|
|
|
1041
|
|
|
1042 -- Two decimal points is a no-no
|
|
|
1043
|
|
|
1044 Answer.Has_Fraction := True;
|
|
|
1045 Answer.End_Of_Fraction := J;
|
|
|
1046
|
|
|
1047 -- Could leave this at Invalid_Position, but this seems the
|
|
|
1048 -- right way to indicate a null range...
|
|
|
1049
|
|
|
1050 Answer.Start_Of_Fraction := J + 1;
|
|
|
1051 Answer.End_Of_Int := J - 1;
|
|
|
1052
|
|
|
1053 when others =>
|
|
|
1054 raise Picture_Error; -- can this happen? probably not
|
|
|
1055 end case;
|
|
|
1056 end loop;
|
|
|
1057
|
|
|
1058 if Answer.Start_Of_Int = Invalid_Position then
|
|
|
1059 Answer.Start_Of_Int := Answer.End_Of_Int + 1;
|
|
|
1060 end if;
|
|
|
1061
|
|
|
1062 -- No significant (intger) digits needs a null range
|
|
|
1063
|
|
|
1064 return Answer;
|
|
|
1065 end Parse_Number_String;
|
|
|
1066
|
|
|
1067 ----------------
|
|
|
1068 -- Pic_String --
|
|
|
1069 ----------------
|
|
|
1070
|
|
|
1071 -- The following ensures that we return B and not b being careful not
|
|
|
1072 -- to break things which expect lower case b for blank. See CXF3A02.
|
|
|
1073
|
|
|
1074 function Pic_String (Pic : Picture) return String is
|
|
|
1075 Temp : String (1 .. Pic.Contents.Picture.Length) :=
|
|
|
1076 Pic.Contents.Picture.Expanded;
|
|
|
1077 begin
|
|
|
1078 for J in Temp'Range loop
|
|
|
1079 if Temp (J) = 'b' then
|
|
|
1080 Temp (J) := 'B';
|
|
|
1081 end if;
|
|
|
1082 end loop;
|
|
|
1083
|
|
|
1084 return Temp;
|
|
|
1085 end Pic_String;
|
|
|
1086
|
|
|
1087 ------------------
|
|
|
1088 -- Precalculate --
|
|
|
1089 ------------------
|
|
|
1090
|
|
|
1091 procedure Precalculate (Pic : in out Format_Record) is
|
|
|
1092
|
|
|
1093 Computed_BWZ : Boolean := True;
|
|
|
1094
|
|
|
1095 type Legality is (Okay, Reject);
|
|
|
1096 State : Legality := Reject;
|
|
|
1097 -- Start in reject, which will reject null strings
|
|
|
1098
|
|
|
1099 Index : Pic_Index := Pic.Picture.Expanded'First;
|
|
|
1100
|
|
|
1101 function At_End return Boolean;
|
|
|
1102 pragma Inline (At_End);
|
|
|
1103
|
|
|
1104 procedure Set_State (L : Legality);
|
|
|
1105 pragma Inline (Set_State);
|
|
|
1106
|
|
|
1107 function Look return Character;
|
|
|
1108 pragma Inline (Look);
|
|
|
1109
|
|
|
1110 function Is_Insert return Boolean;
|
|
|
1111 pragma Inline (Is_Insert);
|
|
|
1112
|
|
|
1113 procedure Skip;
|
|
|
1114 pragma Inline (Skip);
|
|
|
1115
|
|
|
1116 procedure Trailing_Currency;
|
|
|
1117 procedure Trailing_Bracket;
|
|
|
1118 procedure Number_Fraction;
|
|
|
1119 procedure Number_Completion;
|
|
|
1120 procedure Number_Fraction_Or_Bracket;
|
|
|
1121 procedure Number_Fraction_Or_Z_Fill;
|
|
|
1122 procedure Zero_Suppression;
|
|
|
1123 procedure Floating_Bracket;
|
|
|
1124 procedure Number_Fraction_Or_Star_Fill;
|
|
|
1125 procedure Star_Suppression;
|
|
|
1126 procedure Number_Fraction_Or_Dollar;
|
|
|
1127 procedure Leading_Dollar;
|
|
|
1128 procedure Number_Fraction_Or_Pound;
|
|
|
1129 procedure Leading_Pound;
|
|
|
1130 procedure Picture;
|
|
|
1131 procedure Floating_Plus;
|
|
|
1132 procedure Floating_Minus;
|
|
|
1133 procedure Picture_Plus;
|
|
|
1134 procedure Picture_Minus;
|
|
|
1135 procedure Picture_Bracket;
|
|
|
1136 procedure Number;
|
|
|
1137 procedure Optional_RHS_Sign;
|
|
|
1138 procedure Picture_String;
|
|
|
1139
|
|
|
1140 ------------
|
|
|
1141 -- At_End --
|
|
|
1142 ------------
|
|
|
1143
|
|
|
1144 function At_End return Boolean is
|
|
|
1145 begin
|
|
|
1146 return Index > Pic.Picture.Length;
|
|
|
1147 end At_End;
|
|
|
1148
|
|
|
1149 ----------------------
|
|
|
1150 -- Floating_Bracket --
|
|
|
1151 ----------------------
|
|
|
1152
|
|
|
1153 -- Note that Floating_Bracket is only called with an acceptable
|
|
|
1154 -- prefix. But we don't set Okay, because we must end with a '>'.
|
|
|
1155
|
|
|
1156 procedure Floating_Bracket is
|
|
|
1157 begin
|
|
|
1158 Pic.Floater := '<';
|
|
|
1159 Pic.End_Float := Index;
|
|
|
1160 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
1161
|
|
|
1162 -- First bracket wasn't counted...
|
|
|
1163
|
|
|
1164 Skip; -- known '<'
|
|
|
1165
|
|
|
1166 loop
|
|
|
1167 if At_End then
|
|
|
1168 return;
|
|
|
1169 end if;
|
|
|
1170
|
|
|
1171 case Look is
|
|
|
1172 when '_' | '0' | '/' =>
|
|
|
1173 Pic.End_Float := Index;
|
|
|
1174 Skip;
|
|
|
1175
|
|
|
1176 when 'B' | 'b' =>
|
|
|
1177 Pic.End_Float := Index;
|
|
|
1178 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1179 Skip;
|
|
|
1180
|
|
|
1181 when '<' =>
|
|
|
1182 Pic.End_Float := Index;
|
|
|
1183 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
1184 Skip;
|
|
|
1185
|
|
|
1186 when '9' =>
|
|
|
1187 Number_Completion;
|
|
|
1188
|
|
|
1189 when '$' =>
|
|
|
1190 Leading_Dollar;
|
|
|
1191
|
|
|
1192 when '#' =>
|
|
|
1193 Leading_Pound;
|
|
|
1194
|
|
|
1195 when 'V' | 'v' | '.' =>
|
|
|
1196 Pic.Radix_Position := Index;
|
|
|
1197 Skip;
|
|
|
1198 Number_Fraction_Or_Bracket;
|
|
|
1199 return;
|
|
|
1200
|
|
|
1201 when others =>
|
|
|
1202 return;
|
|
|
1203 end case;
|
|
|
1204 end loop;
|
|
|
1205 end Floating_Bracket;
|
|
|
1206
|
|
|
1207 --------------------
|
|
|
1208 -- Floating_Minus --
|
|
|
1209 --------------------
|
|
|
1210
|
|
|
1211 procedure Floating_Minus is
|
|
|
1212 begin
|
|
|
1213 loop
|
|
|
1214 if At_End then
|
|
|
1215 return;
|
|
|
1216 end if;
|
|
|
1217
|
|
|
1218 case Look is
|
|
|
1219 when '_' | '0' | '/' =>
|
|
|
1220 Pic.End_Float := Index;
|
|
|
1221 Skip;
|
|
|
1222
|
|
|
1223 when 'B' | 'b' =>
|
|
|
1224 Pic.End_Float := Index;
|
|
|
1225 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1226 Skip;
|
|
|
1227
|
|
|
1228 when '-' =>
|
|
|
1229 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
1230 Pic.End_Float := Index;
|
|
|
1231 Skip;
|
|
|
1232
|
|
|
1233 when '9' =>
|
|
|
1234 Number_Completion;
|
|
|
1235 return;
|
|
|
1236
|
|
|
1237 when '.' | 'V' | 'v' =>
|
|
|
1238 Pic.Radix_Position := Index;
|
|
|
1239 Skip; -- Radix
|
|
|
1240
|
|
|
1241 while Is_Insert loop
|
|
|
1242 Skip;
|
|
|
1243 end loop;
|
|
|
1244
|
|
|
1245 if At_End then
|
|
|
1246 return;
|
|
|
1247 end if;
|
|
|
1248
|
|
|
1249 if Look = '-' then
|
|
|
1250 loop
|
|
|
1251 if At_End then
|
|
|
1252 return;
|
|
|
1253 end if;
|
|
|
1254
|
|
|
1255 case Look is
|
|
|
1256 when '-' =>
|
|
|
1257 Pic.Max_Trailing_Digits :=
|
|
|
1258 Pic.Max_Trailing_Digits + 1;
|
|
|
1259 Pic.End_Float := Index;
|
|
|
1260 Skip;
|
|
|
1261
|
|
|
1262 when '_' | '0' | '/' =>
|
|
|
1263 Skip;
|
|
|
1264
|
|
|
1265 when 'B' | 'b' =>
|
|
|
1266 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1267 Skip;
|
|
|
1268
|
|
|
1269 when others =>
|
|
|
1270 return;
|
|
|
1271 end case;
|
|
|
1272 end loop;
|
|
|
1273
|
|
|
1274 else
|
|
|
1275 Number_Completion;
|
|
|
1276 end if;
|
|
|
1277
|
|
|
1278 return;
|
|
|
1279
|
|
|
1280 when others =>
|
|
|
1281 return;
|
|
|
1282 end case;
|
|
|
1283 end loop;
|
|
|
1284 end Floating_Minus;
|
|
|
1285
|
|
|
1286 -------------------
|
|
|
1287 -- Floating_Plus --
|
|
|
1288 -------------------
|
|
|
1289
|
|
|
1290 procedure Floating_Plus is
|
|
|
1291 begin
|
|
|
1292 loop
|
|
|
1293 if At_End then
|
|
|
1294 return;
|
|
|
1295 end if;
|
|
|
1296
|
|
|
1297 case Look is
|
|
|
1298 when '_' | '0' | '/' =>
|
|
|
1299 Pic.End_Float := Index;
|
|
|
1300 Skip;
|
|
|
1301
|
|
|
1302 when 'B' | 'b' =>
|
|
|
1303 Pic.End_Float := Index;
|
|
|
1304 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1305 Skip;
|
|
|
1306
|
|
|
1307 when '+' =>
|
|
|
1308 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
1309 Pic.End_Float := Index;
|
|
|
1310 Skip;
|
|
|
1311
|
|
|
1312 when '9' =>
|
|
|
1313 Number_Completion;
|
|
|
1314 return;
|
|
|
1315
|
|
|
1316 when '.' | 'V' | 'v' =>
|
|
|
1317 Pic.Radix_Position := Index;
|
|
|
1318 Skip; -- Radix
|
|
|
1319
|
|
|
1320 while Is_Insert loop
|
|
|
1321 Skip;
|
|
|
1322 end loop;
|
|
|
1323
|
|
|
1324 if At_End then
|
|
|
1325 return;
|
|
|
1326 end if;
|
|
|
1327
|
|
|
1328 if Look = '+' then
|
|
|
1329 loop
|
|
|
1330 if At_End then
|
|
|
1331 return;
|
|
|
1332 end if;
|
|
|
1333
|
|
|
1334 case Look is
|
|
|
1335 when '+' =>
|
|
|
1336 Pic.Max_Trailing_Digits :=
|
|
|
1337 Pic.Max_Trailing_Digits + 1;
|
|
|
1338 Pic.End_Float := Index;
|
|
|
1339 Skip;
|
|
|
1340
|
|
|
1341 when '_' | '0' | '/' =>
|
|
|
1342 Skip;
|
|
|
1343
|
|
|
1344 when 'B' | 'b' =>
|
|
|
1345 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1346 Skip;
|
|
|
1347
|
|
|
1348 when others =>
|
|
|
1349 return;
|
|
|
1350 end case;
|
|
|
1351 end loop;
|
|
|
1352
|
|
|
1353 else
|
|
|
1354 Number_Completion;
|
|
|
1355 end if;
|
|
|
1356
|
|
|
1357 return;
|
|
|
1358
|
|
|
1359 when others =>
|
|
|
1360 return;
|
|
|
1361 end case;
|
|
|
1362 end loop;
|
|
|
1363 end Floating_Plus;
|
|
|
1364
|
|
|
1365 ---------------
|
|
|
1366 -- Is_Insert --
|
|
|
1367 ---------------
|
|
|
1368
|
|
|
1369 function Is_Insert return Boolean is
|
|
|
1370 begin
|
|
|
1371 if At_End then
|
|
|
1372 return False;
|
|
|
1373 end if;
|
|
|
1374
|
|
|
1375 case Pic.Picture.Expanded (Index) is
|
|
|
1376 when '_' | '0' | '/' =>
|
|
|
1377 return True;
|
|
|
1378
|
|
|
1379 when 'B' | 'b' =>
|
|
|
1380 Pic.Picture.Expanded (Index) := 'b'; -- canonical
|
|
|
1381 return True;
|
|
|
1382
|
|
|
1383 when others =>
|
|
|
1384 return False;
|
|
|
1385 end case;
|
|
|
1386 end Is_Insert;
|
|
|
1387
|
|
|
1388 --------------------
|
|
|
1389 -- Leading_Dollar --
|
|
|
1390 --------------------
|
|
|
1391
|
|
|
1392 -- Note that Leading_Dollar can be called in either State.
|
|
|
1393 -- It will set state to Okay only if a 9 or (second) $ is encountered.
|
|
|
1394
|
|
|
1395 -- Also notice the tricky bit with State and Zero_Suppression.
|
|
|
1396 -- Zero_Suppression is Picture_Error if a '$' or a '9' has been
|
|
|
1397 -- encountered, exactly the cases where State has been set.
|
|
|
1398
|
|
|
1399 procedure Leading_Dollar is
|
|
|
1400 begin
|
|
|
1401 -- Treat as a floating dollar, and unwind otherwise
|
|
|
1402
|
|
|
1403 Pic.Floater := '$';
|
|
|
1404 Pic.Start_Currency := Index;
|
|
|
1405 Pic.End_Currency := Index;
|
|
|
1406 Pic.Start_Float := Index;
|
|
|
1407 Pic.End_Float := Index;
|
|
|
1408
|
|
|
1409 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
|
|
|
1410 -- currency place.
|
|
|
1411
|
|
|
1412 Skip; -- known '$'
|
|
|
1413
|
|
|
1414 loop
|
|
|
1415 if At_End then
|
|
|
1416 return;
|
|
|
1417 end if;
|
|
|
1418
|
|
|
1419 case Look is
|
|
|
1420 when '_' | '0' | '/' =>
|
|
|
1421 Pic.End_Float := Index;
|
|
|
1422 Skip;
|
|
|
1423
|
|
|
1424 -- A trailing insertion character is not part of the
|
|
|
1425 -- floating currency, so need to look ahead.
|
|
|
1426
|
|
|
1427 if Look /= '$' then
|
|
|
1428 Pic.End_Float := Pic.End_Float - 1;
|
|
|
1429 end if;
|
|
|
1430
|
|
|
1431 when 'B' | 'b' =>
|
|
|
1432 Pic.End_Float := Index;
|
|
|
1433 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1434 Skip;
|
|
|
1435
|
|
|
1436 when 'Z' | 'z' =>
|
|
|
1437 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
1438
|
|
|
1439 if State = Okay then
|
|
|
1440 raise Picture_Error;
|
|
|
1441 else
|
|
|
1442 -- Will overwrite Floater and Start_Float
|
|
|
1443
|
|
|
1444 Zero_Suppression;
|
|
|
1445 end if;
|
|
|
1446
|
|
|
1447 when '*' =>
|
|
|
1448 if State = Okay then
|
|
|
1449 raise Picture_Error;
|
|
|
1450 else
|
|
|
1451 -- Will overwrite Floater and Start_Float
|
|
|
1452
|
|
|
1453 Star_Suppression;
|
|
|
1454 end if;
|
|
|
1455
|
|
|
1456 when '$' =>
|
|
|
1457 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
1458 Pic.End_Float := Index;
|
|
|
1459 Pic.End_Currency := Index;
|
|
|
1460 Set_State (Okay); Skip;
|
|
|
1461
|
|
|
1462 when '9' =>
|
|
|
1463 if State /= Okay then
|
|
|
1464 Pic.Floater := '!';
|
|
|
1465 Pic.Start_Float := Invalid_Position;
|
|
|
1466 Pic.End_Float := Invalid_Position;
|
|
|
1467 end if;
|
|
|
1468
|
|
|
1469 -- A single dollar does not a floating make
|
|
|
1470
|
|
|
1471 Number_Completion;
|
|
|
1472 return;
|
|
|
1473
|
|
|
1474 when 'V' | 'v' | '.' =>
|
|
|
1475 if State /= Okay then
|
|
|
1476 Pic.Floater := '!';
|
|
|
1477 Pic.Start_Float := Invalid_Position;
|
|
|
1478 Pic.End_Float := Invalid_Position;
|
|
|
1479 end if;
|
|
|
1480
|
|
|
1481 -- Only one dollar before the sign is okay, but doesn't
|
|
|
1482 -- float.
|
|
|
1483
|
|
|
1484 Pic.Radix_Position := Index;
|
|
|
1485 Skip;
|
|
|
1486 Number_Fraction_Or_Dollar;
|
|
|
1487 return;
|
|
|
1488
|
|
|
1489 when others =>
|
|
|
1490 return;
|
|
|
1491 end case;
|
|
|
1492 end loop;
|
|
|
1493 end Leading_Dollar;
|
|
|
1494
|
|
|
1495 -------------------
|
|
|
1496 -- Leading_Pound --
|
|
|
1497 -------------------
|
|
|
1498
|
|
|
1499 -- This one is complex. A Leading_Pound can be fixed or floating,
|
|
|
1500 -- but in some cases the decision has to be deferred until we leave
|
|
|
1501 -- this procedure. Also note that Leading_Pound can be called in
|
|
|
1502 -- either State.
|
|
|
1503
|
|
|
1504 -- It will set state to Okay only if a 9 or (second) # is
|
|
|
1505 -- encountered.
|
|
|
1506
|
|
|
1507 -- One Last note: In ambiguous cases, the currency is treated as
|
|
|
1508 -- floating unless there is only one '#'.
|
|
|
1509
|
|
|
1510 procedure Leading_Pound is
|
|
|
1511
|
|
|
1512 Inserts : Boolean := False;
|
|
|
1513 -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered
|
|
|
1514
|
|
|
1515 Must_Float : Boolean := False;
|
|
|
1516 -- Set to true if a '#' occurs after an insert
|
|
|
1517
|
|
|
1518 begin
|
|
|
1519 -- Treat as a floating currency. If it isn't, this will be
|
|
|
1520 -- overwritten later.
|
|
|
1521
|
|
|
1522 Pic.Floater := '#';
|
|
|
1523
|
|
|
1524 Pic.Start_Currency := Index;
|
|
|
1525 Pic.End_Currency := Index;
|
|
|
1526 Pic.Start_Float := Index;
|
|
|
1527 Pic.End_Float := Index;
|
|
|
1528
|
|
|
1529 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
|
|
|
1530 -- currency place.
|
|
|
1531
|
|
|
1532 Pic.Max_Currency_Digits := 1; -- we've seen one.
|
|
|
1533
|
|
|
1534 Skip; -- known '#'
|
|
|
1535
|
|
|
1536 loop
|
|
|
1537 if At_End then
|
|
|
1538 return;
|
|
|
1539 end if;
|
|
|
1540
|
|
|
1541 case Look is
|
|
|
1542 when '_' | '0' | '/' =>
|
|
|
1543 Pic.End_Float := Index;
|
|
|
1544 Inserts := True;
|
|
|
1545 Skip;
|
|
|
1546
|
|
|
1547 when 'B' | 'b' =>
|
|
|
1548 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1549 Pic.End_Float := Index;
|
|
|
1550 Inserts := True;
|
|
|
1551 Skip;
|
|
|
1552
|
|
|
1553 when 'Z' | 'z' =>
|
|
|
1554 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
1555
|
|
|
1556 if Must_Float then
|
|
|
1557 raise Picture_Error;
|
|
|
1558 else
|
|
|
1559 Pic.Max_Leading_Digits := 0;
|
|
|
1560
|
|
|
1561 -- Will overwrite Floater and Start_Float
|
|
|
1562
|
|
|
1563 Zero_Suppression;
|
|
|
1564 end if;
|
|
|
1565
|
|
|
1566 when '*' =>
|
|
|
1567 if Must_Float then
|
|
|
1568 raise Picture_Error;
|
|
|
1569 else
|
|
|
1570 Pic.Max_Leading_Digits := 0;
|
|
|
1571
|
|
|
1572 -- Will overwrite Floater and Start_Float
|
|
|
1573
|
|
|
1574 Star_Suppression;
|
|
|
1575 end if;
|
|
|
1576
|
|
|
1577 when '#' =>
|
|
|
1578 if Inserts then
|
|
|
1579 Must_Float := True;
|
|
|
1580 end if;
|
|
|
1581
|
|
|
1582 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
1583 Pic.End_Float := Index;
|
|
|
1584 Pic.End_Currency := Index;
|
|
|
1585 Set_State (Okay);
|
|
|
1586 Skip;
|
|
|
1587
|
|
|
1588 when '9' =>
|
|
|
1589 if State /= Okay then
|
|
|
1590
|
|
|
1591 -- A single '#' doesn't float
|
|
|
1592
|
|
|
1593 Pic.Floater := '!';
|
|
|
1594 Pic.Start_Float := Invalid_Position;
|
|
|
1595 Pic.End_Float := Invalid_Position;
|
|
|
1596 end if;
|
|
|
1597
|
|
|
1598 Number_Completion;
|
|
|
1599 return;
|
|
|
1600
|
|
|
1601 when 'V' | 'v' | '.' =>
|
|
|
1602 if State /= Okay then
|
|
|
1603 Pic.Floater := '!';
|
|
|
1604 Pic.Start_Float := Invalid_Position;
|
|
|
1605 Pic.End_Float := Invalid_Position;
|
|
|
1606 end if;
|
|
|
1607
|
|
|
1608 -- Only one pound before the sign is okay, but doesn't
|
|
|
1609 -- float.
|
|
|
1610
|
|
|
1611 Pic.Radix_Position := Index;
|
|
|
1612 Skip;
|
|
|
1613 Number_Fraction_Or_Pound;
|
|
|
1614 return;
|
|
|
1615
|
|
|
1616 when others =>
|
|
|
1617 return;
|
|
|
1618 end case;
|
|
|
1619 end loop;
|
|
|
1620 end Leading_Pound;
|
|
|
1621
|
|
|
1622 ----------
|
|
|
1623 -- Look --
|
|
|
1624 ----------
|
|
|
1625
|
|
|
1626 function Look return Character is
|
|
|
1627 begin
|
|
|
1628 if At_End then
|
|
|
1629 raise Picture_Error;
|
|
|
1630 end if;
|
|
|
1631
|
|
|
1632 return Pic.Picture.Expanded (Index);
|
|
|
1633 end Look;
|
|
|
1634
|
|
|
1635 ------------
|
|
|
1636 -- Number --
|
|
|
1637 ------------
|
|
|
1638
|
|
|
1639 procedure Number is
|
|
|
1640 begin
|
|
|
1641 loop
|
|
|
1642 case Look is
|
|
|
1643 when '_' | '0' | '/' =>
|
|
|
1644 Skip;
|
|
|
1645
|
|
|
1646 when 'B' | 'b' =>
|
|
|
1647 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1648 Skip;
|
|
|
1649
|
|
|
1650 when '9' =>
|
|
|
1651 Computed_BWZ := False;
|
|
|
1652 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
1653 Set_State (Okay);
|
|
|
1654 Skip;
|
|
|
1655
|
|
|
1656 when '.' | 'V' | 'v' =>
|
|
|
1657 Pic.Radix_Position := Index;
|
|
|
1658 Skip;
|
|
|
1659 Number_Fraction;
|
|
|
1660 return;
|
|
|
1661
|
|
|
1662 when others =>
|
|
|
1663 return;
|
|
|
1664 end case;
|
|
|
1665
|
|
|
1666 if At_End then
|
|
|
1667 return;
|
|
|
1668 end if;
|
|
|
1669
|
|
|
1670 -- Will return in Okay state if a '9' was seen
|
|
|
1671
|
|
|
1672 end loop;
|
|
|
1673 end Number;
|
|
|
1674
|
|
|
1675 -----------------------
|
|
|
1676 -- Number_Completion --
|
|
|
1677 -----------------------
|
|
|
1678
|
|
|
1679 procedure Number_Completion is
|
|
|
1680 begin
|
|
|
1681 while not At_End loop
|
|
|
1682 case Look is
|
|
|
1683 when '_' | '0' | '/' =>
|
|
|
1684 Skip;
|
|
|
1685
|
|
|
1686 when 'B' | 'b' =>
|
|
|
1687 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1688 Skip;
|
|
|
1689
|
|
|
1690 when '9' =>
|
|
|
1691 Computed_BWZ := False;
|
|
|
1692 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
1693 Set_State (Okay);
|
|
|
1694 Skip;
|
|
|
1695
|
|
|
1696 when 'V' | 'v' | '.' =>
|
|
|
1697 Pic.Radix_Position := Index;
|
|
|
1698 Skip;
|
|
|
1699 Number_Fraction;
|
|
|
1700 return;
|
|
|
1701
|
|
|
1702 when others =>
|
|
|
1703 return;
|
|
|
1704 end case;
|
|
|
1705 end loop;
|
|
|
1706 end Number_Completion;
|
|
|
1707
|
|
|
1708 ---------------------
|
|
|
1709 -- Number_Fraction --
|
|
|
1710 ---------------------
|
|
|
1711
|
|
|
1712 procedure Number_Fraction is
|
|
|
1713 begin
|
|
|
1714 -- Note that number fraction can be called in either State.
|
|
|
1715 -- It will set state to Valid only if a 9 is encountered.
|
|
|
1716
|
|
|
1717 loop
|
|
|
1718 if At_End then
|
|
|
1719 return;
|
|
|
1720 end if;
|
|
|
1721
|
|
|
1722 case Look is
|
|
|
1723 when '_' | '0' | '/' =>
|
|
|
1724 Skip;
|
|
|
1725
|
|
|
1726 when 'B' | 'b' =>
|
|
|
1727 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1728 Skip;
|
|
|
1729
|
|
|
1730 when '9' =>
|
|
|
1731 Computed_BWZ := False;
|
|
|
1732 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
|
|
|
1733 Set_State (Okay); Skip;
|
|
|
1734
|
|
|
1735 when others =>
|
|
|
1736 return;
|
|
|
1737 end case;
|
|
|
1738 end loop;
|
|
|
1739 end Number_Fraction;
|
|
|
1740
|
|
|
1741 --------------------------------
|
|
|
1742 -- Number_Fraction_Or_Bracket --
|
|
|
1743 --------------------------------
|
|
|
1744
|
|
|
1745 procedure Number_Fraction_Or_Bracket is
|
|
|
1746 begin
|
|
|
1747 loop
|
|
|
1748 if At_End then
|
|
|
1749 return;
|
|
|
1750 end if;
|
|
|
1751
|
|
|
1752 case Look is
|
|
|
1753 when '_' | '0' | '/' =>
|
|
|
1754 Skip;
|
|
|
1755
|
|
|
1756 when 'B' | 'b' =>
|
|
|
1757 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1758 Skip;
|
|
|
1759
|
|
|
1760 when '<' =>
|
|
|
1761 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
|
|
|
1762 Pic.End_Float := Index;
|
|
|
1763 Skip;
|
|
|
1764
|
|
|
1765 loop
|
|
|
1766 if At_End then
|
|
|
1767 return;
|
|
|
1768 end if;
|
|
|
1769
|
|
|
1770 case Look is
|
|
|
1771 when '_' | '0' | '/' =>
|
|
|
1772 Skip;
|
|
|
1773
|
|
|
1774 when 'B' | 'b' =>
|
|
|
1775 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1776 Skip;
|
|
|
1777
|
|
|
1778 when '<' =>
|
|
|
1779 Pic.Max_Trailing_Digits :=
|
|
|
1780 Pic.Max_Trailing_Digits + 1;
|
|
|
1781 Pic.End_Float := Index;
|
|
|
1782 Skip;
|
|
|
1783
|
|
|
1784 when others =>
|
|
|
1785 return;
|
|
|
1786 end case;
|
|
|
1787 end loop;
|
|
|
1788
|
|
|
1789 when others =>
|
|
|
1790 Number_Fraction;
|
|
|
1791 return;
|
|
|
1792 end case;
|
|
|
1793 end loop;
|
|
|
1794 end Number_Fraction_Or_Bracket;
|
|
|
1795
|
|
|
1796 -------------------------------
|
|
|
1797 -- Number_Fraction_Or_Dollar --
|
|
|
1798 -------------------------------
|
|
|
1799
|
|
|
1800 procedure Number_Fraction_Or_Dollar is
|
|
|
1801 begin
|
|
|
1802 loop
|
|
|
1803 if At_End then
|
|
|
1804 return;
|
|
|
1805 end if;
|
|
|
1806
|
|
|
1807 case Look is
|
|
|
1808 when '_' | '0' | '/' =>
|
|
|
1809 Skip;
|
|
|
1810
|
|
|
1811 when 'B' | 'b' =>
|
|
|
1812 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1813 Skip;
|
|
|
1814
|
|
|
1815 when '$' =>
|
|
|
1816 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
|
|
|
1817 Pic.End_Float := Index;
|
|
|
1818 Skip;
|
|
|
1819
|
|
|
1820 loop
|
|
|
1821 if At_End then
|
|
|
1822 return;
|
|
|
1823 end if;
|
|
|
1824
|
|
|
1825 case Look is
|
|
|
1826 when '_' | '0' | '/' =>
|
|
|
1827 Skip;
|
|
|
1828
|
|
|
1829 when 'B' | 'b' =>
|
|
|
1830 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1831 Skip;
|
|
|
1832
|
|
|
1833 when '$' =>
|
|
|
1834 Pic.Max_Trailing_Digits :=
|
|
|
1835 Pic.Max_Trailing_Digits + 1;
|
|
|
1836 Pic.End_Float := Index;
|
|
|
1837 Skip;
|
|
|
1838
|
|
|
1839 when others =>
|
|
|
1840 return;
|
|
|
1841 end case;
|
|
|
1842 end loop;
|
|
|
1843
|
|
|
1844 when others =>
|
|
|
1845 Number_Fraction;
|
|
|
1846 return;
|
|
|
1847 end case;
|
|
|
1848 end loop;
|
|
|
1849 end Number_Fraction_Or_Dollar;
|
|
|
1850
|
|
|
1851 ------------------------------
|
|
|
1852 -- Number_Fraction_Or_Pound --
|
|
|
1853 ------------------------------
|
|
|
1854
|
|
|
1855 procedure Number_Fraction_Or_Pound is
|
|
|
1856 begin
|
|
|
1857 loop
|
|
|
1858 if At_End then
|
|
|
1859 return;
|
|
|
1860 end if;
|
|
|
1861
|
|
|
1862 case Look is
|
|
|
1863 when '_' | '0' | '/' =>
|
|
|
1864 Skip;
|
|
|
1865
|
|
|
1866 when 'B' | 'b' =>
|
|
|
1867 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1868 Skip;
|
|
|
1869
|
|
|
1870 when '#' =>
|
|
|
1871 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
|
|
|
1872 Pic.End_Float := Index;
|
|
|
1873 Skip;
|
|
|
1874
|
|
|
1875 loop
|
|
|
1876 if At_End then
|
|
|
1877 return;
|
|
|
1878 end if;
|
|
|
1879
|
|
|
1880 case Look is
|
|
|
1881 when '_' | '0' | '/' =>
|
|
|
1882 Skip;
|
|
|
1883
|
|
|
1884 when 'B' | 'b' =>
|
|
|
1885 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1886 Skip;
|
|
|
1887
|
|
|
1888 when '#' =>
|
|
|
1889 Pic.Max_Trailing_Digits :=
|
|
|
1890 Pic.Max_Trailing_Digits + 1;
|
|
|
1891 Pic.End_Float := Index;
|
|
|
1892 Skip;
|
|
|
1893
|
|
|
1894 when others =>
|
|
|
1895 return;
|
|
|
1896 end case;
|
|
|
1897 end loop;
|
|
|
1898
|
|
|
1899 when others =>
|
|
|
1900 Number_Fraction;
|
|
|
1901 return;
|
|
|
1902 end case;
|
|
|
1903 end loop;
|
|
|
1904 end Number_Fraction_Or_Pound;
|
|
|
1905
|
|
|
1906 ----------------------------------
|
|
|
1907 -- Number_Fraction_Or_Star_Fill --
|
|
|
1908 ----------------------------------
|
|
|
1909
|
|
|
1910 procedure Number_Fraction_Or_Star_Fill is
|
|
|
1911 begin
|
|
|
1912 loop
|
|
|
1913 if At_End then
|
|
|
1914 return;
|
|
|
1915 end if;
|
|
|
1916
|
|
|
1917 case Look is
|
|
|
1918 when '_' | '0' | '/' =>
|
|
|
1919 Skip;
|
|
|
1920
|
|
|
1921 when 'B' | 'b' =>
|
|
|
1922 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1923 Skip;
|
|
|
1924
|
|
|
1925 when '*' =>
|
|
|
1926 Pic.Star_Fill := True;
|
|
|
1927 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
|
|
|
1928 Pic.End_Float := Index;
|
|
|
1929 Skip;
|
|
|
1930
|
|
|
1931 loop
|
|
|
1932 if At_End then
|
|
|
1933 return;
|
|
|
1934 end if;
|
|
|
1935
|
|
|
1936 case Look is
|
|
|
1937 when '_' | '0' | '/' =>
|
|
|
1938 Skip;
|
|
|
1939
|
|
|
1940 when 'B' | 'b' =>
|
|
|
1941 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1942 Skip;
|
|
|
1943
|
|
|
1944 when '*' =>
|
|
|
1945 Pic.Star_Fill := True;
|
|
|
1946 Pic.Max_Trailing_Digits :=
|
|
|
1947 Pic.Max_Trailing_Digits + 1;
|
|
|
1948 Pic.End_Float := Index;
|
|
|
1949 Skip;
|
|
|
1950
|
|
|
1951 when others =>
|
|
|
1952 return;
|
|
|
1953 end case;
|
|
|
1954 end loop;
|
|
|
1955
|
|
|
1956 when others =>
|
|
|
1957 Number_Fraction;
|
|
|
1958 return;
|
|
|
1959 end case;
|
|
|
1960 end loop;
|
|
|
1961 end Number_Fraction_Or_Star_Fill;
|
|
|
1962
|
|
|
1963 -------------------------------
|
|
|
1964 -- Number_Fraction_Or_Z_Fill --
|
|
|
1965 -------------------------------
|
|
|
1966
|
|
|
1967 procedure Number_Fraction_Or_Z_Fill is
|
|
|
1968 begin
|
|
|
1969 loop
|
|
|
1970 if At_End then
|
|
|
1971 return;
|
|
|
1972 end if;
|
|
|
1973
|
|
|
1974 case Look is
|
|
|
1975 when '_' | '0' | '/' =>
|
|
|
1976 Skip;
|
|
|
1977
|
|
|
1978 when 'B' | 'b' =>
|
|
|
1979 Pic.Picture.Expanded (Index) := 'b';
|
|
|
1980 Skip;
|
|
|
1981
|
|
|
1982 when 'Z' | 'z' =>
|
|
|
1983 Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1;
|
|
|
1984 Pic.End_Float := Index;
|
|
|
1985 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
1986
|
|
|
1987 Skip;
|
|
|
1988
|
|
|
1989 loop
|
|
|
1990 if At_End then
|
|
|
1991 return;
|
|
|
1992 end if;
|
|
|
1993
|
|
|
1994 case Look is
|
|
|
1995 when '_' | '0' | '/' =>
|
|
|
1996 Skip;
|
|
|
1997
|
|
|
1998 when 'B' | 'b' =>
|
|
|
1999 Pic.Picture.Expanded (Index) := 'b';
|
|
|
2000 Skip;
|
|
|
2001
|
|
|
2002 when 'Z' | 'z' =>
|
|
|
2003 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
2004
|
|
|
2005 Pic.Max_Trailing_Digits :=
|
|
|
2006 Pic.Max_Trailing_Digits + 1;
|
|
|
2007 Pic.End_Float := Index;
|
|
|
2008 Skip;
|
|
|
2009
|
|
|
2010 when others =>
|
|
|
2011 return;
|
|
|
2012 end case;
|
|
|
2013 end loop;
|
|
|
2014
|
|
|
2015 when others =>
|
|
|
2016 Number_Fraction;
|
|
|
2017 return;
|
|
|
2018 end case;
|
|
|
2019 end loop;
|
|
|
2020 end Number_Fraction_Or_Z_Fill;
|
|
|
2021
|
|
|
2022 -----------------------
|
|
|
2023 -- Optional_RHS_Sign --
|
|
|
2024 -----------------------
|
|
|
2025
|
|
|
2026 procedure Optional_RHS_Sign is
|
|
|
2027 begin
|
|
|
2028 if At_End then
|
|
|
2029 return;
|
|
|
2030 end if;
|
|
|
2031
|
|
|
2032 case Look is
|
|
|
2033 when '+' | '-' =>
|
|
|
2034 Pic.Sign_Position := Index;
|
|
|
2035 Skip;
|
|
|
2036 return;
|
|
|
2037
|
|
|
2038 when 'C' | 'c' =>
|
|
|
2039 Pic.Sign_Position := Index;
|
|
|
2040 Pic.Picture.Expanded (Index) := 'C';
|
|
|
2041 Skip;
|
|
|
2042
|
|
|
2043 if Look = 'R' or else Look = 'r' then
|
|
|
2044 Pic.Second_Sign := Index;
|
|
|
2045 Pic.Picture.Expanded (Index) := 'R';
|
|
|
2046 Skip;
|
|
|
2047
|
|
|
2048 else
|
|
|
2049 raise Picture_Error;
|
|
|
2050 end if;
|
|
|
2051
|
|
|
2052 return;
|
|
|
2053
|
|
|
2054 when 'D' | 'd' =>
|
|
|
2055 Pic.Sign_Position := Index;
|
|
|
2056 Pic.Picture.Expanded (Index) := 'D';
|
|
|
2057 Skip;
|
|
|
2058
|
|
|
2059 if Look = 'B' or else Look = 'b' then
|
|
|
2060 Pic.Second_Sign := Index;
|
|
|
2061 Pic.Picture.Expanded (Index) := 'B';
|
|
|
2062 Skip;
|
|
|
2063
|
|
|
2064 else
|
|
|
2065 raise Picture_Error;
|
|
|
2066 end if;
|
|
|
2067
|
|
|
2068 return;
|
|
|
2069
|
|
|
2070 when '>' =>
|
|
|
2071 if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then
|
|
|
2072 Pic.Second_Sign := Index;
|
|
|
2073 Skip;
|
|
|
2074
|
|
|
2075 else
|
|
|
2076 raise Picture_Error;
|
|
|
2077 end if;
|
|
|
2078
|
|
|
2079 when others =>
|
|
|
2080 return;
|
|
|
2081 end case;
|
|
|
2082 end Optional_RHS_Sign;
|
|
|
2083
|
|
|
2084 -------------
|
|
|
2085 -- Picture --
|
|
|
2086 -------------
|
|
|
2087
|
|
|
2088 -- Note that Picture can be called in either State
|
|
|
2089
|
|
|
2090 -- It will set state to Valid only if a 9 is encountered or floating
|
|
|
2091 -- currency is called.
|
|
|
2092
|
|
|
2093 procedure Picture is
|
|
|
2094 begin
|
|
|
2095 loop
|
|
|
2096 if At_End then
|
|
|
2097 return;
|
|
|
2098 end if;
|
|
|
2099
|
|
|
2100 case Look is
|
|
|
2101 when '_' | '0' | '/' =>
|
|
|
2102 Skip;
|
|
|
2103
|
|
|
2104 when 'B' | 'b' =>
|
|
|
2105 Pic.Picture.Expanded (Index) := 'b';
|
|
|
2106 Skip;
|
|
|
2107
|
|
|
2108 when '$' =>
|
|
|
2109 Leading_Dollar;
|
|
|
2110 return;
|
|
|
2111
|
|
|
2112 when '#' =>
|
|
|
2113 Leading_Pound;
|
|
|
2114 return;
|
|
|
2115
|
|
|
2116 when '9' =>
|
|
|
2117 Computed_BWZ := False;
|
|
|
2118 Set_State (Okay);
|
|
|
2119 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
2120 Skip;
|
|
|
2121
|
|
|
2122 when 'V' | 'v' | '.' =>
|
|
|
2123 Pic.Radix_Position := Index;
|
|
|
2124 Skip;
|
|
|
2125 Number_Fraction;
|
|
|
2126 Trailing_Currency;
|
|
|
2127 return;
|
|
|
2128
|
|
|
2129 when others =>
|
|
|
2130 return;
|
|
|
2131 end case;
|
|
|
2132 end loop;
|
|
|
2133 end Picture;
|
|
|
2134
|
|
|
2135 ---------------------
|
|
|
2136 -- Picture_Bracket --
|
|
|
2137 ---------------------
|
|
|
2138
|
|
|
2139 procedure Picture_Bracket is
|
|
|
2140 begin
|
|
|
2141 Pic.Sign_Position := Index;
|
|
|
2142 Pic.Sign_Position := Index;
|
|
|
2143
|
|
|
2144 -- Treat as a floating sign, and unwind otherwise
|
|
|
2145
|
|
|
2146 Pic.Floater := '<';
|
|
|
2147 Pic.Start_Float := Index;
|
|
|
2148 Pic.End_Float := Index;
|
|
|
2149
|
|
|
2150 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
|
|
|
2151 -- sign place.
|
|
|
2152
|
|
|
2153 Skip; -- Known Bracket
|
|
|
2154
|
|
|
2155 loop
|
|
|
2156 case Look is
|
|
|
2157 when '_' | '0' | '/' =>
|
|
|
2158 Pic.End_Float := Index;
|
|
|
2159 Skip;
|
|
|
2160
|
|
|
2161 when 'B' | 'b' =>
|
|
|
2162 Pic.End_Float := Index;
|
|
|
2163 Pic.Picture.Expanded (Index) := 'b';
|
|
|
2164 Skip;
|
|
|
2165
|
|
|
2166 when '<' =>
|
|
|
2167 Set_State (Okay); -- "<<>" is enough.
|
|
|
2168 Floating_Bracket;
|
|
|
2169 Trailing_Currency;
|
|
|
2170 Trailing_Bracket;
|
|
|
2171 return;
|
|
|
2172
|
|
|
2173 when '$' | '#' | '9' | '*' =>
|
|
|
2174 if State /= Okay then
|
|
|
2175 Pic.Floater := '!';
|
|
|
2176 Pic.Start_Float := Invalid_Position;
|
|
|
2177 Pic.End_Float := Invalid_Position;
|
|
|
2178 end if;
|
|
|
2179
|
|
|
2180 Picture;
|
|
|
2181 Trailing_Bracket;
|
|
|
2182 Set_State (Okay);
|
|
|
2183 return;
|
|
|
2184
|
|
|
2185 when '.' | 'V' | 'v' =>
|
|
|
2186 if State /= Okay then
|
|
|
2187 Pic.Floater := '!';
|
|
|
2188 Pic.Start_Float := Invalid_Position;
|
|
|
2189 Pic.End_Float := Invalid_Position;
|
|
|
2190 end if;
|
|
|
2191
|
|
|
2192 -- Don't assume that state is okay, haven't seen a digit
|
|
|
2193
|
|
|
2194 Picture;
|
|
|
2195 Trailing_Bracket;
|
|
|
2196 return;
|
|
|
2197
|
|
|
2198 when others =>
|
|
|
2199 raise Picture_Error;
|
|
|
2200 end case;
|
|
|
2201 end loop;
|
|
|
2202 end Picture_Bracket;
|
|
|
2203
|
|
|
2204 -------------------
|
|
|
2205 -- Picture_Minus --
|
|
|
2206 -------------------
|
|
|
2207
|
|
|
2208 procedure Picture_Minus is
|
|
|
2209 begin
|
|
|
2210 Pic.Sign_Position := Index;
|
|
|
2211
|
|
|
2212 -- Treat as a floating sign, and unwind otherwise
|
|
|
2213
|
|
|
2214 Pic.Floater := '-';
|
|
|
2215 Pic.Start_Float := Index;
|
|
|
2216 Pic.End_Float := Index;
|
|
|
2217
|
|
|
2218 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
|
|
|
2219 -- sign place.
|
|
|
2220
|
|
|
2221 Skip; -- Known Minus
|
|
|
2222
|
|
|
2223 loop
|
|
|
2224 case Look is
|
|
|
2225 when '_' | '0' | '/' =>
|
|
|
2226 Pic.End_Float := Index;
|
|
|
2227 Skip;
|
|
|
2228
|
|
|
2229 when 'B' | 'b' =>
|
|
|
2230 Pic.End_Float := Index;
|
|
|
2231 Pic.Picture.Expanded (Index) := 'b';
|
|
|
2232 Skip;
|
|
|
2233
|
|
|
2234 when '-' =>
|
|
|
2235 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
2236 Pic.End_Float := Index;
|
|
|
2237 Skip;
|
|
|
2238 Set_State (Okay); -- "-- " is enough
|
|
|
2239 Floating_Minus;
|
|
|
2240 Trailing_Currency;
|
|
|
2241 return;
|
|
|
2242
|
|
|
2243 when '$' | '#' | '9' | '*' =>
|
|
|
2244 if State /= Okay then
|
|
|
2245 Pic.Floater := '!';
|
|
|
2246 Pic.Start_Float := Invalid_Position;
|
|
|
2247 Pic.End_Float := Invalid_Position;
|
|
|
2248 end if;
|
|
|
2249
|
|
|
2250 Picture;
|
|
|
2251 Set_State (Okay);
|
|
|
2252 return;
|
|
|
2253
|
|
|
2254 when 'Z' | 'z' =>
|
|
|
2255
|
|
|
2256 -- Can't have Z and a floating sign
|
|
|
2257
|
|
|
2258 if State = Okay then
|
|
|
2259 Set_State (Reject);
|
|
|
2260 end if;
|
|
|
2261
|
|
|
2262 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
2263 Zero_Suppression;
|
|
|
2264 Trailing_Currency;
|
|
|
2265 Optional_RHS_Sign;
|
|
|
2266 return;
|
|
|
2267
|
|
|
2268 when '.' | 'V' | 'v' =>
|
|
|
2269 if State /= Okay then
|
|
|
2270 Pic.Floater := '!';
|
|
|
2271 Pic.Start_Float := Invalid_Position;
|
|
|
2272 Pic.End_Float := Invalid_Position;
|
|
|
2273 end if;
|
|
|
2274
|
|
|
2275 -- Don't assume that state is okay, haven't seen a digit
|
|
|
2276
|
|
|
2277 Picture;
|
|
|
2278 return;
|
|
|
2279
|
|
|
2280 when others =>
|
|
|
2281 return;
|
|
|
2282 end case;
|
|
|
2283 end loop;
|
|
|
2284 end Picture_Minus;
|
|
|
2285
|
|
|
2286 ------------------
|
|
|
2287 -- Picture_Plus --
|
|
|
2288 ------------------
|
|
|
2289
|
|
|
2290 procedure Picture_Plus is
|
|
|
2291 begin
|
|
|
2292 Pic.Sign_Position := Index;
|
|
|
2293
|
|
|
2294 -- Treat as a floating sign, and unwind otherwise
|
|
|
2295
|
|
|
2296 Pic.Floater := '+';
|
|
|
2297 Pic.Start_Float := Index;
|
|
|
2298 Pic.End_Float := Index;
|
|
|
2299
|
|
|
2300 -- Don't increment Pic.Max_Leading_Digits, we need one "real"
|
|
|
2301 -- sign place.
|
|
|
2302
|
|
|
2303 Skip; -- Known Plus
|
|
|
2304
|
|
|
2305 loop
|
|
|
2306 case Look is
|
|
|
2307 when '_' | '0' | '/' =>
|
|
|
2308 Pic.End_Float := Index;
|
|
|
2309 Skip;
|
|
|
2310
|
|
|
2311 when 'B' | 'b' =>
|
|
|
2312 Pic.End_Float := Index;
|
|
|
2313 Pic.Picture.Expanded (Index) := 'b';
|
|
|
2314 Skip;
|
|
|
2315
|
|
|
2316 when '+' =>
|
|
|
2317 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
2318 Pic.End_Float := Index;
|
|
|
2319 Skip;
|
|
|
2320 Set_State (Okay); -- "++" is enough
|
|
|
2321 Floating_Plus;
|
|
|
2322 Trailing_Currency;
|
|
|
2323 return;
|
|
|
2324
|
|
|
2325 when '$' | '#' | '9' | '*' =>
|
|
|
2326 if State /= Okay then
|
|
|
2327 Pic.Floater := '!';
|
|
|
2328 Pic.Start_Float := Invalid_Position;
|
|
|
2329 Pic.End_Float := Invalid_Position;
|
|
|
2330 end if;
|
|
|
2331
|
|
|
2332 Picture;
|
|
|
2333 Set_State (Okay);
|
|
|
2334 return;
|
|
|
2335
|
|
|
2336 when 'Z' | 'z' =>
|
|
|
2337 if State = Okay then
|
|
|
2338 Set_State (Reject);
|
|
|
2339 end if;
|
|
|
2340
|
|
|
2341 -- Can't have Z and a floating sign
|
|
|
2342
|
|
|
2343 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
2344
|
|
|
2345 -- '+Z' is acceptable
|
|
|
2346
|
|
|
2347 Set_State (Okay);
|
|
|
2348
|
|
|
2349 Zero_Suppression;
|
|
|
2350 Trailing_Currency;
|
|
|
2351 Optional_RHS_Sign;
|
|
|
2352 return;
|
|
|
2353
|
|
|
2354 when '.' | 'V' | 'v' =>
|
|
|
2355 if State /= Okay then
|
|
|
2356 Pic.Floater := '!';
|
|
|
2357 Pic.Start_Float := Invalid_Position;
|
|
|
2358 Pic.End_Float := Invalid_Position;
|
|
|
2359 end if;
|
|
|
2360
|
|
|
2361 -- Don't assume that state is okay, haven't seen a digit
|
|
|
2362
|
|
|
2363 Picture;
|
|
|
2364 return;
|
|
|
2365
|
|
|
2366 when others =>
|
|
|
2367 return;
|
|
|
2368 end case;
|
|
|
2369 end loop;
|
|
|
2370 end Picture_Plus;
|
|
|
2371
|
|
|
2372 --------------------
|
|
|
2373 -- Picture_String --
|
|
|
2374 --------------------
|
|
|
2375
|
|
|
2376 procedure Picture_String is
|
|
|
2377 begin
|
|
|
2378 while Is_Insert loop
|
|
|
2379 Skip;
|
|
|
2380 end loop;
|
|
|
2381
|
|
|
2382 case Look is
|
|
|
2383 when '$' | '#' =>
|
|
|
2384 Picture;
|
|
|
2385 Optional_RHS_Sign;
|
|
|
2386
|
|
|
2387 when '+' =>
|
|
|
2388 Picture_Plus;
|
|
|
2389
|
|
|
2390 when '-' =>
|
|
|
2391 Picture_Minus;
|
|
|
2392
|
|
|
2393 when '<' =>
|
|
|
2394 Picture_Bracket;
|
|
|
2395
|
|
|
2396 when 'Z' | 'z' =>
|
|
|
2397 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
2398 Zero_Suppression;
|
|
|
2399 Trailing_Currency;
|
|
|
2400 Optional_RHS_Sign;
|
|
|
2401
|
|
|
2402 when '*' =>
|
|
|
2403 Star_Suppression;
|
|
|
2404 Trailing_Currency;
|
|
|
2405 Optional_RHS_Sign;
|
|
|
2406
|
|
|
2407 when '9' | '.' | 'V' | 'v' =>
|
|
|
2408 Number;
|
|
|
2409 Trailing_Currency;
|
|
|
2410 Optional_RHS_Sign;
|
|
|
2411
|
|
|
2412 when others =>
|
|
|
2413 raise Picture_Error;
|
|
|
2414 end case;
|
|
|
2415
|
|
|
2416 -- Blank when zero either if the PIC does not contain a '9' or if
|
|
|
2417 -- requested by the user and no '*'.
|
|
|
2418
|
|
|
2419 Pic.Blank_When_Zero :=
|
|
|
2420 (Computed_BWZ or else Pic.Blank_When_Zero)
|
|
|
2421 and then not Pic.Star_Fill;
|
|
|
2422
|
|
|
2423 -- Star fill if '*' and no '9'
|
|
|
2424
|
|
|
2425 Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ;
|
|
|
2426
|
|
|
2427 if not At_End then
|
|
|
2428 Set_State (Reject);
|
|
|
2429 end if;
|
|
|
2430 end Picture_String;
|
|
|
2431
|
|
|
2432 ---------------
|
|
|
2433 -- Set_State --
|
|
|
2434 ---------------
|
|
|
2435
|
|
|
2436 procedure Set_State (L : Legality) is
|
|
|
2437 begin
|
|
|
2438 State := L;
|
|
|
2439 end Set_State;
|
|
|
2440
|
|
|
2441 ----------
|
|
|
2442 -- Skip --
|
|
|
2443 ----------
|
|
|
2444
|
|
|
2445 procedure Skip is
|
|
|
2446 begin
|
|
|
2447 Index := Index + 1;
|
|
|
2448 end Skip;
|
|
|
2449
|
|
|
2450 ----------------------
|
|
|
2451 -- Star_Suppression --
|
|
|
2452 ----------------------
|
|
|
2453
|
|
|
2454 procedure Star_Suppression is
|
|
|
2455 begin
|
|
|
2456 Pic.Floater := '*';
|
|
|
2457 Pic.Start_Float := Index;
|
|
|
2458 Pic.End_Float := Index;
|
|
|
2459 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
2460 Set_State (Okay);
|
|
|
2461
|
|
|
2462 -- Even a single * is a valid picture
|
|
|
2463
|
|
|
2464 Pic.Star_Fill := True;
|
|
|
2465 Skip; -- Known *
|
|
|
2466
|
|
|
2467 loop
|
|
|
2468 if At_End then
|
|
|
2469 return;
|
|
|
2470 end if;
|
|
|
2471
|
|
|
2472 case Look is
|
|
|
2473 when '_' | '0' | '/' =>
|
|
|
2474 Pic.End_Float := Index;
|
|
|
2475 Skip;
|
|
|
2476
|
|
|
2477 when 'B' | 'b' =>
|
|
|
2478 Pic.End_Float := Index;
|
|
|
2479 Pic.Picture.Expanded (Index) := 'b';
|
|
|
2480 Skip;
|
|
|
2481
|
|
|
2482 when '*' =>
|
|
|
2483 Pic.End_Float := Index;
|
|
|
2484 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
2485 Set_State (Okay); Skip;
|
|
|
2486
|
|
|
2487 when '9' =>
|
|
|
2488 Set_State (Okay);
|
|
|
2489 Number_Completion;
|
|
|
2490 return;
|
|
|
2491
|
|
|
2492 when '.' | 'V' | 'v' =>
|
|
|
2493 Pic.Radix_Position := Index;
|
|
|
2494 Skip;
|
|
|
2495 Number_Fraction_Or_Star_Fill;
|
|
|
2496 return;
|
|
|
2497
|
|
|
2498 when '#' | '$' =>
|
|
|
2499 Trailing_Currency;
|
|
|
2500 Set_State (Okay);
|
|
|
2501 return;
|
|
|
2502
|
|
|
2503 when others =>
|
|
|
2504 raise Picture_Error;
|
|
|
2505 end case;
|
|
|
2506 end loop;
|
|
|
2507 end Star_Suppression;
|
|
|
2508
|
|
|
2509 ----------------------
|
|
|
2510 -- Trailing_Bracket --
|
|
|
2511 ----------------------
|
|
|
2512
|
|
|
2513 procedure Trailing_Bracket is
|
|
|
2514 begin
|
|
|
2515 if Look = '>' then
|
|
|
2516 Pic.Second_Sign := Index;
|
|
|
2517 Skip;
|
|
|
2518 else
|
|
|
2519 raise Picture_Error;
|
|
|
2520 end if;
|
|
|
2521 end Trailing_Bracket;
|
|
|
2522
|
|
|
2523 -----------------------
|
|
|
2524 -- Trailing_Currency --
|
|
|
2525 -----------------------
|
|
|
2526
|
|
|
2527 procedure Trailing_Currency is
|
|
|
2528 begin
|
|
|
2529 if At_End then
|
|
|
2530 return;
|
|
|
2531 end if;
|
|
|
2532
|
|
|
2533 if Look = '$' then
|
|
|
2534 Pic.Start_Currency := Index;
|
|
|
2535 Pic.End_Currency := Index;
|
|
|
2536 Skip;
|
|
|
2537
|
|
|
2538 else
|
|
|
2539 while not At_End and then Look = '#' loop
|
|
|
2540 if Pic.Start_Currency = Invalid_Position then
|
|
|
2541 Pic.Start_Currency := Index;
|
|
|
2542 end if;
|
|
|
2543
|
|
|
2544 Pic.End_Currency := Index;
|
|
|
2545 Skip;
|
|
|
2546 end loop;
|
|
|
2547 end if;
|
|
|
2548
|
|
|
2549 loop
|
|
|
2550 if At_End then
|
|
|
2551 return;
|
|
|
2552 end if;
|
|
|
2553
|
|
|
2554 case Look is
|
|
|
2555 when '_' | '0' | '/' =>
|
|
|
2556 Skip;
|
|
|
2557
|
|
|
2558 when 'B' | 'b' =>
|
|
|
2559 Pic.Picture.Expanded (Index) := 'b';
|
|
|
2560 Skip;
|
|
|
2561
|
|
|
2562 when others =>
|
|
|
2563 return;
|
|
|
2564 end case;
|
|
|
2565 end loop;
|
|
|
2566 end Trailing_Currency;
|
|
|
2567
|
|
|
2568 ----------------------
|
|
|
2569 -- Zero_Suppression --
|
|
|
2570 ----------------------
|
|
|
2571
|
|
|
2572 procedure Zero_Suppression is
|
|
|
2573 begin
|
|
|
2574 Pic.Floater := 'Z';
|
|
|
2575 Pic.Start_Float := Index;
|
|
|
2576 Pic.End_Float := Index;
|
|
|
2577 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
2578 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
2579
|
|
|
2580 Skip; -- Known Z
|
|
|
2581
|
|
|
2582 loop
|
|
|
2583 -- Even a single Z is a valid picture
|
|
|
2584
|
|
|
2585 if At_End then
|
|
|
2586 Set_State (Okay);
|
|
|
2587 return;
|
|
|
2588 end if;
|
|
|
2589
|
|
|
2590 case Look is
|
|
|
2591 when '_' | '0' | '/' =>
|
|
|
2592 Pic.End_Float := Index;
|
|
|
2593 Skip;
|
|
|
2594
|
|
|
2595 when 'B' | 'b' =>
|
|
|
2596 Pic.End_Float := Index;
|
|
|
2597 Pic.Picture.Expanded (Index) := 'b';
|
|
|
2598 Skip;
|
|
|
2599
|
|
|
2600 when 'Z' | 'z' =>
|
|
|
2601 Pic.Picture.Expanded (Index) := 'Z'; -- consistency
|
|
|
2602
|
|
|
2603 Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1;
|
|
|
2604 Pic.End_Float := Index;
|
|
|
2605 Set_State (Okay);
|
|
|
2606 Skip;
|
|
|
2607
|
|
|
2608 when '9' =>
|
|
|
2609 Set_State (Okay);
|
|
|
2610 Number_Completion;
|
|
|
2611 return;
|
|
|
2612
|
|
|
2613 when '.' | 'V' | 'v' =>
|
|
|
2614 Pic.Radix_Position := Index;
|
|
|
2615 Skip;
|
|
|
2616 Number_Fraction_Or_Z_Fill;
|
|
|
2617 return;
|
|
|
2618
|
|
|
2619 when '#' | '$' =>
|
|
|
2620 Trailing_Currency;
|
|
|
2621 Set_State (Okay);
|
|
|
2622 return;
|
|
|
2623
|
|
|
2624 when others =>
|
|
|
2625 return;
|
|
|
2626 end case;
|
|
|
2627 end loop;
|
|
|
2628 end Zero_Suppression;
|
|
|
2629
|
|
|
2630 -- Start of processing for Precalculate
|
|
|
2631
|
|
|
2632 begin
|
|
|
2633 Picture_String;
|
|
|
2634
|
|
|
2635 if State = Reject then
|
|
|
2636 raise Picture_Error;
|
|
|
2637 end if;
|
|
|
2638
|
|
|
2639 exception
|
|
|
2640
|
|
|
2641 when Constraint_Error =>
|
|
|
2642
|
|
|
2643 -- To deal with special cases like null strings
|
|
|
2644
|
|
|
2645 raise Picture_Error;
|
|
|
2646 end Precalculate;
|
|
|
2647
|
|
|
2648 ----------------
|
|
|
2649 -- To_Picture --
|
|
|
2650 ----------------
|
|
|
2651
|
|
|
2652 function To_Picture
|
|
|
2653 (Pic_String : String;
|
|
|
2654 Blank_When_Zero : Boolean := False) return Picture
|
|
|
2655 is
|
|
|
2656 Result : Picture;
|
|
|
2657
|
|
|
2658 begin
|
|
|
2659 declare
|
|
|
2660 Item : constant String := Expand (Pic_String);
|
|
|
2661
|
|
|
2662 begin
|
|
|
2663 Result.Contents.Picture := (Item'Length, Item);
|
|
|
2664 Result.Contents.Original_BWZ := Blank_When_Zero;
|
|
|
2665 Result.Contents.Blank_When_Zero := Blank_When_Zero;
|
|
|
2666 Precalculate (Result.Contents);
|
|
|
2667 return Result;
|
|
|
2668 end;
|
|
|
2669
|
|
|
2670 exception
|
|
|
2671 when others =>
|
|
|
2672 raise Picture_Error;
|
|
|
2673
|
|
|
2674 end To_Picture;
|
|
|
2675
|
|
|
2676 -------------
|
|
|
2677 -- To_Wide --
|
|
|
2678 -------------
|
|
|
2679
|
|
|
2680 function To_Wide (C : Character) return Wide_Character is
|
|
|
2681 begin
|
|
|
2682 return Wide_Character'Val (Character'Pos (C));
|
|
|
2683 end To_Wide;
|
|
|
2684
|
|
|
2685 -----------
|
|
|
2686 -- Valid --
|
|
|
2687 -----------
|
|
|
2688
|
|
|
2689 function Valid
|
|
|
2690 (Pic_String : String;
|
|
|
2691 Blank_When_Zero : Boolean := False) return Boolean
|
|
|
2692 is
|
|
|
2693 begin
|
|
|
2694 declare
|
|
|
2695 Expanded_Pic : constant String := Expand (Pic_String);
|
|
|
2696 -- Raises Picture_Error if Item not well-formed
|
|
|
2697
|
|
|
2698 Format_Rec : Format_Record;
|
|
|
2699
|
|
|
2700 begin
|
|
|
2701 Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic);
|
|
|
2702 Format_Rec.Blank_When_Zero := Blank_When_Zero;
|
|
|
2703 Format_Rec.Original_BWZ := Blank_When_Zero;
|
|
|
2704 Precalculate (Format_Rec);
|
|
|
2705
|
|
|
2706 -- False only if Blank_When_0 is True but the pic string has a '*'
|
|
|
2707
|
|
|
2708 return not Blank_When_Zero
|
|
|
2709 or else Strings_Fixed.Index (Expanded_Pic, "*") = 0;
|
|
|
2710 end;
|
|
|
2711
|
|
|
2712 exception
|
|
|
2713 when others => return False;
|
|
|
2714 end Valid;
|
|
|
2715
|
|
|
2716 end Ada.Wide_Text_IO.Editing;
|
