1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- S Y S T E M . I O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2018, Free Software Foundation, Inc. -- 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 System.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 -- New_Line -- 40 -------------- 41 42 procedure New_Line (Spacing : Positive := 1) is 43 begin 44 for J in 1 .. Spacing loop 45 Put (ASCII.LF); 46 end loop; 47 end New_Line; 48 49 --------- 50 -- Put -- 51 --------- 52 53 procedure Put (X : Integer) is 54 procedure Put_Int (X : Integer); 55 pragma Import (C, Put_Int, "put_int"); 56 57 procedure Put_Int_Err (X : Integer); 58 pragma Import (C, Put_Int_Err, "put_int_stderr"); 59 60 begin 61 case Current_Out is 62 when Stdout => Put_Int (X); 63 when Stderr => Put_Int_Err (X); 64 end case; 65 end Put; 66 67 procedure Put (C : Character) is 68 procedure Put_Char (C : Character); 69 pragma Import (C, Put_Char, "put_char"); 70 71 procedure Put_Char_Stderr (C : Character); 72 pragma Import (C, Put_Char_Stderr, "put_char_stderr"); 73 74 begin 75 case Current_Out is 76 when Stdout => Put_Char (C); 77 when Stderr => Put_Char_Stderr (C); 78 end case; 79 end Put; 80 81 procedure Put (S : String) is 82 begin 83 for J in S'Range loop 84 Put (S (J)); 85 end loop; 86 end Put; 87 88 -------------- 89 -- Put_Line -- 90 -------------- 91 92 procedure Put_Line (S : String) is 93 begin 94 Put (S); 95 New_Line; 96 end Put_Line; 97 98 --------------------- 99 -- Standard_Output -- 100 --------------------- 101 102 function Standard_Output return File_Type is 103 begin 104 return Stdout; 105 end Standard_Output; 106 107 -------------------- 108 -- Standard_Error -- 109 -------------------- 110 111 function Standard_Error return File_Type is 112 begin 113 return Stderr; 114 end Standard_Error; 115 116 ---------------- 117 -- Set_Output -- 118 ---------------- 119 120 procedure Set_Output (File : File_Type) is 121 begin 122 Current_Out := File; 123 end Set_Output; 124 125end System.IO; 126