File : g-io-vxworks-ppc-cert.adb
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-2015, 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 -- --
19 -- --
20 -- --
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 -- This version is for the Level A runtime. It eliminates the need
33 -- for cio.c and related headers.
34
35 with Interfaces.C;
36 with System;
37
38 package body GNAT.IO is
39 use Interfaces.C;
40
41 Stdin_ID : constant int := 0;
42 Stdout_ID : constant int := 1;
43 Stderr_ID : constant int := 2;
44
45 Current_Out : File_Type := Stdout;
46 pragma Atomic (Current_Out);
47 -- Current output file (modified by Set_Output)
48
49 function Get_File_Descriptor (File : File_Type) return int;
50 -- Return the VxWorks global io file descriptor corresponding to File
51
52 -------------------------
53 -- Get_File_Descriptor --
54 -------------------------
55
56 function Get_File_Descriptor (File : File_Type) return int is
57 begin
58 case File is
59 when Stdout =>
60 return Stdout_ID;
61 when Stderr =>
62 return Stderr_ID;
63 end case;
64 end Get_File_Descriptor;
65
66 ---------
67 -- Get --
68 ---------
69
70 procedure Get (X : out Integer) is
71 C : Character;
72 Sign : Integer := +1;
73 No_Digit_Seen : Boolean := True;
74
75 begin
76 X := 0;
77 loop
78 Get (C);
79
80 -- Handle initial minus sign
81
82 if No_Digit_Seen
83 and then C = '-'
84 then
85 Sign := -1;
86
87 -- Ignore initial white space
88
89 elsif No_Digit_Seen
90 and then (C = ' ' or else C in ASCII.HT .. ASCII.CR)
91 then
92 null;
93
94 -- Otherwise accumulate digit, we accumulate the negative of the
95 -- absolute value, to properly deal with the largest neg number.
96
97 elsif C in '0' .. '9' then
98 X := X * 10 - (Character'Pos (C) - Character'Pos ('0'));
99 No_Digit_Seen := False;
100
101 else
102 exit;
103 end if;
104 end loop;
105
106 X := (-Sign) * X;
107 end Get;
108
109 procedure Get (C : out Character) is
110 function read
111 (fd : Interfaces.C.int;
112 buffer : System.Address;
113 maxbytes : Interfaces.C.size_t) return Interfaces.C.int;
114 pragma Import (C, read, "read");
115
116 Result : Interfaces.C.int;
117 Buffer : Interfaces.C.char;
118
119 begin
120 Result := read (Stdin_ID, Buffer'Address, 1);
121 pragma Assert (Result = 0);
122 C := Character (Buffer);
123 end Get;
124
125 --------------
126 -- Get_Line --
127 --------------
128
129 procedure Get_Line (Item : out String; Last : out Natural) is
130 C : Character;
131
132 begin
133 for Nstore in Item'Range loop
134 Get (C);
135
136 if C = ASCII.LF then
137 Last := Nstore - 1;
138 return;
139 else
140 Item (Nstore) := C;
141 end if;
142 end loop;
143
144 Last := Item'Last;
145 end Get_Line;
146
147 --------------
148 -- New_Line --
149 --------------
150
151 procedure New_Line (File : File_Type; Spacing : Positive := 1) is
152 begin
153 for J in 1 .. Spacing loop
154 Put (File, ASCII.LF);
155 end loop;
156 end New_Line;
157
158 procedure New_Line (Spacing : Positive := 1) is
159 begin
160 New_Line (Current_Out, Spacing);
161 end New_Line;
162
163 ---------
164 -- Put --
165 ---------
166
167 procedure Put (X : Integer) is
168 begin
169 Put (Current_Out, X);
170 end Put;
171
172 procedure Put (File : File_Type; X : Integer) is
173
174 procedure fdprintf
175 (File : Interfaces.C.int;
176 Format : String;
177 Value : Interfaces.C.int);
178 pragma Import (C, fdprintf, "fdprintf");
179
180 begin
181 fdprintf (Get_File_Descriptor (File), "%d" & ASCII.NUL, int (X));
182 end Put;
183
184 procedure Put (C : Character) is
185 begin
186 Put (Current_Out, C);
187 end Put;
188
189 procedure Put (File : File_Type; C : Character) is
190
191 procedure fdprintf
192 (File : Interfaces.C.int;
193 Format : String;
194 Value : Character);
195 pragma Import (C, fdprintf, "fdprintf");
196
197 begin
198 fdprintf (Get_File_Descriptor (File), "%c" & ASCII.NUL, C);
199 end Put;
200
201 procedure Put (S : String) is
202 begin
203 Put (Current_Out, S);
204 end Put;
205
206 procedure Put (File : File_Type; S : String) is
207 procedure fdprintf
208 (File : Interfaces.C.int;
209 Format : String;
210 Value : String);
211 pragma Import (C, fdprintf, "fdprintf");
212
213 Buffer : String (1 .. S'Length + 1);
214
215 begin
216 Buffer (1 .. S'Length) := S;
217 Buffer (Buffer'Last) := ASCII.NUL;
218 fdprintf (Get_File_Descriptor (File), "%s" & ASCII.NUL, Buffer);
219 end Put;
220
221 --------------
222 -- Put_Line --
223 --------------
224
225 procedure Put_Line (S : String) is
226 begin
227 Put_Line (Current_Out, S);
228 end Put_Line;
229
230 procedure Put_Line (File : File_Type; S : String) is
231 begin
232 Put (File, S);
233 New_Line (File);
234 end Put_Line;
235
236 ----------------
237 -- Set_Output --
238 ----------------
239
240 procedure Set_Output (File : File_Type) is
241 begin
242 Current_Out := File;
243 end Set_Output;
244
245 ---------------------
246 -- Standard_Output --
247 ---------------------
248
249 function Standard_Output return File_Type is
250 begin
251 return Stdout;
252 end Standard_Output;
253
254 --------------------
255 -- Standard_Error --
256 --------------------
257
258 function Standard_Error return File_Type is
259 begin
260 return Stderr;
261 end Standard_Error;
262
263 end GNAT.IO;