|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- G N A T . F O R M A T T E D _ S T R I N G --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2014-2018, Free Software Foundation, Inc. --
|
|
111
|
10 -- --
|
|
|
11 -- GNAT is free software; you can redistribute it and/or modify it under --
|
|
|
12 -- terms of the GNU General Public License as published by the Free Soft- --
|
|
|
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
|
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
|
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
|
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
|
17 -- --
|
|
|
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
|
19 -- additional permissions described in the GCC Runtime Library Exception, --
|
|
|
20 -- version 3.1, as published by the Free Software Foundation. --
|
|
|
21 -- --
|
|
|
22 -- You should have received a copy of the GNU General Public License and --
|
|
|
23 -- a copy of the GCC Runtime Library Exception along with this program; --
|
|
|
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
|
25 -- <http://www.gnu.org/licenses/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 with Ada.Characters.Handling;
|
|
|
33 with Ada.Float_Text_IO;
|
|
|
34 with Ada.Integer_Text_IO;
|
|
|
35 with Ada.Long_Float_Text_IO;
|
|
|
36 with Ada.Long_Integer_Text_IO;
|
|
|
37 with Ada.Strings.Fixed;
|
|
|
38 with Ada.Unchecked_Deallocation;
|
|
|
39
|
|
|
40 with System.Address_Image;
|
|
|
41
|
|
|
42 package body GNAT.Formatted_String is
|
|
|
43
|
|
|
44 type F_Kind is (Decimal_Int, -- %d %i
|
|
|
45 Unsigned_Decimal_Int, -- %u
|
|
|
46 Unsigned_Octal, -- %o
|
|
|
47 Unsigned_Hexadecimal_Int, -- %x
|
|
|
48 Unsigned_Hexadecimal_Int_Up, -- %X
|
|
|
49 Decimal_Float, -- %f %F
|
|
|
50 Decimal_Scientific_Float, -- %e
|
|
|
51 Decimal_Scientific_Float_Up, -- %E
|
|
|
52 Shortest_Decimal_Float, -- %g
|
|
|
53 Shortest_Decimal_Float_Up, -- %G
|
|
|
54 Char, -- %c
|
|
|
55 Str, -- %s
|
|
|
56 Pointer -- %p
|
|
|
57 );
|
|
|
58
|
|
|
59 type Sign_Kind is (Neg, Zero, Pos);
|
|
|
60
|
|
|
61 subtype Is_Number is F_Kind range Decimal_Int .. Decimal_Float;
|
|
|
62
|
|
|
63 type F_Sign is (If_Neg, Forced, Space) with Default_Value => If_Neg;
|
|
|
64
|
|
|
65 type F_Base is (None, C_Style, Ada_Style) with Default_Value => None;
|
|
|
66
|
|
|
67 Unset : constant Integer := -1;
|
|
|
68
|
|
|
69 type F_Data is record
|
|
|
70 Kind : F_Kind;
|
|
|
71 Width : Natural := 0;
|
|
|
72 Precision : Integer := Unset;
|
|
|
73 Left_Justify : Boolean := False;
|
|
|
74 Sign : F_Sign;
|
|
|
75 Base : F_Base;
|
|
|
76 Zero_Pad : Boolean := False;
|
|
|
77 Value_Needed : Natural range 0 .. 2 := 0;
|
|
|
78 end record;
|
|
|
79
|
|
|
80 procedure Next_Format
|
|
|
81 (Format : Formatted_String;
|
|
|
82 F_Spec : out F_Data;
|
|
|
83 Start : out Positive);
|
|
|
84 -- Parse the next format specifier, a format specifier has the following
|
|
|
85 -- syntax: %[flags][width][.precision][length]specifier
|
|
|
86
|
|
|
87 function Get_Formatted
|
|
|
88 (F_Spec : F_Data;
|
|
|
89 Value : String;
|
|
|
90 Len : Positive) return String;
|
|
|
91 -- Returns Value formatted given the information in F_Spec
|
|
|
92
|
|
|
93 procedure Raise_Wrong_Format (Format : Formatted_String) with No_Return;
|
|
|
94 -- Raise the Format_Error exception which information about the context
|
|
|
95
|
|
|
96 generic
|
|
|
97 type Flt is private;
|
|
|
98
|
|
|
99 with procedure Put
|
|
|
100 (To : out String;
|
|
|
101 Item : Flt;
|
|
|
102 Aft : Text_IO.Field;
|
|
|
103 Exp : Text_IO.Field);
|
|
|
104 function P_Flt_Format
|
|
|
105 (Format : Formatted_String;
|
|
|
106 Var : Flt) return Formatted_String;
|
|
|
107 -- Generic routine which handles all floating point numbers
|
|
|
108
|
|
|
109 generic
|
|
|
110 type Int is private;
|
|
|
111
|
|
|
112 with function To_Integer (Item : Int) return Integer;
|
|
|
113
|
|
|
114 with function Sign (Item : Int) return Sign_Kind;
|
|
|
115
|
|
|
116 with procedure Put
|
|
|
117 (To : out String;
|
|
|
118 Item : Int;
|
|
|
119 Base : Text_IO.Number_Base);
|
|
|
120 function P_Int_Format
|
|
|
121 (Format : Formatted_String;
|
|
|
122 Var : Int) return Formatted_String;
|
|
|
123 -- Generic routine which handles all the integer numbers
|
|
|
124
|
|
|
125 ---------
|
|
|
126 -- "+" --
|
|
|
127 ---------
|
|
|
128
|
|
|
129 function "+" (Format : String) return Formatted_String is
|
|
|
130 begin
|
|
|
131 return Formatted_String'
|
|
|
132 (Finalization.Controlled with
|
|
|
133 D => new Data'(Format'Length, 1, 1,
|
|
|
134 Null_Unbounded_String, 0, 0, (0, 0), Format));
|
|
|
135 end "+";
|
|
|
136
|
|
|
137 ---------
|
|
|
138 -- "-" --
|
|
|
139 ---------
|
|
|
140
|
|
|
141 function "-" (Format : Formatted_String) return String is
|
|
|
142 F : String renames Format.D.Format;
|
|
|
143 J : Natural renames Format.D.Index;
|
|
|
144 R : Unbounded_String := Format.D.Result;
|
|
|
145
|
|
|
146 begin
|
|
|
147 -- Make sure we get the remaining character up to the next unhandled
|
|
|
148 -- format specifier.
|
|
|
149
|
|
|
150 while (J <= F'Length and then F (J) /= '%')
|
|
|
151 or else (J < F'Length - 1 and then F (J + 1) = '%')
|
|
|
152 loop
|
|
|
153 Append (R, F (J));
|
|
|
154
|
|
|
155 -- If we have two consecutive %, skip the second one
|
|
|
156
|
|
|
157 if F (J) = '%' and then J < F'Length - 1 and then F (J + 1) = '%' then
|
|
|
158 J := J + 1;
|
|
|
159 end if;
|
|
|
160
|
|
|
161 J := J + 1;
|
|
|
162 end loop;
|
|
|
163
|
|
|
164 return To_String (R);
|
|
|
165 end "-";
|
|
|
166
|
|
|
167 ---------
|
|
|
168 -- "&" --
|
|
|
169 ---------
|
|
|
170
|
|
|
171 function "&"
|
|
|
172 (Format : Formatted_String;
|
|
|
173 Var : Character) return Formatted_String
|
|
|
174 is
|
|
|
175 F : F_Data;
|
|
|
176 Start : Positive;
|
|
|
177
|
|
|
178 begin
|
|
|
179 Next_Format (Format, F, Start);
|
|
|
180
|
|
|
181 if F.Value_Needed > 0 then
|
|
|
182 Raise_Wrong_Format (Format);
|
|
|
183 end if;
|
|
|
184
|
|
|
185 case F.Kind is
|
|
|
186 when Char =>
|
|
|
187 Append (Format.D.Result, Get_Formatted (F, String'(1 => Var), 1));
|
|
|
188 when others =>
|
|
|
189 Raise_Wrong_Format (Format);
|
|
|
190 end case;
|
|
|
191
|
|
|
192 return Format;
|
|
|
193 end "&";
|
|
|
194
|
|
|
195 function "&"
|
|
|
196 (Format : Formatted_String;
|
|
|
197 Var : String) return Formatted_String
|
|
|
198 is
|
|
|
199 F : F_Data;
|
|
|
200 Start : Positive;
|
|
|
201
|
|
|
202 begin
|
|
|
203 Next_Format (Format, F, Start);
|
|
|
204
|
|
|
205 if F.Value_Needed > 0 then
|
|
|
206 Raise_Wrong_Format (Format);
|
|
|
207 end if;
|
|
|
208
|
|
|
209 case F.Kind is
|
|
|
210 when Str =>
|
|
|
211 declare
|
|
|
212 S : constant String := Get_Formatted (F, Var, Var'Length);
|
|
|
213 begin
|
|
|
214 if F.Precision = Unset then
|
|
|
215 Append (Format.D.Result, S);
|
|
|
216 else
|
|
|
217 Append
|
|
|
218 (Format.D.Result,
|
|
|
219 S (S'First .. S'First + F.Precision - 1));
|
|
|
220 end if;
|
|
|
221 end;
|
|
|
222
|
|
|
223 when others =>
|
|
|
224 Raise_Wrong_Format (Format);
|
|
|
225 end case;
|
|
|
226
|
|
|
227 return Format;
|
|
|
228 end "&";
|
|
|
229
|
|
|
230 function "&"
|
|
|
231 (Format : Formatted_String;
|
|
|
232 Var : Boolean) return Formatted_String is
|
|
|
233 begin
|
|
|
234 return Format & Boolean'Image (Var);
|
|
|
235 end "&";
|
|
|
236
|
|
|
237 function "&"
|
|
|
238 (Format : Formatted_String;
|
|
|
239 Var : Float) return Formatted_String
|
|
|
240 is
|
|
|
241 function Float_Format is new Flt_Format (Float, Float_Text_IO.Put);
|
|
|
242 begin
|
|
|
243 return Float_Format (Format, Var);
|
|
|
244 end "&";
|
|
|
245
|
|
|
246 function "&"
|
|
|
247 (Format : Formatted_String;
|
|
|
248 Var : Long_Float) return Formatted_String
|
|
|
249 is
|
|
|
250 function Float_Format is
|
|
|
251 new Flt_Format (Long_Float, Long_Float_Text_IO.Put);
|
|
|
252 begin
|
|
|
253 return Float_Format (Format, Var);
|
|
|
254 end "&";
|
|
|
255
|
|
|
256 function "&"
|
|
|
257 (Format : Formatted_String;
|
|
|
258 Var : Duration) return Formatted_String
|
|
|
259 is
|
|
|
260 package Duration_Text_IO is new Text_IO.Fixed_IO (Duration);
|
|
|
261 function Duration_Format is
|
|
|
262 new P_Flt_Format (Duration, Duration_Text_IO.Put);
|
|
|
263 begin
|
|
|
264 return Duration_Format (Format, Var);
|
|
|
265 end "&";
|
|
|
266
|
|
|
267 function "&"
|
|
|
268 (Format : Formatted_String;
|
|
|
269 Var : Integer) return Formatted_String
|
|
|
270 is
|
|
|
271 function Integer_Format is
|
|
|
272 new Int_Format (Integer, Integer_Text_IO.Put);
|
|
|
273 begin
|
|
|
274 return Integer_Format (Format, Var);
|
|
|
275 end "&";
|
|
|
276
|
|
|
277 function "&"
|
|
|
278 (Format : Formatted_String;
|
|
|
279 Var : Long_Integer) return Formatted_String
|
|
|
280 is
|
|
|
281 function Integer_Format is
|
|
|
282 new Int_Format (Long_Integer, Long_Integer_Text_IO.Put);
|
|
|
283 begin
|
|
|
284 return Integer_Format (Format, Var);
|
|
|
285 end "&";
|
|
|
286
|
|
|
287 function "&"
|
|
|
288 (Format : Formatted_String;
|
|
|
289 Var : System.Address) return Formatted_String
|
|
|
290 is
|
|
|
291 A_Img : constant String := System.Address_Image (Var);
|
|
|
292 F : F_Data;
|
|
|
293 Start : Positive;
|
|
|
294
|
|
|
295 begin
|
|
|
296 Next_Format (Format, F, Start);
|
|
|
297
|
|
|
298 if F.Value_Needed > 0 then
|
|
|
299 Raise_Wrong_Format (Format);
|
|
|
300 end if;
|
|
|
301
|
|
|
302 case F.Kind is
|
|
|
303 when Pointer =>
|
|
|
304 Append (Format.D.Result, Get_Formatted (F, A_Img, A_Img'Length));
|
|
|
305 when others =>
|
|
|
306 Raise_Wrong_Format (Format);
|
|
|
307 end case;
|
|
|
308
|
|
|
309 return Format;
|
|
|
310 end "&";
|
|
|
311
|
|
|
312 ------------
|
|
|
313 -- Adjust --
|
|
|
314 ------------
|
|
|
315
|
|
|
316 overriding procedure Adjust (F : in out Formatted_String) is
|
|
|
317 begin
|
|
|
318 F.D.Ref_Count := F.D.Ref_Count + 1;
|
|
|
319 end Adjust;
|
|
|
320
|
|
|
321 --------------------
|
|
|
322 -- Decimal_Format --
|
|
|
323 --------------------
|
|
|
324
|
|
|
325 function Decimal_Format
|
|
|
326 (Format : Formatted_String;
|
|
|
327 Var : Flt) return Formatted_String
|
|
|
328 is
|
|
|
329 function Flt_Format is new P_Flt_Format (Flt, Put);
|
|
|
330 begin
|
|
|
331 return Flt_Format (Format, Var);
|
|
|
332 end Decimal_Format;
|
|
|
333
|
|
|
334 -----------------
|
|
|
335 -- Enum_Format --
|
|
|
336 -----------------
|
|
|
337
|
|
|
338 function Enum_Format
|
|
|
339 (Format : Formatted_String;
|
|
|
340 Var : Enum) return Formatted_String is
|
|
|
341 begin
|
|
|
342 return Format & Enum'Image (Var);
|
|
|
343 end Enum_Format;
|
|
|
344
|
|
|
345 --------------
|
|
|
346 -- Finalize --
|
|
|
347 --------------
|
|
|
348
|
|
|
349 overriding procedure Finalize (F : in out Formatted_String) is
|
|
|
350 procedure Unchecked_Free is
|
|
|
351 new Unchecked_Deallocation (Data, Data_Access);
|
|
|
352
|
|
|
353 D : Data_Access := F.D;
|
|
|
354
|
|
|
355 begin
|
|
|
356 F.D := null;
|
|
|
357
|
|
|
358 D.Ref_Count := D.Ref_Count - 1;
|
|
|
359
|
|
|
360 if D.Ref_Count = 0 then
|
|
|
361 Unchecked_Free (D);
|
|
|
362 end if;
|
|
|
363 end Finalize;
|
|
|
364
|
|
|
365 ------------------
|
|
|
366 -- Fixed_Format --
|
|
|
367 ------------------
|
|
|
368
|
|
|
369 function Fixed_Format
|
|
|
370 (Format : Formatted_String;
|
|
|
371 Var : Flt) return Formatted_String
|
|
|
372 is
|
|
|
373 function Flt_Format is new P_Flt_Format (Flt, Put);
|
|
|
374 begin
|
|
|
375 return Flt_Format (Format, Var);
|
|
|
376 end Fixed_Format;
|
|
|
377
|
|
|
378 ----------------
|
|
|
379 -- Flt_Format --
|
|
|
380 ----------------
|
|
|
381
|
|
|
382 function Flt_Format
|
|
|
383 (Format : Formatted_String;
|
|
|
384 Var : Flt) return Formatted_String
|
|
|
385 is
|
|
|
386 function Flt_Format is new P_Flt_Format (Flt, Put);
|
|
|
387 begin
|
|
|
388 return Flt_Format (Format, Var);
|
|
|
389 end Flt_Format;
|
|
|
390
|
|
|
391 -------------------
|
|
|
392 -- Get_Formatted --
|
|
|
393 -------------------
|
|
|
394
|
|
|
395 function Get_Formatted
|
|
|
396 (F_Spec : F_Data;
|
|
|
397 Value : String;
|
|
|
398 Len : Positive) return String
|
|
|
399 is
|
|
|
400 use Ada.Strings.Fixed;
|
|
|
401
|
|
|
402 Res : Unbounded_String;
|
|
|
403 S : Positive := Value'First;
|
|
|
404
|
|
|
405 begin
|
|
|
406 -- Handle the flags
|
|
|
407
|
|
|
408 if F_Spec.Kind in Is_Number then
|
|
|
409 if F_Spec.Sign = Forced and then Value (Value'First) /= '-' then
|
|
|
410 Append (Res, "+");
|
|
|
411 elsif F_Spec.Sign = Space and then Value (Value'First) /= '-' then
|
|
|
412 Append (Res, " ");
|
|
|
413 end if;
|
|
|
414
|
|
|
415 if Value (Value'First) = '-' then
|
|
|
416 Append (Res, "-");
|
|
|
417 S := S + 1;
|
|
|
418 end if;
|
|
|
419 end if;
|
|
|
420
|
|
|
421 -- Zero padding if required and possible
|
|
|
422
|
|
|
423 if F_Spec.Left_Justify = False
|
|
|
424 and then F_Spec.Zero_Pad
|
|
|
425 and then F_Spec.Width > Len + Value'First - S
|
|
|
426 then
|
|
|
427 Append (Res, String'((F_Spec.Width - Len + Value'First - S) * '0'));
|
|
|
428 end if;
|
|
|
429
|
|
|
430 -- Add the value now
|
|
|
431
|
|
|
432 Append (Res, Value (S .. Value'Last));
|
|
|
433
|
|
|
434 declare
|
|
|
435 R : String (1 .. Natural'Max (Natural'Max (F_Spec.Width, Len),
|
|
|
436 Length (Res))) := (others => ' ');
|
|
|
437 begin
|
|
|
438 if F_Spec.Left_Justify then
|
|
|
439 R (1 .. Length (Res)) := To_String (Res);
|
|
|
440 else
|
|
|
441 R (R'Last - Length (Res) + 1 .. R'Last) := To_String (Res);
|
|
|
442 end if;
|
|
|
443
|
|
|
444 return R;
|
|
|
445 end;
|
|
|
446 end Get_Formatted;
|
|
|
447
|
|
|
448 ----------------
|
|
|
449 -- Int_Format --
|
|
|
450 ----------------
|
|
|
451
|
|
|
452 function Int_Format
|
|
|
453 (Format : Formatted_String;
|
|
|
454 Var : Int) return Formatted_String
|
|
|
455 is
|
|
|
456 function Sign (Var : Int) return Sign_Kind is
|
|
|
457 (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
|
|
|
458
|
|
|
459 function To_Integer (Var : Int) return Integer is
|
|
|
460 (Integer (Var));
|
|
|
461
|
|
|
462 function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
|
|
|
463
|
|
|
464 begin
|
|
|
465 return Int_Format (Format, Var);
|
|
|
466 end Int_Format;
|
|
|
467
|
|
|
468 ----------------
|
|
|
469 -- Mod_Format --
|
|
|
470 ----------------
|
|
|
471
|
|
|
472 function Mod_Format
|
|
|
473 (Format : Formatted_String;
|
|
|
474 Var : Int) return Formatted_String
|
|
|
475 is
|
|
|
476 function Sign (Var : Int) return Sign_Kind is
|
|
|
477 (if Var < 0 then Neg elsif Var = 0 then Zero else Pos);
|
|
|
478
|
|
|
479 function To_Integer (Var : Int) return Integer is
|
|
|
480 (Integer (Var));
|
|
|
481
|
|
|
482 function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put);
|
|
|
483
|
|
|
484 begin
|
|
|
485 return Int_Format (Format, Var);
|
|
|
486 end Mod_Format;
|
|
|
487
|
|
|
488 -----------------
|
|
|
489 -- Next_Format --
|
|
|
490 -----------------
|
|
|
491
|
|
|
492 procedure Next_Format
|
|
|
493 (Format : Formatted_String;
|
|
|
494 F_Spec : out F_Data;
|
|
|
495 Start : out Positive)
|
|
|
496 is
|
|
|
497 F : String renames Format.D.Format;
|
|
|
498 J : Natural renames Format.D.Index;
|
|
|
499 S : Natural;
|
|
|
500 Width_From_Var : Boolean := False;
|
|
|
501
|
|
|
502 begin
|
|
|
503 Format.D.Current := Format.D.Current + 1;
|
|
|
504 F_Spec.Value_Needed := 0;
|
|
|
505
|
|
|
506 -- Got to next %
|
|
|
507
|
|
|
508 while (J <= F'Last and then F (J) /= '%')
|
|
|
509 or else (J < F'Last - 1 and then F (J + 1) = '%')
|
|
|
510 loop
|
|
|
511 Append (Format.D.Result, F (J));
|
|
|
512
|
|
|
513 -- If we have two consecutive %, skip the second one
|
|
|
514
|
|
|
515 if F (J) = '%' and then J < F'Last - 1 and then F (J + 1) = '%' then
|
|
|
516 J := J + 1;
|
|
|
517 end if;
|
|
|
518
|
|
|
519 J := J + 1;
|
|
|
520 end loop;
|
|
|
521
|
|
|
522 if F (J) /= '%' or else J = F'Last then
|
|
|
523 raise Format_Error with "no format specifier found for parameter"
|
|
|
524 & Positive'Image (Format.D.Current);
|
|
|
525 end if;
|
|
|
526
|
|
|
527 Start := J;
|
|
|
528
|
|
|
529 J := J + 1;
|
|
|
530
|
|
|
531 -- Check for any flags
|
|
|
532
|
|
|
533 Flags_Check : while J < F'Last loop
|
|
|
534 if F (J) = '-' then
|
|
|
535 F_Spec.Left_Justify := True;
|
|
|
536 elsif F (J) = '+' then
|
|
|
537 F_Spec.Sign := Forced;
|
|
|
538 elsif F (J) = ' ' then
|
|
|
539 F_Spec.Sign := Space;
|
|
|
540 elsif F (J) = '#' then
|
|
|
541 F_Spec.Base := C_Style;
|
|
|
542 elsif F (J) = '~' then
|
|
|
543 F_Spec.Base := Ada_Style;
|
|
|
544 elsif F (J) = '0' then
|
|
|
545 F_Spec.Zero_Pad := True;
|
|
|
546 else
|
|
|
547 exit Flags_Check;
|
|
|
548 end if;
|
|
|
549
|
|
|
550 J := J + 1;
|
|
|
551 end loop Flags_Check;
|
|
|
552
|
|
|
553 -- Check width if any
|
|
|
554
|
|
|
555 if F (J) in '0' .. '9' then
|
|
|
556
|
|
|
557 -- We have a width parameter
|
|
|
558
|
|
|
559 S := J;
|
|
|
560
|
|
|
561 while J < F'Last and then F (J + 1) in '0' .. '9' loop
|
|
|
562 J := J + 1;
|
|
|
563 end loop;
|
|
|
564
|
|
|
565 F_Spec.Width := Natural'Value (F (S .. J));
|
|
|
566
|
|
|
567 J := J + 1;
|
|
|
568
|
|
|
569 elsif F (J) = '*' then
|
|
|
570
|
|
|
571 -- The width will be taken from the integer parameter
|
|
|
572
|
|
|
573 F_Spec.Value_Needed := 1;
|
|
|
574 Width_From_Var := True;
|
|
|
575
|
|
|
576 J := J + 1;
|
|
|
577 end if;
|
|
|
578
|
|
|
579 if F (J) = '.' then
|
|
|
580
|
|
|
581 -- We have a precision parameter
|
|
|
582
|
|
|
583 J := J + 1;
|
|
|
584
|
|
|
585 if F (J) in '0' .. '9' then
|
|
|
586 S := J;
|
|
|
587
|
|
|
588 while J < F'Length and then F (J + 1) in '0' .. '9' loop
|
|
|
589 J := J + 1;
|
|
|
590 end loop;
|
|
|
591
|
|
|
592 if F (J) = '.' then
|
|
|
593
|
|
|
594 -- No precision, 0 is assumed
|
|
|
595
|
|
|
596 F_Spec.Precision := 0;
|
|
|
597
|
|
|
598 else
|
|
|
599 F_Spec.Precision := Natural'Value (F (S .. J));
|
|
|
600 end if;
|
|
|
601
|
|
|
602 J := J + 1;
|
|
|
603
|
|
|
604 elsif F (J) = '*' then
|
|
|
605
|
|
|
606 -- The prevision will be taken from the integer parameter
|
|
|
607
|
|
|
608 F_Spec.Value_Needed := F_Spec.Value_Needed + 1;
|
|
|
609 J := J + 1;
|
|
|
610 end if;
|
|
|
611 end if;
|
|
|
612
|
|
|
613 -- Skip the length specifier, this is not needed for this implementation
|
|
|
614 -- but yet for compatibility reason it is handled.
|
|
|
615
|
|
|
616 Length_Check :
|
|
|
617 while J <= F'Last
|
|
|
618 and then F (J) in 'h' | 'l' | 'j' | 'z' | 't' | 'L'
|
|
|
619 loop
|
|
|
620 J := J + 1;
|
|
|
621 end loop Length_Check;
|
|
|
622
|
|
|
623 if J > F'Last then
|
|
|
624 Raise_Wrong_Format (Format);
|
|
|
625 end if;
|
|
|
626
|
|
|
627 -- Read next character which should be the expected type
|
|
|
628
|
|
|
629 case F (J) is
|
|
|
630 when 'c' => F_Spec.Kind := Char;
|
|
|
631 when 's' => F_Spec.Kind := Str;
|
|
|
632 when 'd' | 'i' => F_Spec.Kind := Decimal_Int;
|
|
|
633 when 'u' => F_Spec.Kind := Unsigned_Decimal_Int;
|
|
|
634 when 'f' | 'F' => F_Spec.Kind := Decimal_Float;
|
|
|
635 when 'e' => F_Spec.Kind := Decimal_Scientific_Float;
|
|
|
636 when 'E' => F_Spec.Kind := Decimal_Scientific_Float_Up;
|
|
|
637 when 'g' => F_Spec.Kind := Shortest_Decimal_Float;
|
|
|
638 when 'G' => F_Spec.Kind := Shortest_Decimal_Float_Up;
|
|
|
639 when 'o' => F_Spec.Kind := Unsigned_Octal;
|
|
|
640 when 'x' => F_Spec.Kind := Unsigned_Hexadecimal_Int;
|
|
|
641 when 'X' => F_Spec.Kind := Unsigned_Hexadecimal_Int_Up;
|
|
|
642
|
|
|
643 when others =>
|
|
|
644 raise Format_Error with "unknown format specified for parameter"
|
|
|
645 & Positive'Image (Format.D.Current);
|
|
|
646 end case;
|
|
|
647
|
|
|
648 J := J + 1;
|
|
|
649
|
|
|
650 if F_Spec.Value_Needed > 0
|
|
|
651 and then F_Spec.Value_Needed = Format.D.Stored_Value
|
|
|
652 then
|
|
|
653 if F_Spec.Value_Needed = 1 then
|
|
|
654 if Width_From_Var then
|
|
|
655 F_Spec.Width := Format.D.Stack (1);
|
|
|
656 else
|
|
|
657 F_Spec.Precision := Format.D.Stack (1);
|
|
|
658 end if;
|
|
|
659
|
|
|
660 else
|
|
|
661 F_Spec.Width := Format.D.Stack (1);
|
|
|
662 F_Spec.Precision := Format.D.Stack (2);
|
|
|
663 end if;
|
|
|
664 end if;
|
|
|
665 end Next_Format;
|
|
|
666
|
|
|
667 ------------------
|
|
|
668 -- P_Flt_Format --
|
|
|
669 ------------------
|
|
|
670
|
|
|
671 function P_Flt_Format
|
|
|
672 (Format : Formatted_String;
|
|
|
673 Var : Flt) return Formatted_String
|
|
|
674 is
|
|
|
675 F : F_Data;
|
|
|
676 Buffer : String (1 .. 50);
|
|
|
677 S, E : Positive := 1;
|
|
|
678 Start : Positive;
|
|
|
679 Aft : Text_IO.Field;
|
|
|
680
|
|
|
681 begin
|
|
|
682 Next_Format (Format, F, Start);
|
|
|
683
|
|
|
684 if F.Value_Needed > 0 then
|
|
|
685 Raise_Wrong_Format (Format);
|
|
|
686 end if;
|
|
|
687
|
|
|
688 if F.Precision = Unset then
|
|
|
689 Aft := 6;
|
|
|
690 else
|
|
|
691 Aft := F.Precision;
|
|
|
692 end if;
|
|
|
693
|
|
|
694 case F.Kind is
|
|
|
695 when Decimal_Float =>
|
|
|
696
|
|
|
697 Put (Buffer, Var, Aft, Exp => 0);
|
|
|
698 S := Strings.Fixed.Index_Non_Blank (Buffer);
|
|
|
699 E := Buffer'Last;
|
|
|
700
|
|
|
701 when Decimal_Scientific_Float
|
|
|
702 | Decimal_Scientific_Float_Up
|
|
|
703 =>
|
|
|
704 Put (Buffer, Var, Aft, Exp => 3);
|
|
|
705 S := Strings.Fixed.Index_Non_Blank (Buffer);
|
|
|
706 E := Buffer'Last;
|
|
|
707
|
|
|
708 if F.Kind = Decimal_Scientific_Float then
|
|
|
709 Buffer (S .. E) :=
|
|
|
710 Characters.Handling.To_Lower (Buffer (S .. E));
|
|
|
711 end if;
|
|
|
712
|
|
|
713 when Shortest_Decimal_Float
|
|
|
714 | Shortest_Decimal_Float_Up
|
|
|
715 =>
|
|
|
716 -- Without exponent
|
|
|
717
|
|
|
718 Put (Buffer, Var, Aft, Exp => 0);
|
|
|
719 S := Strings.Fixed.Index_Non_Blank (Buffer);
|
|
|
720 E := Buffer'Last;
|
|
|
721
|
|
|
722 -- Check with exponent
|
|
|
723
|
|
|
724 declare
|
|
|
725 Buffer2 : String (1 .. 50);
|
|
|
726 S2, E2 : Positive;
|
|
|
727
|
|
|
728 begin
|
|
|
729 Put (Buffer2, Var, Aft, Exp => 3);
|
|
|
730 S2 := Strings.Fixed.Index_Non_Blank (Buffer2);
|
|
|
731 E2 := Buffer2'Last;
|
|
|
732
|
|
|
733 -- If with exponent it is shorter, use it
|
|
|
734
|
|
|
735 if (E2 - S2) < (E - S) then
|
|
|
736 Buffer := Buffer2;
|
|
|
737 S := S2;
|
|
|
738 E := E2;
|
|
|
739 end if;
|
|
|
740 end;
|
|
|
741
|
|
|
742 if F.Kind = Shortest_Decimal_Float then
|
|
|
743 Buffer (S .. E) :=
|
|
|
744 Characters.Handling.To_Lower (Buffer (S .. E));
|
|
|
745 end if;
|
|
|
746
|
|
|
747 when others =>
|
|
|
748 Raise_Wrong_Format (Format);
|
|
|
749 end case;
|
|
|
750
|
|
|
751 Append (Format.D.Result,
|
|
|
752 Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length));
|
|
|
753
|
|
|
754 return Format;
|
|
|
755 end P_Flt_Format;
|
|
|
756
|
|
|
757 ------------------
|
|
|
758 -- P_Int_Format --
|
|
|
759 ------------------
|
|
|
760
|
|
|
761 function P_Int_Format
|
|
|
762 (Format : Formatted_String;
|
|
|
763 Var : Int) return Formatted_String
|
|
|
764 is
|
|
|
765 function Handle_Precision return Boolean;
|
|
|
766 -- Return True if nothing else to do
|
|
|
767
|
|
|
768 F : F_Data;
|
|
|
769 Buffer : String (1 .. 50);
|
|
|
770 S, E : Positive := 1;
|
|
|
771 Len : Natural := 0;
|
|
|
772 Start : Positive;
|
|
|
773
|
|
|
774 ----------------------
|
|
|
775 -- Handle_Precision --
|
|
|
776 ----------------------
|
|
|
777
|
|
|
778 function Handle_Precision return Boolean is
|
|
|
779 begin
|
|
|
780 if F.Precision = 0 and then Sign (Var) = Zero then
|
|
|
781 return True;
|
|
|
782
|
|
|
783 elsif F.Precision = Natural'Last then
|
|
|
784 null;
|
|
|
785
|
|
|
786 elsif F.Precision > E - S + 1 then
|
|
|
787 Len := F.Precision - (E - S + 1);
|
|
|
788 Buffer (S - Len .. S - 1) := (others => '0');
|
|
|
789 S := S - Len;
|
|
|
790 end if;
|
|
|
791
|
|
|
792 return False;
|
|
|
793 end Handle_Precision;
|
|
|
794
|
|
|
795 -- Start of processing for P_Int_Format
|
|
|
796
|
|
|
797 begin
|
|
|
798 Next_Format (Format, F, Start);
|
|
|
799
|
|
|
800 if Format.D.Stored_Value < F.Value_Needed then
|
|
|
801 Format.D.Stored_Value := Format.D.Stored_Value + 1;
|
|
|
802 Format.D.Stack (Format.D.Stored_Value) := To_Integer (Var);
|
|
|
803 Format.D.Index := Start;
|
|
|
804 return Format;
|
|
|
805 end if;
|
|
|
806
|
|
|
807 case F.Kind is
|
|
|
808 when Unsigned_Octal =>
|
|
|
809 if Sign (Var) = Neg then
|
|
|
810 Raise_Wrong_Format (Format);
|
|
|
811 end if;
|
|
|
812
|
|
|
813 Put (Buffer, Var, Base => 8);
|
|
|
814 S := Strings.Fixed.Index (Buffer, "8#") + 2;
|
|
|
815 E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
|
|
|
816
|
|
|
817 if Handle_Precision then
|
|
|
818 return Format;
|
|
|
819 end if;
|
|
|
820
|
|
|
821 case F.Base is
|
|
|
822 when None => null;
|
|
|
823 when C_Style => Len := 1;
|
|
|
824 when Ada_Style => Len := 3;
|
|
|
825 end case;
|
|
|
826
|
|
|
827 when Unsigned_Hexadecimal_Int =>
|
|
|
828 if Sign (Var) = Neg then
|
|
|
829 Raise_Wrong_Format (Format);
|
|
|
830 end if;
|
|
|
831
|
|
|
832 Put (Buffer, Var, Base => 16);
|
|
|
833 S := Strings.Fixed.Index (Buffer, "16#") + 3;
|
|
|
834 E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
|
|
|
835 Buffer (S .. E) := Characters.Handling.To_Lower (Buffer (S .. E));
|
|
|
836
|
|
|
837 if Handle_Precision then
|
|
|
838 return Format;
|
|
|
839 end if;
|
|
|
840
|
|
|
841 case F.Base is
|
|
|
842 when None => null;
|
|
|
843 when C_Style => Len := 2;
|
|
|
844 when Ada_Style => Len := 4;
|
|
|
845 end case;
|
|
|
846
|
|
|
847 when Unsigned_Hexadecimal_Int_Up =>
|
|
|
848 if Sign (Var) = Neg then
|
|
|
849 Raise_Wrong_Format (Format);
|
|
|
850 end if;
|
|
|
851
|
|
|
852 Put (Buffer, Var, Base => 16);
|
|
|
853 S := Strings.Fixed.Index (Buffer, "16#") + 3;
|
|
|
854 E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1;
|
|
|
855
|
|
|
856 if Handle_Precision then
|
|
|
857 return Format;
|
|
|
858 end if;
|
|
|
859
|
|
|
860 case F.Base is
|
|
|
861 when None => null;
|
|
|
862 when C_Style => Len := 2;
|
|
|
863 when Ada_Style => Len := 4;
|
|
|
864 end case;
|
|
|
865
|
|
|
866 when Unsigned_Decimal_Int =>
|
|
|
867 if Sign (Var) = Neg then
|
|
|
868 Raise_Wrong_Format (Format);
|
|
|
869 end if;
|
|
|
870
|
|
|
871 Put (Buffer, Var, Base => 10);
|
|
|
872 S := Strings.Fixed.Index_Non_Blank (Buffer);
|
|
|
873 E := Buffer'Last;
|
|
|
874
|
|
|
875 if Handle_Precision then
|
|
|
876 return Format;
|
|
|
877 end if;
|
|
|
878
|
|
|
879 when Decimal_Int =>
|
|
|
880 Put (Buffer, Var, Base => 10);
|
|
|
881 S := Strings.Fixed.Index_Non_Blank (Buffer);
|
|
|
882 E := Buffer'Last;
|
|
|
883
|
|
|
884 if Handle_Precision then
|
|
|
885 return Format;
|
|
|
886 end if;
|
|
|
887
|
|
|
888 when Char =>
|
|
|
889 S := Buffer'First;
|
|
|
890 E := Buffer'First;
|
|
|
891 Buffer (S) := Character'Val (To_Integer (Var));
|
|
|
892
|
|
|
893 if Handle_Precision then
|
|
|
894 return Format;
|
|
|
895 end if;
|
|
|
896
|
|
|
897 when others =>
|
|
|
898 Raise_Wrong_Format (Format);
|
|
|
899 end case;
|
|
|
900
|
|
|
901 -- Then add base if needed
|
|
|
902
|
|
|
903 declare
|
|
|
904 N : String := Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len);
|
|
|
905 P : constant Positive :=
|
|
|
906 (if F.Left_Justify
|
|
|
907 then N'First
|
|
|
908 else Natural'Max (Strings.Fixed.Index_Non_Blank (N) - 1,
|
|
|
909 N'First));
|
|
|
910 begin
|
|
|
911 case F.Base is
|
|
|
912 when None =>
|
|
|
913 null;
|
|
|
914
|
|
|
915 when C_Style =>
|
|
|
916 case F.Kind is
|
|
|
917 when Unsigned_Octal =>
|
|
|
918 N (P) := 'O';
|
|
|
919
|
|
|
920 when Unsigned_Hexadecimal_Int =>
|
|
|
921 if F.Left_Justify then
|
|
|
922 N (P .. P + 1) := "Ox";
|
|
|
923 else
|
|
|
924 N (P - 1 .. P) := "0x";
|
|
|
925 end if;
|
|
|
926
|
|
|
927 when Unsigned_Hexadecimal_Int_Up =>
|
|
|
928 if F.Left_Justify then
|
|
|
929 N (P .. P + 1) := "OX";
|
|
|
930 else
|
|
|
931 N (P - 1 .. P) := "0X";
|
|
|
932 end if;
|
|
|
933
|
|
|
934 when others =>
|
|
|
935 null;
|
|
|
936 end case;
|
|
|
937
|
|
|
938 when Ada_Style =>
|
|
|
939 case F.Kind is
|
|
|
940 when Unsigned_Octal =>
|
|
|
941 if F.Left_Justify then
|
|
|
942 N (N'First + 2 .. N'Last) := N (N'First .. N'Last - 2);
|
|
|
943 else
|
|
|
944 N (P .. N'Last - 1) := N (P + 1 .. N'Last);
|
|
|
945 end if;
|
|
|
946
|
|
|
947 N (N'First .. N'First + 1) := "8#";
|
|
|
948 N (N'Last) := '#';
|
|
|
949
|
|
|
950 when Unsigned_Hexadecimal_Int
|
|
|
951 | Unsigned_Hexadecimal_Int_Up
|
|
|
952 =>
|
|
|
953 if F.Left_Justify then
|
|
|
954 N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3);
|
|
|
955 else
|
|
|
956 N (P .. N'Last - 1) := N (P + 1 .. N'Last);
|
|
|
957 end if;
|
|
|
958
|
|
|
959 N (N'First .. N'First + 2) := "16#";
|
|
|
960 N (N'Last) := '#';
|
|
|
961
|
|
|
962 when others =>
|
|
|
963 null;
|
|
|
964 end case;
|
|
|
965 end case;
|
|
|
966
|
|
|
967 Append (Format.D.Result, N);
|
|
|
968 end;
|
|
|
969
|
|
|
970 return Format;
|
|
|
971 end P_Int_Format;
|
|
|
972
|
|
|
973 ------------------------
|
|
|
974 -- Raise_Wrong_Format --
|
|
|
975 ------------------------
|
|
|
976
|
|
|
977 procedure Raise_Wrong_Format (Format : Formatted_String) is
|
|
|
978 begin
|
|
|
979 raise Format_Error with
|
|
|
980 "wrong format specified for parameter"
|
|
|
981 & Positive'Image (Format.D.Current);
|
|
|
982 end Raise_Wrong_Format;
|
|
|
983
|
|
|
984 end GNAT.Formatted_String;
|
