diff options
Diffstat (limited to 'gcc/ada/libgnat/a-wtfiau.adb')
| -rw-r--r-- | gcc/ada/libgnat/a-wtfiau.adb | 160 |
1 files changed, 160 insertions, 0 deletions
diff --git a/gcc/ada/libgnat/a-wtfiau.adb b/gcc/ada/libgnat/a-wtfiau.adb new file mode 100644 index 0000000..d4a1534 --- /dev/null +++ b/gcc/ada/libgnat/a-wtfiau.adb @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2020, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- <http://www.gnu.org/licenses/>. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; +with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux; + +package body Ada.Wide_Text_IO.Fixed_Aux is + + --------- + -- Get -- + --------- + + function Get + (File : File_Type; + Width : Field; + Num : Int; + Den : Int) return Int + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Int; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan (Buf, Ptr'Access, Stop, Num, Den); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get; + + ---------- + -- Gets -- + ---------- + + function Gets + (From : String; + Last : out Positive; + Num : Int; + Den : Int) return Int + is + Pos : aliased Integer; + Item : Int; + + begin + String_Skip (From, Pos); + Item := Scan (From, Pos'Access, From'Last, Num, Den); + Last := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last := Pos - 1; + raise Data_Error; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Int; + Fore : Field; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : Int; + Aft : Field; + Exp : Natural; + Num : Int; + Den : Int; + For0 : Natural; + Aft0 : Natural) + is + Buf : String (1 .. Positive'Max (Field'Last, To'Length)); + Fore : Integer; + Ptr : Natural := 0; + + begin + -- Compute Fore, allowing for the decimal dot and Aft digits + + Fore := To'Length - 1 - Field'Max (1, Aft); + + -- Allow for Exp and one more for E if exponent present + + if Exp /= 0 then + Fore := Fore - 1 - Field'Max (2, Exp); + end if; + + -- Make sure we have enough room + + if Fore < 1 + Boolean'Pos (Item < 0) then + raise Layout_Error; + end if; + + -- Do the conversion and check length of result + + Set_Image (Item, Buf, Ptr, Num, Den, For0, Aft0, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts; + +end Ada.Wide_Text_IO.Fixed_Aux; |