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