1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1995-2010, AdaCore -- 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 32package body GNAT.IO is 33 34 Current_Out : File_Type := Stdout; 35 pragma Atomic (Current_Out); 36 -- Current output file (modified by Set_Output) 37 38 --------- 39 -- Get -- 40 --------- 41 42 procedure Get (X : out Integer) is 43 function Get_Int return Integer; 44 pragma Import (C, Get_Int, "get_int"); 45 begin 46 X := Get_Int; 47 end Get; 48 49 procedure Get (C : out Character) is 50 function Get_Char return Character; 51 pragma Import (C, Get_Char, "get_char"); 52 begin 53 C := Get_Char; 54 end Get; 55 56 -------------- 57 -- Get_Line -- 58 -------------- 59 60 procedure Get_Line (Item : out String; Last : out Natural) is 61 C : Character; 62 63 begin 64 for Nstore in Item'Range loop 65 Get (C); 66 67 if C = ASCII.LF then 68 Last := Nstore - 1; 69 return; 70 71 else 72 Item (Nstore) := C; 73 end if; 74 end loop; 75 76 Last := Item'Last; 77 end Get_Line; 78 79 -------------- 80 -- New_Line -- 81 -------------- 82 83 procedure New_Line (File : File_Type; Spacing : Positive := 1) is 84 begin 85 for J in 1 .. Spacing loop 86 Put (File, ASCII.LF); 87 end loop; 88 end New_Line; 89 90 procedure New_Line (Spacing : Positive := 1) is 91 begin 92 New_Line (Current_Out, Spacing); 93 end New_Line; 94 95 --------- 96 -- Put -- 97 --------- 98 99 procedure Put (X : Integer) is 100 begin 101 Put (Current_Out, X); 102 end Put; 103 104 procedure Put (File : File_Type; X : Integer) is 105 procedure Put_Int (X : Integer); 106 pragma Import (C, Put_Int, "put_int"); 107 108 procedure Put_Int_Stderr (X : Integer); 109 pragma Import (C, Put_Int_Stderr, "put_int_stderr"); 110 111 begin 112 case File is 113 when Stdout => Put_Int (X); 114 when Stderr => Put_Int_Stderr (X); 115 end case; 116 end Put; 117 118 procedure Put (C : Character) is 119 begin 120 Put (Current_Out, C); 121 end Put; 122 123 procedure Put (File : File_Type; C : Character) is 124 procedure Put_Char (C : Character); 125 pragma Import (C, Put_Char, "put_char"); 126 127 procedure Put_Char_Stderr (C : Character); 128 pragma Import (C, Put_Char_Stderr, "put_char_stderr"); 129 130 begin 131 case File is 132 when Stdout => Put_Char (C); 133 when Stderr => Put_Char_Stderr (C); 134 end case; 135 end Put; 136 137 procedure Put (S : String) is 138 begin 139 Put (Current_Out, S); 140 end Put; 141 142 procedure Put (File : File_Type; S : String) is 143 begin 144 for J in S'Range loop 145 Put (File, S (J)); 146 end loop; 147 end Put; 148 149 -------------- 150 -- Put_Line -- 151 -------------- 152 153 procedure Put_Line (S : String) is 154 begin 155 Put_Line (Current_Out, S); 156 end Put_Line; 157 158 procedure Put_Line (File : File_Type; S : String) is 159 begin 160 Put (File, S); 161 New_Line (File); 162 end Put_Line; 163 164 ---------------- 165 -- Set_Output -- 166 ---------------- 167 168 procedure Set_Output (File : File_Type) is 169 begin 170 Current_Out := File; 171 end Set_Output; 172 173 --------------------- 174 -- Standard_Output -- 175 --------------------- 176 177 function Standard_Output return File_Type is 178 begin 179 return Stdout; 180 end Standard_Output; 181 182 -------------------- 183 -- Standard_Error -- 184 -------------------- 185 186 function Standard_Error return File_Type is 187 begin 188 return Stderr; 189 end Standard_Error; 190 191end GNAT.IO; 192