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-2009, 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 => 63 Put_Int (X); 64 when Stderr => 65 Put_Int_Err (X); 66 end case; 67 end Put; 68 69 procedure Put (C : Character) is 70 procedure Put_Char (C : Character); 71 pragma Import (C, Put_Char, "put_char"); 72 73 procedure Put_Char_Stderr (C : Character); 74 pragma Import (C, Put_Char_Stderr, "put_char_stderr"); 75 76 begin 77 case Current_Out is 78 when Stdout => 79 Put_Char (C); 80 when Stderr => 81 Put_Char_Stderr (C); 82 end case; 83 end Put; 84 85 procedure Put (S : String) is 86 begin 87 for J in S'Range loop 88 Put (S (J)); 89 end loop; 90 end Put; 91 92 -------------- 93 -- Put_Line -- 94 -------------- 95 96 procedure Put_Line (S : String) is 97 begin 98 Put (S); 99 New_Line; 100 end Put_Line; 101 102 --------------------- 103 -- Standard_Output -- 104 --------------------- 105 106 function Standard_Output return File_Type is 107 begin 108 return Stdout; 109 end Standard_Output; 110 111 -------------------- 112 -- Standard_Error -- 113 -------------------- 114 115 function Standard_Error return File_Type is 116 begin 117 return Stderr; 118 end Standard_Error; 119 120 ---------------- 121 -- Set_Output -- 122 ---------------- 123 124 procedure Set_Output (File : File_Type) is 125 begin 126 Current_Out := File; 127 end Set_Output; 128 129end System.IO; 130