annotate gcc/ada/libgnat/a-textio.adb @ 145:1830386684a0

gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents 84e7813d76e9
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 ------------------------------------------------------------------------------
kono
parents:
diff changeset
2 -- --
kono
parents:
diff changeset
3 -- GNAT RUN-TIME COMPONENTS --
kono
parents:
diff changeset
4 -- --
kono
parents:
diff changeset
5 -- A D A . T E X T _ I O --
kono
parents:
diff changeset
6 -- --
kono
parents:
diff changeset
7 -- B o d y --
kono
parents:
diff changeset
8 -- --
145
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
111
kono
parents:
diff changeset
10 -- --
kono
parents:
diff changeset
11 -- GNAT is free software; you can redistribute it and/or modify it under --
kono
parents:
diff changeset
12 -- terms of the GNU General Public License as published by the Free Soft- --
kono
parents:
diff changeset
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
kono
parents:
diff changeset
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
kono
parents:
diff changeset
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
kono
parents:
diff changeset
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
kono
parents:
diff changeset
17 -- --
kono
parents:
diff changeset
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
kono
parents:
diff changeset
19 -- additional permissions described in the GCC Runtime Library Exception, --
kono
parents:
diff changeset
20 -- version 3.1, as published by the Free Software Foundation. --
kono
parents:
diff changeset
21 -- --
kono
parents:
diff changeset
22 -- You should have received a copy of the GNU General Public License and --
kono
parents:
diff changeset
23 -- a copy of the GCC Runtime Library Exception along with this program; --
kono
parents:
diff changeset
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
kono
parents:
diff changeset
25 -- <http://www.gnu.org/licenses/>. --
kono
parents:
diff changeset
26 -- --
kono
parents:
diff changeset
27 -- GNAT was originally developed by the GNAT team at New York University. --
kono
parents:
diff changeset
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
kono
parents:
diff changeset
29 -- --
kono
parents:
diff changeset
30 ------------------------------------------------------------------------------
kono
parents:
diff changeset
31
kono
parents:
diff changeset
32 with Ada.Streams; use Ada.Streams;
kono
parents:
diff changeset
33 with Interfaces.C_Streams; use Interfaces.C_Streams;
kono
parents:
diff changeset
34
kono
parents:
diff changeset
35 with System.File_IO;
kono
parents:
diff changeset
36 with System.CRTL;
kono
parents:
diff changeset
37 with System.WCh_Cnv; use System.WCh_Cnv;
kono
parents:
diff changeset
38 with System.WCh_Con; use System.WCh_Con;
kono
parents:
diff changeset
39
kono
parents:
diff changeset
40 with Ada.Unchecked_Conversion;
kono
parents:
diff changeset
41 with Ada.Unchecked_Deallocation;
kono
parents:
diff changeset
42
kono
parents:
diff changeset
43 pragma Elaborate_All (System.File_IO);
kono
parents:
diff changeset
44 -- Needed because of calls to Chain_File in package body elaboration
kono
parents:
diff changeset
45
145
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
46 package body Ada.Text_IO with
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
47 Refined_State => (File_System => (Standard_In,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
48 Standard_Out,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
49 Standard_Err,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
50 Current_In,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
51 Current_Out,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
52 Current_Err,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
53 In_Name,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
54 Out_Name,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
55 Err_Name,
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
56 WC_Encoding))
1830386684a0 gcc-9.2.0
anatofuz
parents: 131
diff changeset
57 is
111
kono
parents:
diff changeset
58
kono
parents:
diff changeset
59 package FIO renames System.File_IO;
kono
parents:
diff changeset
60
kono
parents:
diff changeset
61 subtype AP is FCB.AFCB_Ptr;
kono
parents:
diff changeset
62
kono
parents:
diff changeset
63 function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode);
kono
parents:
diff changeset
64 function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode);
kono
parents:
diff changeset
65 use type FCB.File_Mode;
kono
parents:
diff changeset
66
kono
parents:
diff changeset
67 use type System.CRTL.size_t;
kono
parents:
diff changeset
68
kono
parents:
diff changeset
69 WC_Encoding : Character;
kono
parents:
diff changeset
70 pragma Import (C, WC_Encoding, "__gl_wc_encoding");
kono
parents:
diff changeset
71 -- Default wide character encoding
kono
parents:
diff changeset
72
kono
parents:
diff changeset
73 Err_Name : aliased String := "*stderr" & ASCII.NUL;
kono
parents:
diff changeset
74 In_Name : aliased String := "*stdin" & ASCII.NUL;
kono
parents:
diff changeset
75 Out_Name : aliased String := "*stdout" & ASCII.NUL;
kono
parents:
diff changeset
76 -- Names of standard files
kono
parents:
diff changeset
77 --
kono
parents:
diff changeset
78 -- Use "preallocated" strings to avoid calling "new" during the elaboration
kono
parents:
diff changeset
79 -- of the run time. This is needed in the tasking case to avoid calling
kono
parents:
diff changeset
80 -- Task_Lock too early. A filename is expected to end with a null character
kono
parents:
diff changeset
81 -- in the runtime, here the null characters are added just to have a
kono
parents:
diff changeset
82 -- correct filename length.
kono
parents:
diff changeset
83 --
kono
parents:
diff changeset
84 -- Note: the names for these files are bogus, and probably it would be
kono
parents:
diff changeset
85 -- better for these files to have no names, but the ACVC tests insist.
kono
parents:
diff changeset
86 -- We use names that are bound to fail in open etc.
kono
parents:
diff changeset
87
kono
parents:
diff changeset
88 Null_Str : aliased constant String := "";
kono
parents:
diff changeset
89 -- Used as form string for standard files
kono
parents:
diff changeset
90
kono
parents:
diff changeset
91 -----------------------
kono
parents:
diff changeset
92 -- Local Subprograms --
kono
parents:
diff changeset
93 -----------------------
kono
parents:
diff changeset
94
kono
parents:
diff changeset
95 function Get_Upper_Half_Char
kono
parents:
diff changeset
96 (C : Character;
kono
parents:
diff changeset
97 File : File_Type) return Character;
kono
parents:
diff changeset
98 -- This function is shared by Get and Get_Immediate to extract an encoded
kono
parents:
diff changeset
99 -- upper half character value from the given File. The first byte has
kono
parents:
diff changeset
100 -- already been read and is passed in C. The character value is returned as
kono
parents:
diff changeset
101 -- the result, and the file pointer is bumped past the character.
kono
parents:
diff changeset
102 -- Constraint_Error is raised if the encoded value is outside the bounds of
kono
parents:
diff changeset
103 -- type Character.
kono
parents:
diff changeset
104
kono
parents:
diff changeset
105 function Get_Upper_Half_Char_Immed
kono
parents:
diff changeset
106 (C : Character;
kono
parents:
diff changeset
107 File : File_Type) return Character;
kono
parents:
diff changeset
108 -- This routine is identical to Get_Upper_Half_Char, except that the reads
kono
parents:
diff changeset
109 -- are done in Get_Immediate mode (i.e. without waiting for a line return).
kono
parents:
diff changeset
110
kono
parents:
diff changeset
111 function Getc (File : File_Type) return int;
kono
parents:
diff changeset
112 -- Gets next character from file, which has already been checked for being
kono
parents:
diff changeset
113 -- in read status, and returns the character read if no error occurs. The
kono
parents:
diff changeset
114 -- result is EOF if the end of file was read.
kono
parents:
diff changeset
115
kono
parents:
diff changeset
116 function Getc_Immed (File : File_Type) return int;
kono
parents:
diff changeset
117 -- This routine is identical to Getc, except that the read is done in
kono
parents:
diff changeset
118 -- Get_Immediate mode (i.e. without waiting for a line return).
kono
parents:
diff changeset
119
kono
parents:
diff changeset
120 function Has_Upper_Half_Character (Item : String) return Boolean;
kono
parents:
diff changeset
121 -- Returns True if any of the characters is in the range 16#80#-16#FF#
kono
parents:
diff changeset
122
kono
parents:
diff changeset
123 function Nextc (File : File_Type) return int;
kono
parents:
diff changeset
124 -- Returns next character from file without skipping past it (i.e. it is a
kono
parents:
diff changeset
125 -- combination of Getc followed by an Ungetc).
kono
parents:
diff changeset
126
kono
parents:
diff changeset
127 procedure Put_Encoded (File : File_Type; Char : Character);
kono
parents:
diff changeset
128 -- Called to output a character Char to the given File, when the encoding
kono
parents:
diff changeset
129 -- method for the file is other than brackets, and Char is upper half.
kono
parents:
diff changeset
130
kono
parents:
diff changeset
131 procedure Putc (ch : int; File : File_Type);
kono
parents:
diff changeset
132 -- Outputs the given character to the file, which has already been checked
kono
parents:
diff changeset
133 -- for being in output status. Device_Error is raised if the character
kono
parents:
diff changeset
134 -- cannot be written.
kono
parents:
diff changeset
135
kono
parents:
diff changeset
136 procedure Set_WCEM (File : in out File_Type);
kono
parents:
diff changeset
137 -- Called by Open and Create to set the wide character encoding method for
kono
parents:
diff changeset
138 -- the file, processing a WCEM form parameter if one is present. File is
kono
parents:
diff changeset
139 -- IN OUT because it may be closed in case of an error.
kono
parents:
diff changeset
140
kono
parents:
diff changeset
141 procedure Terminate_Line (File : File_Type);
kono
parents:
diff changeset
142 -- If the file is in Write_File or Append_File mode, and the current line
kono
parents:
diff changeset
143 -- is not terminated, then a line terminator is written using New_Line.
kono
parents:
diff changeset
144 -- Note that there is no Terminate_Page routine, because the page mark at
kono
parents:
diff changeset
145 -- the end of the file is implied if necessary.
kono
parents:
diff changeset
146
kono
parents:
diff changeset
147 procedure Ungetc (ch : int; File : File_Type);
kono
parents:
diff changeset
148 -- Pushes back character into stream, using ungetc. The caller has checked
kono
parents:
diff changeset
149 -- that the file is in read status. Device_Error is raised if the character
kono
parents:
diff changeset
150 -- cannot be pushed back. An attempt to push back and end of file character
kono
parents:
diff changeset
151 -- (EOF) is ignored.
kono
parents:
diff changeset
152
kono
parents:
diff changeset
153 -------------------
kono
parents:
diff changeset
154 -- AFCB_Allocate --
kono
parents:
diff changeset
155 -------------------
kono
parents:
diff changeset
156
kono
parents:
diff changeset
157 function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is
kono
parents:
diff changeset
158 pragma Unreferenced (Control_Block);
kono
parents:
diff changeset
159 begin
kono
parents:
diff changeset
160 return new Text_AFCB;
kono
parents:
diff changeset
161 end AFCB_Allocate;
kono
parents:
diff changeset
162
kono
parents:
diff changeset
163 ----------------
kono
parents:
diff changeset
164 -- AFCB_Close --
kono
parents:
diff changeset
165 ----------------
kono
parents:
diff changeset
166
kono
parents:
diff changeset
167 procedure AFCB_Close (File : not null access Text_AFCB) is
kono
parents:
diff changeset
168 begin
kono
parents:
diff changeset
169 -- If the file being closed is one of the current files, then close
kono
parents:
diff changeset
170 -- the corresponding current file. It is not clear that this action
kono
parents:
diff changeset
171 -- is required (RM A.10.3(23)) but it seems reasonable, and besides
kono
parents:
diff changeset
172 -- ACVC test CE3208A expects this behavior.
kono
parents:
diff changeset
173
kono
parents:
diff changeset
174 if File_Type (File) = Current_In then
kono
parents:
diff changeset
175 Current_In := null;
kono
parents:
diff changeset
176 elsif File_Type (File) = Current_Out then
kono
parents:
diff changeset
177 Current_Out := null;
kono
parents:
diff changeset
178 elsif File_Type (File) = Current_Err then
kono
parents:
diff changeset
179 Current_Err := null;
kono
parents:
diff changeset
180 end if;
kono
parents:
diff changeset
181
kono
parents:
diff changeset
182 Terminate_Line (File_Type (File));
kono
parents:
diff changeset
183 end AFCB_Close;
kono
parents:
diff changeset
184
kono
parents:
diff changeset
185 ---------------
kono
parents:
diff changeset
186 -- AFCB_Free --
kono
parents:
diff changeset
187 ---------------
kono
parents:
diff changeset
188
kono
parents:
diff changeset
189 procedure AFCB_Free (File : not null access Text_AFCB) is
kono
parents:
diff changeset
190 type FCB_Ptr is access all Text_AFCB;
kono
parents:
diff changeset
191 FT : FCB_Ptr := FCB_Ptr (File);
kono
parents:
diff changeset
192
kono
parents:
diff changeset
193 procedure Free is new Ada.Unchecked_Deallocation (Text_AFCB, FCB_Ptr);
kono
parents:
diff changeset
194
kono
parents:
diff changeset
195 begin
kono
parents:
diff changeset
196 Free (FT);
kono
parents:
diff changeset
197 end AFCB_Free;
kono
parents:
diff changeset
198
kono
parents:
diff changeset
199 -----------
kono
parents:
diff changeset
200 -- Close --
kono
parents:
diff changeset
201 -----------
kono
parents:
diff changeset
202
kono
parents:
diff changeset
203 procedure Close (File : in out File_Type) is
kono
parents:
diff changeset
204 begin
kono
parents:
diff changeset
205 FIO.Close (AP (File)'Unrestricted_Access);
kono
parents:
diff changeset
206 end Close;
kono
parents:
diff changeset
207
kono
parents:
diff changeset
208 ---------
kono
parents:
diff changeset
209 -- Col --
kono
parents:
diff changeset
210 ---------
kono
parents:
diff changeset
211
kono
parents:
diff changeset
212 -- Note: we assume that it is impossible in practice for the column
kono
parents:
diff changeset
213 -- to exceed the value of Count'Last, i.e. no check is required for
kono
parents:
diff changeset
214 -- overflow raising layout error.
kono
parents:
diff changeset
215
kono
parents:
diff changeset
216 function Col (File : File_Type) return Positive_Count is
kono
parents:
diff changeset
217 begin
kono
parents:
diff changeset
218 FIO.Check_File_Open (AP (File));
kono
parents:
diff changeset
219 return File.Col;
kono
parents:
diff changeset
220 end Col;
kono
parents:
diff changeset
221
kono
parents:
diff changeset
222 function Col return Positive_Count is
kono
parents:
diff changeset
223 begin
kono
parents:
diff changeset
224 return Col (Current_Out);
kono
parents:
diff changeset
225 end Col;
kono
parents:
diff changeset
226
kono
parents:
diff changeset
227 ------------
kono
parents:
diff changeset
228 -- Create --
kono
parents:
diff changeset
229 ------------
kono
parents:
diff changeset
230
kono
parents:
diff changeset
231 procedure Create
kono
parents:
diff changeset
232 (File : in out File_Type;
kono
parents:
diff changeset
233 Mode : File_Mode := Out_File;
kono
parents:
diff changeset
234 Name : String := "";
kono
parents:
diff changeset
235 Form : String := "")
kono
parents:
diff changeset
236 is
kono
parents:
diff changeset
237 Dummy_File_Control_Block : Text_AFCB;
kono
parents:
diff changeset
238 pragma Warnings (Off, Dummy_File_Control_Block);
kono
parents:
diff changeset
239 -- Yes, we know this is never assigned a value, only the tag
kono
parents:
diff changeset
240 -- is used for dispatching purposes, so that's expected.
kono
parents:
diff changeset
241
kono
parents:
diff changeset
242 begin
kono
parents:
diff changeset
243 FIO.Open (File_Ptr => AP (File),
kono
parents:
diff changeset
244 Dummy_FCB => Dummy_File_Control_Block,
kono
parents:
diff changeset
245 Mode => To_FCB (Mode),
kono
parents:
diff changeset
246 Name => Name,
kono
parents:
diff changeset
247 Form => Form,
kono
parents:
diff changeset
248 Amethod => 'T',
kono
parents:
diff changeset
249 Creat => True,
kono
parents:
diff changeset
250 Text => True);
kono
parents:
diff changeset
251
kono
parents:
diff changeset
252 File.Self := File;
kono
parents:
diff changeset
253 Set_WCEM (File);
kono
parents:
diff changeset
254 end Create;
kono
parents:
diff changeset
255
kono
parents:
diff changeset
256 -------------------
kono
parents:
diff changeset
257 -- Current_Error --
kono
parents:
diff changeset
258 -------------------
kono
parents:
diff changeset
259
kono
parents:
diff changeset
260 function Current_Error return File_Type is
kono
parents:
diff changeset
261 begin
kono
parents:
diff changeset
262 return Current_Err;
kono
parents:
diff changeset
263 end Current_Error;
kono
parents:
diff changeset
264
kono
parents:
diff changeset
265 function Current_Error return File_Access is
kono
parents:
diff changeset
266 begin
kono
parents:
diff changeset
267 return Current_Err.Self'Access;
kono
parents:
diff changeset
268 end Current_Error;
kono
parents:
diff changeset
269
kono
parents:
diff changeset
270 -------------------
kono
parents:
diff changeset
271 -- Current_Input --
kono
parents:
diff changeset
272 -------------------
kono
parents:
diff changeset
273
kono
parents:
diff changeset
274 function Current_Input return File_Type is
kono
parents:
diff changeset
275 begin
kono
parents:
diff changeset
276 return Current_In;
kono
parents:
diff changeset
277 end Current_Input;
kono
parents:
diff changeset
278
kono
parents:
diff changeset
279 function Current_Input return File_Access is
kono
parents:
diff changeset
280 begin
kono
parents:
diff changeset
281 return Current_In.Self'Access;
kono
parents:
diff changeset
282 end Current_Input;
kono
parents:
diff changeset
283
kono
parents:
diff changeset
284 --------------------
kono
parents:
diff changeset
285 -- Current_Output --
kono
parents:
diff changeset
286 --------------------
kono
parents:
diff changeset
287
kono
parents:
diff changeset
288 function Current_Output return File_Type is
kono
parents:
diff changeset
289 begin
kono
parents:
diff changeset
290 return Current_Out;
kono
parents:
diff changeset
291 end Current_Output;
kono
parents:
diff changeset
292
kono
parents:
diff changeset
293 function Current_Output return File_Access is
kono
parents:
diff changeset
294 begin
kono
parents:
diff changeset
295 return Current_Out.Self'Access;
kono
parents:
diff changeset
296 end Current_Output;
kono
parents:
diff changeset
297
kono
parents:
diff changeset
298 ------------
kono
parents:
diff changeset
299 -- Delete --
kono
parents:
diff changeset
300 ------------
kono
parents:
diff changeset
301
kono
parents:
diff changeset
302 procedure Delete (File : in out File_Type) is
kono
parents:
diff changeset
303 begin
kono
parents:
diff changeset
304 FIO.Delete (AP (File)'Unrestricted_Access);
kono
parents:
diff changeset
305 end Delete;
kono
parents:
diff changeset
306
kono
parents:
diff changeset
307 -----------------
kono
parents:
diff changeset
308 -- End_Of_File --
kono
parents:
diff changeset
309 -----------------
kono
parents:
diff changeset
310
kono
parents:
diff changeset
311 function End_Of_File (File : File_Type) return Boolean is
kono
parents:
diff changeset
312 ch : int;
kono
parents:
diff changeset
313
kono
parents:
diff changeset
314 begin
kono
parents:
diff changeset
315 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
316
kono
parents:
diff changeset
317 if File.Before_Upper_Half_Character then
kono
parents:
diff changeset
318 return False;
kono
parents:
diff changeset
319
kono
parents:
diff changeset
320 elsif File.Before_LM then
kono
parents:
diff changeset
321 if File.Before_LM_PM then
kono
parents:
diff changeset
322 return Nextc (File) = EOF;
kono
parents:
diff changeset
323 end if;
kono
parents:
diff changeset
324
kono
parents:
diff changeset
325 else
kono
parents:
diff changeset
326 ch := Getc (File);
kono
parents:
diff changeset
327
kono
parents:
diff changeset
328 if ch = EOF then
kono
parents:
diff changeset
329 return True;
kono
parents:
diff changeset
330
kono
parents:
diff changeset
331 elsif ch /= LM then
kono
parents:
diff changeset
332 Ungetc (ch, File);
kono
parents:
diff changeset
333 return False;
kono
parents:
diff changeset
334
kono
parents:
diff changeset
335 else -- ch = LM
kono
parents:
diff changeset
336 File.Before_LM := True;
kono
parents:
diff changeset
337 end if;
kono
parents:
diff changeset
338 end if;
kono
parents:
diff changeset
339
kono
parents:
diff changeset
340 -- Here we are just past the line mark with Before_LM set so that we
kono
parents:
diff changeset
341 -- do not have to try to back up past the LM, thus avoiding the need
kono
parents:
diff changeset
342 -- to back up more than one character.
kono
parents:
diff changeset
343
kono
parents:
diff changeset
344 ch := Getc (File);
kono
parents:
diff changeset
345
kono
parents:
diff changeset
346 if ch = EOF then
kono
parents:
diff changeset
347 return True;
kono
parents:
diff changeset
348
kono
parents:
diff changeset
349 elsif ch = PM and then File.Is_Regular_File then
kono
parents:
diff changeset
350 File.Before_LM_PM := True;
kono
parents:
diff changeset
351 return Nextc (File) = EOF;
kono
parents:
diff changeset
352
kono
parents:
diff changeset
353 -- Here if neither EOF nor PM followed end of line
kono
parents:
diff changeset
354
kono
parents:
diff changeset
355 else
kono
parents:
diff changeset
356 Ungetc (ch, File);
kono
parents:
diff changeset
357 return False;
kono
parents:
diff changeset
358 end if;
kono
parents:
diff changeset
359
kono
parents:
diff changeset
360 end End_Of_File;
kono
parents:
diff changeset
361
kono
parents:
diff changeset
362 function End_Of_File return Boolean is
kono
parents:
diff changeset
363 begin
kono
parents:
diff changeset
364 return End_Of_File (Current_In);
kono
parents:
diff changeset
365 end End_Of_File;
kono
parents:
diff changeset
366
kono
parents:
diff changeset
367 -----------------
kono
parents:
diff changeset
368 -- End_Of_Line --
kono
parents:
diff changeset
369 -----------------
kono
parents:
diff changeset
370
kono
parents:
diff changeset
371 function End_Of_Line (File : File_Type) return Boolean is
kono
parents:
diff changeset
372 ch : int;
kono
parents:
diff changeset
373
kono
parents:
diff changeset
374 begin
kono
parents:
diff changeset
375 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
376
kono
parents:
diff changeset
377 if File.Before_Upper_Half_Character then
kono
parents:
diff changeset
378 return False;
kono
parents:
diff changeset
379
kono
parents:
diff changeset
380 elsif File.Before_LM then
kono
parents:
diff changeset
381 return True;
kono
parents:
diff changeset
382
kono
parents:
diff changeset
383 else
kono
parents:
diff changeset
384 ch := Getc (File);
kono
parents:
diff changeset
385
kono
parents:
diff changeset
386 if ch = EOF then
kono
parents:
diff changeset
387 return True;
kono
parents:
diff changeset
388
kono
parents:
diff changeset
389 else
kono
parents:
diff changeset
390 Ungetc (ch, File);
kono
parents:
diff changeset
391 return (ch = LM);
kono
parents:
diff changeset
392 end if;
kono
parents:
diff changeset
393 end if;
kono
parents:
diff changeset
394 end End_Of_Line;
kono
parents:
diff changeset
395
kono
parents:
diff changeset
396 function End_Of_Line return Boolean is
kono
parents:
diff changeset
397 begin
kono
parents:
diff changeset
398 return End_Of_Line (Current_In);
kono
parents:
diff changeset
399 end End_Of_Line;
kono
parents:
diff changeset
400
kono
parents:
diff changeset
401 -----------------
kono
parents:
diff changeset
402 -- End_Of_Page --
kono
parents:
diff changeset
403 -----------------
kono
parents:
diff changeset
404
kono
parents:
diff changeset
405 function End_Of_Page (File : File_Type) return Boolean is
kono
parents:
diff changeset
406 ch : int;
kono
parents:
diff changeset
407
kono
parents:
diff changeset
408 begin
kono
parents:
diff changeset
409 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
410
kono
parents:
diff changeset
411 if not File.Is_Regular_File then
kono
parents:
diff changeset
412 return False;
kono
parents:
diff changeset
413
kono
parents:
diff changeset
414 elsif File.Before_Upper_Half_Character then
kono
parents:
diff changeset
415 return False;
kono
parents:
diff changeset
416
kono
parents:
diff changeset
417 elsif File.Before_LM then
kono
parents:
diff changeset
418 if File.Before_LM_PM then
kono
parents:
diff changeset
419 return True;
kono
parents:
diff changeset
420 end if;
kono
parents:
diff changeset
421
kono
parents:
diff changeset
422 else
kono
parents:
diff changeset
423 ch := Getc (File);
kono
parents:
diff changeset
424
kono
parents:
diff changeset
425 if ch = EOF then
kono
parents:
diff changeset
426 return True;
kono
parents:
diff changeset
427
kono
parents:
diff changeset
428 elsif ch /= LM then
kono
parents:
diff changeset
429 Ungetc (ch, File);
kono
parents:
diff changeset
430 return False;
kono
parents:
diff changeset
431
kono
parents:
diff changeset
432 else -- ch = LM
kono
parents:
diff changeset
433 File.Before_LM := True;
kono
parents:
diff changeset
434 end if;
kono
parents:
diff changeset
435 end if;
kono
parents:
diff changeset
436
kono
parents:
diff changeset
437 -- Here we are just past the line mark with Before_LM set so that we
kono
parents:
diff changeset
438 -- do not have to try to back up past the LM, thus avoiding the need
kono
parents:
diff changeset
439 -- to back up more than one character.
kono
parents:
diff changeset
440
kono
parents:
diff changeset
441 ch := Nextc (File);
kono
parents:
diff changeset
442
kono
parents:
diff changeset
443 return ch = PM or else ch = EOF;
kono
parents:
diff changeset
444 end End_Of_Page;
kono
parents:
diff changeset
445
kono
parents:
diff changeset
446 function End_Of_Page return Boolean is
kono
parents:
diff changeset
447 begin
kono
parents:
diff changeset
448 return End_Of_Page (Current_In);
kono
parents:
diff changeset
449 end End_Of_Page;
kono
parents:
diff changeset
450
kono
parents:
diff changeset
451 --------------
kono
parents:
diff changeset
452 -- EOF_Char --
kono
parents:
diff changeset
453 --------------
kono
parents:
diff changeset
454
kono
parents:
diff changeset
455 function EOF_Char return Integer is
kono
parents:
diff changeset
456 begin
kono
parents:
diff changeset
457 return EOF;
kono
parents:
diff changeset
458 end EOF_Char;
kono
parents:
diff changeset
459
kono
parents:
diff changeset
460 -----------
kono
parents:
diff changeset
461 -- Flush --
kono
parents:
diff changeset
462 -----------
kono
parents:
diff changeset
463
kono
parents:
diff changeset
464 procedure Flush (File : File_Type) is
kono
parents:
diff changeset
465 begin
kono
parents:
diff changeset
466 FIO.Flush (AP (File));
kono
parents:
diff changeset
467 end Flush;
kono
parents:
diff changeset
468
kono
parents:
diff changeset
469 procedure Flush is
kono
parents:
diff changeset
470 begin
kono
parents:
diff changeset
471 Flush (Current_Out);
kono
parents:
diff changeset
472 end Flush;
kono
parents:
diff changeset
473
kono
parents:
diff changeset
474 ----------
kono
parents:
diff changeset
475 -- Form --
kono
parents:
diff changeset
476 ----------
kono
parents:
diff changeset
477
kono
parents:
diff changeset
478 function Form (File : File_Type) return String is
kono
parents:
diff changeset
479 begin
kono
parents:
diff changeset
480 return FIO.Form (AP (File));
kono
parents:
diff changeset
481 end Form;
kono
parents:
diff changeset
482
kono
parents:
diff changeset
483 ---------
kono
parents:
diff changeset
484 -- Get --
kono
parents:
diff changeset
485 ---------
kono
parents:
diff changeset
486
kono
parents:
diff changeset
487 procedure Get
kono
parents:
diff changeset
488 (File : File_Type;
kono
parents:
diff changeset
489 Item : out Character)
kono
parents:
diff changeset
490 is
kono
parents:
diff changeset
491 ch : int;
kono
parents:
diff changeset
492
kono
parents:
diff changeset
493 begin
kono
parents:
diff changeset
494 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
495
kono
parents:
diff changeset
496 if File.Before_Upper_Half_Character then
kono
parents:
diff changeset
497 File.Before_Upper_Half_Character := False;
kono
parents:
diff changeset
498 Item := File.Saved_Upper_Half_Character;
kono
parents:
diff changeset
499
kono
parents:
diff changeset
500 elsif File.Before_LM then
kono
parents:
diff changeset
501 File.Before_LM := False;
kono
parents:
diff changeset
502 File.Col := 1;
kono
parents:
diff changeset
503
kono
parents:
diff changeset
504 if File.Before_LM_PM then
kono
parents:
diff changeset
505 File.Line := 1;
kono
parents:
diff changeset
506 File.Page := File.Page + 1;
kono
parents:
diff changeset
507 File.Before_LM_PM := False;
kono
parents:
diff changeset
508 else
kono
parents:
diff changeset
509 File.Line := File.Line + 1;
kono
parents:
diff changeset
510 end if;
kono
parents:
diff changeset
511 end if;
kono
parents:
diff changeset
512
kono
parents:
diff changeset
513 loop
kono
parents:
diff changeset
514 ch := Getc (File);
kono
parents:
diff changeset
515
kono
parents:
diff changeset
516 if ch = EOF then
kono
parents:
diff changeset
517 raise End_Error;
kono
parents:
diff changeset
518
kono
parents:
diff changeset
519 elsif ch = LM then
kono
parents:
diff changeset
520 File.Line := File.Line + 1;
kono
parents:
diff changeset
521 File.Col := 1;
kono
parents:
diff changeset
522
kono
parents:
diff changeset
523 elsif ch = PM and then File.Is_Regular_File then
kono
parents:
diff changeset
524 File.Page := File.Page + 1;
kono
parents:
diff changeset
525 File.Line := 1;
kono
parents:
diff changeset
526
kono
parents:
diff changeset
527 else
kono
parents:
diff changeset
528 Item := Character'Val (ch);
kono
parents:
diff changeset
529 File.Col := File.Col + 1;
kono
parents:
diff changeset
530 return;
kono
parents:
diff changeset
531 end if;
kono
parents:
diff changeset
532 end loop;
kono
parents:
diff changeset
533 end Get;
kono
parents:
diff changeset
534
kono
parents:
diff changeset
535 procedure Get (Item : out Character) is
kono
parents:
diff changeset
536 begin
kono
parents:
diff changeset
537 Get (Current_In, Item);
kono
parents:
diff changeset
538 end Get;
kono
parents:
diff changeset
539
kono
parents:
diff changeset
540 procedure Get
kono
parents:
diff changeset
541 (File : File_Type;
kono
parents:
diff changeset
542 Item : out String)
kono
parents:
diff changeset
543 is
kono
parents:
diff changeset
544 ch : int;
kono
parents:
diff changeset
545 J : Natural;
kono
parents:
diff changeset
546
kono
parents:
diff changeset
547 begin
kono
parents:
diff changeset
548 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
549
kono
parents:
diff changeset
550 if File.Before_LM then
kono
parents:
diff changeset
551 File.Before_LM := False;
kono
parents:
diff changeset
552 File.Before_LM_PM := False;
kono
parents:
diff changeset
553 File.Col := 1;
kono
parents:
diff changeset
554
kono
parents:
diff changeset
555 if File.Before_LM_PM then
kono
parents:
diff changeset
556 File.Line := 1;
kono
parents:
diff changeset
557 File.Page := File.Page + 1;
kono
parents:
diff changeset
558 File.Before_LM_PM := False;
kono
parents:
diff changeset
559
kono
parents:
diff changeset
560 else
kono
parents:
diff changeset
561 File.Line := File.Line + 1;
kono
parents:
diff changeset
562 end if;
kono
parents:
diff changeset
563 end if;
kono
parents:
diff changeset
564
kono
parents:
diff changeset
565 J := Item'First;
kono
parents:
diff changeset
566 while J <= Item'Last loop
kono
parents:
diff changeset
567 ch := Getc (File);
kono
parents:
diff changeset
568
kono
parents:
diff changeset
569 if ch = EOF then
kono
parents:
diff changeset
570 raise End_Error;
kono
parents:
diff changeset
571
kono
parents:
diff changeset
572 elsif ch = LM then
kono
parents:
diff changeset
573 File.Line := File.Line + 1;
kono
parents:
diff changeset
574 File.Col := 1;
kono
parents:
diff changeset
575
kono
parents:
diff changeset
576 elsif ch = PM and then File.Is_Regular_File then
kono
parents:
diff changeset
577 File.Page := File.Page + 1;
kono
parents:
diff changeset
578 File.Line := 1;
kono
parents:
diff changeset
579
kono
parents:
diff changeset
580 else
kono
parents:
diff changeset
581 Item (J) := Character'Val (ch);
kono
parents:
diff changeset
582 J := J + 1;
kono
parents:
diff changeset
583 File.Col := File.Col + 1;
kono
parents:
diff changeset
584 end if;
kono
parents:
diff changeset
585 end loop;
kono
parents:
diff changeset
586 end Get;
kono
parents:
diff changeset
587
kono
parents:
diff changeset
588 procedure Get (Item : out String) is
kono
parents:
diff changeset
589 begin
kono
parents:
diff changeset
590 Get (Current_In, Item);
kono
parents:
diff changeset
591 end Get;
kono
parents:
diff changeset
592
kono
parents:
diff changeset
593 -------------------
kono
parents:
diff changeset
594 -- Get_Immediate --
kono
parents:
diff changeset
595 -------------------
kono
parents:
diff changeset
596
kono
parents:
diff changeset
597 procedure Get_Immediate
kono
parents:
diff changeset
598 (File : File_Type;
kono
parents:
diff changeset
599 Item : out Character)
kono
parents:
diff changeset
600 is
kono
parents:
diff changeset
601 ch : int;
kono
parents:
diff changeset
602
kono
parents:
diff changeset
603 begin
kono
parents:
diff changeset
604 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
605
kono
parents:
diff changeset
606 if File.Before_Upper_Half_Character then
kono
parents:
diff changeset
607 File.Before_Upper_Half_Character := False;
kono
parents:
diff changeset
608 Item := File.Saved_Upper_Half_Character;
kono
parents:
diff changeset
609
kono
parents:
diff changeset
610 elsif File.Before_LM then
kono
parents:
diff changeset
611 File.Before_LM := False;
kono
parents:
diff changeset
612 File.Before_LM_PM := False;
kono
parents:
diff changeset
613 Item := Character'Val (LM);
kono
parents:
diff changeset
614
kono
parents:
diff changeset
615 else
kono
parents:
diff changeset
616 ch := Getc_Immed (File);
kono
parents:
diff changeset
617
kono
parents:
diff changeset
618 if ch = EOF then
kono
parents:
diff changeset
619 raise End_Error;
kono
parents:
diff changeset
620 else
kono
parents:
diff changeset
621 Item :=
kono
parents:
diff changeset
622 (if not Is_Start_Of_Encoding (Character'Val (ch), File.WC_Method)
kono
parents:
diff changeset
623 then Character'Val (ch)
kono
parents:
diff changeset
624 else Get_Upper_Half_Char_Immed (Character'Val (ch), File));
kono
parents:
diff changeset
625 end if;
kono
parents:
diff changeset
626 end if;
kono
parents:
diff changeset
627 end Get_Immediate;
kono
parents:
diff changeset
628
kono
parents:
diff changeset
629 procedure Get_Immediate
kono
parents:
diff changeset
630 (Item : out Character)
kono
parents:
diff changeset
631 is
kono
parents:
diff changeset
632 begin
kono
parents:
diff changeset
633 Get_Immediate (Current_In, Item);
kono
parents:
diff changeset
634 end Get_Immediate;
kono
parents:
diff changeset
635
kono
parents:
diff changeset
636 procedure Get_Immediate
kono
parents:
diff changeset
637 (File : File_Type;
kono
parents:
diff changeset
638 Item : out Character;
kono
parents:
diff changeset
639 Available : out Boolean)
kono
parents:
diff changeset
640 is
kono
parents:
diff changeset
641 ch : int;
kono
parents:
diff changeset
642 end_of_file : int;
kono
parents:
diff changeset
643 avail : int;
kono
parents:
diff changeset
644
kono
parents:
diff changeset
645 procedure getc_immediate_nowait
kono
parents:
diff changeset
646 (stream : FILEs;
kono
parents:
diff changeset
647 ch : out int;
kono
parents:
diff changeset
648 end_of_file : out int;
kono
parents:
diff changeset
649 avail : out int);
kono
parents:
diff changeset
650 pragma Import (C, getc_immediate_nowait, "getc_immediate_nowait");
kono
parents:
diff changeset
651
kono
parents:
diff changeset
652 begin
kono
parents:
diff changeset
653 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
654 Available := True;
kono
parents:
diff changeset
655
kono
parents:
diff changeset
656 if File.Before_Upper_Half_Character then
kono
parents:
diff changeset
657 File.Before_Upper_Half_Character := False;
kono
parents:
diff changeset
658 Item := File.Saved_Upper_Half_Character;
kono
parents:
diff changeset
659
kono
parents:
diff changeset
660 elsif File.Before_LM then
kono
parents:
diff changeset
661 File.Before_LM := False;
kono
parents:
diff changeset
662 File.Before_LM_PM := False;
kono
parents:
diff changeset
663 Item := Character'Val (LM);
kono
parents:
diff changeset
664
kono
parents:
diff changeset
665 else
kono
parents:
diff changeset
666 getc_immediate_nowait (File.Stream, ch, end_of_file, avail);
kono
parents:
diff changeset
667
kono
parents:
diff changeset
668 if ferror (File.Stream) /= 0 then
kono
parents:
diff changeset
669 raise Device_Error;
kono
parents:
diff changeset
670
kono
parents:
diff changeset
671 elsif end_of_file /= 0 then
kono
parents:
diff changeset
672 raise End_Error;
kono
parents:
diff changeset
673
kono
parents:
diff changeset
674 elsif avail = 0 then
kono
parents:
diff changeset
675 Available := False;
kono
parents:
diff changeset
676 Item := ASCII.NUL;
kono
parents:
diff changeset
677
kono
parents:
diff changeset
678 else
kono
parents:
diff changeset
679 Available := True;
kono
parents:
diff changeset
680
kono
parents:
diff changeset
681 Item :=
kono
parents:
diff changeset
682 (if not Is_Start_Of_Encoding (Character'Val (ch), File.WC_Method)
kono
parents:
diff changeset
683 then Character'Val (ch)
kono
parents:
diff changeset
684 else Get_Upper_Half_Char_Immed (Character'Val (ch), File));
kono
parents:
diff changeset
685 end if;
kono
parents:
diff changeset
686 end if;
kono
parents:
diff changeset
687
kono
parents:
diff changeset
688 end Get_Immediate;
kono
parents:
diff changeset
689
kono
parents:
diff changeset
690 procedure Get_Immediate
kono
parents:
diff changeset
691 (Item : out Character;
kono
parents:
diff changeset
692 Available : out Boolean)
kono
parents:
diff changeset
693 is
kono
parents:
diff changeset
694 begin
kono
parents:
diff changeset
695 Get_Immediate (Current_In, Item, Available);
kono
parents:
diff changeset
696 end Get_Immediate;
kono
parents:
diff changeset
697
kono
parents:
diff changeset
698 --------------
kono
parents:
diff changeset
699 -- Get_Line --
kono
parents:
diff changeset
700 --------------
kono
parents:
diff changeset
701
kono
parents:
diff changeset
702 procedure Get_Line
kono
parents:
diff changeset
703 (File : File_Type;
kono
parents:
diff changeset
704 Item : out String;
kono
parents:
diff changeset
705 Last : out Natural) is separate;
kono
parents:
diff changeset
706 -- The implementation of Ada.Text_IO.Get_Line is split into a subunit so
kono
parents:
diff changeset
707 -- that different implementations can be used on different systems.
kono
parents:
diff changeset
708
kono
parents:
diff changeset
709 procedure Get_Line
kono
parents:
diff changeset
710 (Item : out String;
kono
parents:
diff changeset
711 Last : out Natural)
kono
parents:
diff changeset
712 is
kono
parents:
diff changeset
713 begin
kono
parents:
diff changeset
714 Get_Line (Current_In, Item, Last);
kono
parents:
diff changeset
715 end Get_Line;
kono
parents:
diff changeset
716
kono
parents:
diff changeset
717 function Get_Line (File : File_Type) return String is
kono
parents:
diff changeset
718 function Get_Rest (S : String) return String;
kono
parents:
diff changeset
719 -- This is a recursive function that reads the rest of the line and
kono
parents:
diff changeset
720 -- returns it. S is the part read so far.
kono
parents:
diff changeset
721
kono
parents:
diff changeset
722 --------------
kono
parents:
diff changeset
723 -- Get_Rest --
kono
parents:
diff changeset
724 --------------
kono
parents:
diff changeset
725
kono
parents:
diff changeset
726 function Get_Rest (S : String) return String is
kono
parents:
diff changeset
727
kono
parents:
diff changeset
728 -- The first time we allocate a buffer of size 500. Each following
kono
parents:
diff changeset
729 -- time we allocate a buffer the same size as what we have read so
kono
parents:
diff changeset
730 -- far. This limits us to a logarithmic number of calls to Get_Rest
kono
parents:
diff changeset
731 -- and also ensures only a linear use of stack space.
kono
parents:
diff changeset
732
kono
parents:
diff changeset
733 Buffer : String (1 .. Integer'Max (500, S'Length));
kono
parents:
diff changeset
734 Last : Natural;
kono
parents:
diff changeset
735
kono
parents:
diff changeset
736 begin
kono
parents:
diff changeset
737 Get_Line (File, Buffer, Last);
kono
parents:
diff changeset
738
kono
parents:
diff changeset
739 declare
kono
parents:
diff changeset
740 R : constant String := S & Buffer (1 .. Last);
kono
parents:
diff changeset
741 begin
kono
parents:
diff changeset
742 if Last < Buffer'Last then
kono
parents:
diff changeset
743 return R;
kono
parents:
diff changeset
744
kono
parents:
diff changeset
745 else
kono
parents:
diff changeset
746 pragma Assert (Last = Buffer'Last);
kono
parents:
diff changeset
747
kono
parents:
diff changeset
748 -- If the String has the same length as the buffer, and there
kono
parents:
diff changeset
749 -- is no end of line, check whether we are at the end of file,
kono
parents:
diff changeset
750 -- in which case we have the full String in the buffer.
kono
parents:
diff changeset
751
kono
parents:
diff changeset
752 if End_Of_File (File) then
kono
parents:
diff changeset
753 return R;
kono
parents:
diff changeset
754
kono
parents:
diff changeset
755 else
kono
parents:
diff changeset
756 return Get_Rest (R);
kono
parents:
diff changeset
757 end if;
kono
parents:
diff changeset
758 end if;
kono
parents:
diff changeset
759 end;
kono
parents:
diff changeset
760 end Get_Rest;
kono
parents:
diff changeset
761
kono
parents:
diff changeset
762 -- Start of processing for Get_Line
kono
parents:
diff changeset
763
kono
parents:
diff changeset
764 begin
kono
parents:
diff changeset
765 return Get_Rest ("");
kono
parents:
diff changeset
766 end Get_Line;
kono
parents:
diff changeset
767
kono
parents:
diff changeset
768 function Get_Line return String is
kono
parents:
diff changeset
769 begin
kono
parents:
diff changeset
770 return Get_Line (Current_In);
kono
parents:
diff changeset
771 end Get_Line;
kono
parents:
diff changeset
772
kono
parents:
diff changeset
773 -------------------------
kono
parents:
diff changeset
774 -- Get_Upper_Half_Char --
kono
parents:
diff changeset
775 -------------------------
kono
parents:
diff changeset
776
kono
parents:
diff changeset
777 function Get_Upper_Half_Char
kono
parents:
diff changeset
778 (C : Character;
kono
parents:
diff changeset
779 File : File_Type) return Character
kono
parents:
diff changeset
780 is
kono
parents:
diff changeset
781 Result : Wide_Character;
kono
parents:
diff changeset
782
kono
parents:
diff changeset
783 function In_Char return Character;
kono
parents:
diff changeset
784 -- Function used to obtain additional characters it the wide character
kono
parents:
diff changeset
785 -- sequence is more than one character long.
kono
parents:
diff changeset
786
kono
parents:
diff changeset
787 function WC_In is new Char_Sequence_To_Wide_Char (In_Char);
kono
parents:
diff changeset
788
kono
parents:
diff changeset
789 -------------
kono
parents:
diff changeset
790 -- In_Char --
kono
parents:
diff changeset
791 -------------
kono
parents:
diff changeset
792
kono
parents:
diff changeset
793 function In_Char return Character is
kono
parents:
diff changeset
794 ch : constant Integer := Getc (File);
kono
parents:
diff changeset
795 begin
kono
parents:
diff changeset
796 if ch = EOF then
kono
parents:
diff changeset
797 raise End_Error;
kono
parents:
diff changeset
798 else
kono
parents:
diff changeset
799 return Character'Val (ch);
kono
parents:
diff changeset
800 end if;
kono
parents:
diff changeset
801 end In_Char;
kono
parents:
diff changeset
802
kono
parents:
diff changeset
803 -- Start of processing for Get_Upper_Half_Char
kono
parents:
diff changeset
804
kono
parents:
diff changeset
805 begin
kono
parents:
diff changeset
806 Result := WC_In (C, File.WC_Method);
kono
parents:
diff changeset
807
kono
parents:
diff changeset
808 if Wide_Character'Pos (Result) > 16#FF# then
kono
parents:
diff changeset
809 raise Constraint_Error with
kono
parents:
diff changeset
810 "invalid wide character in Text_'I'O input";
kono
parents:
diff changeset
811 else
kono
parents:
diff changeset
812 return Character'Val (Wide_Character'Pos (Result));
kono
parents:
diff changeset
813 end if;
kono
parents:
diff changeset
814 end Get_Upper_Half_Char;
kono
parents:
diff changeset
815
kono
parents:
diff changeset
816 -------------------------------
kono
parents:
diff changeset
817 -- Get_Upper_Half_Char_Immed --
kono
parents:
diff changeset
818 -------------------------------
kono
parents:
diff changeset
819
kono
parents:
diff changeset
820 function Get_Upper_Half_Char_Immed
kono
parents:
diff changeset
821 (C : Character;
kono
parents:
diff changeset
822 File : File_Type) return Character
kono
parents:
diff changeset
823 is
kono
parents:
diff changeset
824 Result : Wide_Character;
kono
parents:
diff changeset
825
kono
parents:
diff changeset
826 function In_Char return Character;
kono
parents:
diff changeset
827 -- Function used to obtain additional characters it the wide character
kono
parents:
diff changeset
828 -- sequence is more than one character long.
kono
parents:
diff changeset
829
kono
parents:
diff changeset
830 function WC_In is new Char_Sequence_To_Wide_Char (In_Char);
kono
parents:
diff changeset
831
kono
parents:
diff changeset
832 -------------
kono
parents:
diff changeset
833 -- In_Char --
kono
parents:
diff changeset
834 -------------
kono
parents:
diff changeset
835
kono
parents:
diff changeset
836 function In_Char return Character is
kono
parents:
diff changeset
837 ch : constant Integer := Getc_Immed (File);
kono
parents:
diff changeset
838 begin
kono
parents:
diff changeset
839 if ch = EOF then
kono
parents:
diff changeset
840 raise End_Error;
kono
parents:
diff changeset
841 else
kono
parents:
diff changeset
842 return Character'Val (ch);
kono
parents:
diff changeset
843 end if;
kono
parents:
diff changeset
844 end In_Char;
kono
parents:
diff changeset
845
kono
parents:
diff changeset
846 -- Start of processing for Get_Upper_Half_Char_Immed
kono
parents:
diff changeset
847
kono
parents:
diff changeset
848 begin
kono
parents:
diff changeset
849 Result := WC_In (C, File.WC_Method);
kono
parents:
diff changeset
850
kono
parents:
diff changeset
851 if Wide_Character'Pos (Result) > 16#FF# then
kono
parents:
diff changeset
852 raise Constraint_Error with
kono
parents:
diff changeset
853 "invalid wide character in Text_'I'O input";
kono
parents:
diff changeset
854 else
kono
parents:
diff changeset
855 return Character'Val (Wide_Character'Pos (Result));
kono
parents:
diff changeset
856 end if;
kono
parents:
diff changeset
857 end Get_Upper_Half_Char_Immed;
kono
parents:
diff changeset
858
kono
parents:
diff changeset
859 ----------
kono
parents:
diff changeset
860 -- Getc --
kono
parents:
diff changeset
861 ----------
kono
parents:
diff changeset
862
kono
parents:
diff changeset
863 function Getc (File : File_Type) return int is
kono
parents:
diff changeset
864 ch : int;
kono
parents:
diff changeset
865
kono
parents:
diff changeset
866 begin
kono
parents:
diff changeset
867 ch := fgetc (File.Stream);
kono
parents:
diff changeset
868
kono
parents:
diff changeset
869 if ch = EOF and then ferror (File.Stream) /= 0 then
kono
parents:
diff changeset
870 raise Device_Error;
kono
parents:
diff changeset
871 else
kono
parents:
diff changeset
872 return ch;
kono
parents:
diff changeset
873 end if;
kono
parents:
diff changeset
874 end Getc;
kono
parents:
diff changeset
875
kono
parents:
diff changeset
876 ----------------
kono
parents:
diff changeset
877 -- Getc_Immed --
kono
parents:
diff changeset
878 ----------------
kono
parents:
diff changeset
879
kono
parents:
diff changeset
880 function Getc_Immed (File : File_Type) return int is
kono
parents:
diff changeset
881 ch : int;
kono
parents:
diff changeset
882 end_of_file : int;
kono
parents:
diff changeset
883
kono
parents:
diff changeset
884 procedure getc_immediate
kono
parents:
diff changeset
885 (stream : FILEs; ch : out int; end_of_file : out int);
kono
parents:
diff changeset
886 pragma Import (C, getc_immediate, "getc_immediate");
kono
parents:
diff changeset
887
kono
parents:
diff changeset
888 begin
kono
parents:
diff changeset
889 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
890
kono
parents:
diff changeset
891 if File.Before_LM then
kono
parents:
diff changeset
892 File.Before_LM := False;
kono
parents:
diff changeset
893 File.Before_LM_PM := False;
kono
parents:
diff changeset
894 ch := LM;
kono
parents:
diff changeset
895
kono
parents:
diff changeset
896 else
kono
parents:
diff changeset
897 getc_immediate (File.Stream, ch, end_of_file);
kono
parents:
diff changeset
898
kono
parents:
diff changeset
899 if ferror (File.Stream) /= 0 then
kono
parents:
diff changeset
900 raise Device_Error;
kono
parents:
diff changeset
901 elsif end_of_file /= 0 then
kono
parents:
diff changeset
902 return EOF;
kono
parents:
diff changeset
903 end if;
kono
parents:
diff changeset
904 end if;
kono
parents:
diff changeset
905
kono
parents:
diff changeset
906 return ch;
kono
parents:
diff changeset
907 end Getc_Immed;
kono
parents:
diff changeset
908
kono
parents:
diff changeset
909 ------------------------------
kono
parents:
diff changeset
910 -- Has_Upper_Half_Character --
kono
parents:
diff changeset
911 ------------------------------
kono
parents:
diff changeset
912
kono
parents:
diff changeset
913 function Has_Upper_Half_Character (Item : String) return Boolean is
kono
parents:
diff changeset
914 begin
kono
parents:
diff changeset
915 for J in Item'Range loop
kono
parents:
diff changeset
916 if Character'Pos (Item (J)) >= 16#80# then
kono
parents:
diff changeset
917 return True;
kono
parents:
diff changeset
918 end if;
kono
parents:
diff changeset
919 end loop;
kono
parents:
diff changeset
920
kono
parents:
diff changeset
921 return False;
kono
parents:
diff changeset
922 end Has_Upper_Half_Character;
kono
parents:
diff changeset
923
kono
parents:
diff changeset
924 -------------------------------
kono
parents:
diff changeset
925 -- Initialize_Standard_Files --
kono
parents:
diff changeset
926 -------------------------------
kono
parents:
diff changeset
927
kono
parents:
diff changeset
928 procedure Initialize_Standard_Files is
kono
parents:
diff changeset
929 begin
kono
parents:
diff changeset
930 Standard_Err.Stream := stderr;
kono
parents:
diff changeset
931 Standard_Err.Name := Err_Name'Access;
kono
parents:
diff changeset
932 Standard_Err.Form := Null_Str'Unrestricted_Access;
kono
parents:
diff changeset
933 Standard_Err.Mode := FCB.Out_File;
kono
parents:
diff changeset
934 Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0;
kono
parents:
diff changeset
935 Standard_Err.Is_Temporary_File := False;
kono
parents:
diff changeset
936 Standard_Err.Is_System_File := True;
kono
parents:
diff changeset
937 Standard_Err.Text_Encoding := Default_Text;
kono
parents:
diff changeset
938 Standard_Err.Access_Method := 'T';
kono
parents:
diff changeset
939 Standard_Err.Self := Standard_Err;
kono
parents:
diff changeset
940 Standard_Err.WC_Method := Default_WCEM;
kono
parents:
diff changeset
941
kono
parents:
diff changeset
942 Standard_In.Stream := stdin;
kono
parents:
diff changeset
943 Standard_In.Name := In_Name'Access;
kono
parents:
diff changeset
944 Standard_In.Form := Null_Str'Unrestricted_Access;
kono
parents:
diff changeset
945 Standard_In.Mode := FCB.In_File;
kono
parents:
diff changeset
946 Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0;
kono
parents:
diff changeset
947 Standard_In.Is_Temporary_File := False;
kono
parents:
diff changeset
948 Standard_In.Is_System_File := True;
kono
parents:
diff changeset
949 Standard_In.Text_Encoding := Default_Text;
kono
parents:
diff changeset
950 Standard_In.Access_Method := 'T';
kono
parents:
diff changeset
951 Standard_In.Self := Standard_In;
kono
parents:
diff changeset
952 Standard_In.WC_Method := Default_WCEM;
kono
parents:
diff changeset
953
kono
parents:
diff changeset
954 Standard_Out.Stream := stdout;
kono
parents:
diff changeset
955 Standard_Out.Name := Out_Name'Access;
kono
parents:
diff changeset
956 Standard_Out.Form := Null_Str'Unrestricted_Access;
kono
parents:
diff changeset
957 Standard_Out.Mode := FCB.Out_File;
kono
parents:
diff changeset
958 Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0;
kono
parents:
diff changeset
959 Standard_Out.Is_Temporary_File := False;
kono
parents:
diff changeset
960 Standard_Out.Is_System_File := True;
kono
parents:
diff changeset
961 Standard_Out.Text_Encoding := Default_Text;
kono
parents:
diff changeset
962 Standard_Out.Access_Method := 'T';
kono
parents:
diff changeset
963 Standard_Out.Self := Standard_Out;
kono
parents:
diff changeset
964 Standard_Out.WC_Method := Default_WCEM;
kono
parents:
diff changeset
965
kono
parents:
diff changeset
966 FIO.Make_Unbuffered (AP (Standard_Out));
kono
parents:
diff changeset
967 FIO.Make_Unbuffered (AP (Standard_Err));
kono
parents:
diff changeset
968 end Initialize_Standard_Files;
kono
parents:
diff changeset
969
kono
parents:
diff changeset
970 -------------
kono
parents:
diff changeset
971 -- Is_Open --
kono
parents:
diff changeset
972 -------------
kono
parents:
diff changeset
973
kono
parents:
diff changeset
974 function Is_Open (File : File_Type) return Boolean is
kono
parents:
diff changeset
975 begin
kono
parents:
diff changeset
976 return FIO.Is_Open (AP (File));
kono
parents:
diff changeset
977 end Is_Open;
kono
parents:
diff changeset
978
kono
parents:
diff changeset
979 ----------
kono
parents:
diff changeset
980 -- Line --
kono
parents:
diff changeset
981 ----------
kono
parents:
diff changeset
982
kono
parents:
diff changeset
983 -- Note: we assume that it is impossible in practice for the line
kono
parents:
diff changeset
984 -- to exceed the value of Count'Last, i.e. no check is required for
kono
parents:
diff changeset
985 -- overflow raising layout error.
kono
parents:
diff changeset
986
kono
parents:
diff changeset
987 function Line (File : File_Type) return Positive_Count is
kono
parents:
diff changeset
988 begin
kono
parents:
diff changeset
989 FIO.Check_File_Open (AP (File));
kono
parents:
diff changeset
990 return File.Line;
kono
parents:
diff changeset
991 end Line;
kono
parents:
diff changeset
992
kono
parents:
diff changeset
993 function Line return Positive_Count is
kono
parents:
diff changeset
994 begin
kono
parents:
diff changeset
995 return Line (Current_Out);
kono
parents:
diff changeset
996 end Line;
kono
parents:
diff changeset
997
kono
parents:
diff changeset
998 -----------------
kono
parents:
diff changeset
999 -- Line_Length --
kono
parents:
diff changeset
1000 -----------------
kono
parents:
diff changeset
1001
kono
parents:
diff changeset
1002 function Line_Length (File : File_Type) return Count is
kono
parents:
diff changeset
1003 begin
kono
parents:
diff changeset
1004 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1005 return File.Line_Length;
kono
parents:
diff changeset
1006 end Line_Length;
kono
parents:
diff changeset
1007
kono
parents:
diff changeset
1008 function Line_Length return Count is
kono
parents:
diff changeset
1009 begin
kono
parents:
diff changeset
1010 return Line_Length (Current_Out);
kono
parents:
diff changeset
1011 end Line_Length;
kono
parents:
diff changeset
1012
kono
parents:
diff changeset
1013 ----------------
kono
parents:
diff changeset
1014 -- Look_Ahead --
kono
parents:
diff changeset
1015 ----------------
kono
parents:
diff changeset
1016
kono
parents:
diff changeset
1017 procedure Look_Ahead
kono
parents:
diff changeset
1018 (File : File_Type;
kono
parents:
diff changeset
1019 Item : out Character;
kono
parents:
diff changeset
1020 End_Of_Line : out Boolean)
kono
parents:
diff changeset
1021 is
kono
parents:
diff changeset
1022 ch : int;
kono
parents:
diff changeset
1023
kono
parents:
diff changeset
1024 begin
kono
parents:
diff changeset
1025 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
1026
kono
parents:
diff changeset
1027 -- If we are logically before a line mark, we can return immediately
kono
parents:
diff changeset
1028
kono
parents:
diff changeset
1029 if File.Before_LM then
kono
parents:
diff changeset
1030 End_Of_Line := True;
kono
parents:
diff changeset
1031 Item := ASCII.NUL;
kono
parents:
diff changeset
1032
kono
parents:
diff changeset
1033 -- If we are before an upper half character just return it (this can
kono
parents:
diff changeset
1034 -- happen if there are two calls to Look_Ahead in a row).
kono
parents:
diff changeset
1035
kono
parents:
diff changeset
1036 elsif File.Before_Upper_Half_Character then
kono
parents:
diff changeset
1037 End_Of_Line := False;
kono
parents:
diff changeset
1038 Item := File.Saved_Upper_Half_Character;
kono
parents:
diff changeset
1039
kono
parents:
diff changeset
1040 -- Otherwise we must read a character from the input stream
kono
parents:
diff changeset
1041
kono
parents:
diff changeset
1042 else
kono
parents:
diff changeset
1043 ch := Getc (File);
kono
parents:
diff changeset
1044
kono
parents:
diff changeset
1045 if ch = LM
kono
parents:
diff changeset
1046 or else ch = EOF
kono
parents:
diff changeset
1047 or else (ch = PM and then File.Is_Regular_File)
kono
parents:
diff changeset
1048 then
kono
parents:
diff changeset
1049 End_Of_Line := True;
kono
parents:
diff changeset
1050 Ungetc (ch, File);
kono
parents:
diff changeset
1051 Item := ASCII.NUL;
kono
parents:
diff changeset
1052
kono
parents:
diff changeset
1053 -- Case where character obtained does not represent the start of an
kono
parents:
diff changeset
1054 -- encoded sequence so it stands for itself and we can unget it with
kono
parents:
diff changeset
1055 -- no difficulty.
kono
parents:
diff changeset
1056
kono
parents:
diff changeset
1057 elsif not Is_Start_Of_Encoding
kono
parents:
diff changeset
1058 (Character'Val (ch), File.WC_Method)
kono
parents:
diff changeset
1059 then
kono
parents:
diff changeset
1060 End_Of_Line := False;
kono
parents:
diff changeset
1061 Ungetc (ch, File);
kono
parents:
diff changeset
1062 Item := Character'Val (ch);
kono
parents:
diff changeset
1063
kono
parents:
diff changeset
1064 -- For the start of an encoding, we read the character using the
kono
parents:
diff changeset
1065 -- Get_Upper_Half_Char routine. It will occupy more than one byte
kono
parents:
diff changeset
1066 -- so we can't put it back with ungetc. Instead we save it in the
kono
parents:
diff changeset
1067 -- control block, setting a flag that everyone interested in reading
kono
parents:
diff changeset
1068 -- characters must test before reading the stream.
kono
parents:
diff changeset
1069
kono
parents:
diff changeset
1070 else
kono
parents:
diff changeset
1071 Item := Get_Upper_Half_Char (Character'Val (ch), File);
kono
parents:
diff changeset
1072 End_Of_Line := False;
kono
parents:
diff changeset
1073 File.Saved_Upper_Half_Character := Item;
kono
parents:
diff changeset
1074 File.Before_Upper_Half_Character := True;
kono
parents:
diff changeset
1075 end if;
kono
parents:
diff changeset
1076 end if;
kono
parents:
diff changeset
1077 end Look_Ahead;
kono
parents:
diff changeset
1078
kono
parents:
diff changeset
1079 procedure Look_Ahead
kono
parents:
diff changeset
1080 (Item : out Character;
kono
parents:
diff changeset
1081 End_Of_Line : out Boolean)
kono
parents:
diff changeset
1082 is
kono
parents:
diff changeset
1083 begin
kono
parents:
diff changeset
1084 Look_Ahead (Current_In, Item, End_Of_Line);
kono
parents:
diff changeset
1085 end Look_Ahead;
kono
parents:
diff changeset
1086
kono
parents:
diff changeset
1087 ----------
kono
parents:
diff changeset
1088 -- Mode --
kono
parents:
diff changeset
1089 ----------
kono
parents:
diff changeset
1090
kono
parents:
diff changeset
1091 function Mode (File : File_Type) return File_Mode is
kono
parents:
diff changeset
1092 begin
kono
parents:
diff changeset
1093 return To_TIO (FIO.Mode (AP (File)));
kono
parents:
diff changeset
1094 end Mode;
kono
parents:
diff changeset
1095
kono
parents:
diff changeset
1096 ----------
kono
parents:
diff changeset
1097 -- Name --
kono
parents:
diff changeset
1098 ----------
kono
parents:
diff changeset
1099
kono
parents:
diff changeset
1100 function Name (File : File_Type) return String is
kono
parents:
diff changeset
1101 begin
kono
parents:
diff changeset
1102 return FIO.Name (AP (File));
kono
parents:
diff changeset
1103 end Name;
kono
parents:
diff changeset
1104
kono
parents:
diff changeset
1105 --------------
kono
parents:
diff changeset
1106 -- New_Line --
kono
parents:
diff changeset
1107 --------------
kono
parents:
diff changeset
1108
kono
parents:
diff changeset
1109 procedure New_Line
kono
parents:
diff changeset
1110 (File : File_Type;
kono
parents:
diff changeset
1111 Spacing : Positive_Count := 1)
kono
parents:
diff changeset
1112 is
kono
parents:
diff changeset
1113 begin
kono
parents:
diff changeset
1114 -- Raise Constraint_Error if out of range value. The reason for this
kono
parents:
diff changeset
1115 -- explicit test is that we don't want junk values around, even if
kono
parents:
diff changeset
1116 -- checks are off in the caller.
kono
parents:
diff changeset
1117
kono
parents:
diff changeset
1118 if not Spacing'Valid then
kono
parents:
diff changeset
1119 raise Constraint_Error;
kono
parents:
diff changeset
1120 end if;
kono
parents:
diff changeset
1121
kono
parents:
diff changeset
1122 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1123
kono
parents:
diff changeset
1124 for K in 1 .. Spacing loop
kono
parents:
diff changeset
1125 Putc (LM, File);
kono
parents:
diff changeset
1126 File.Line := File.Line + 1;
kono
parents:
diff changeset
1127
kono
parents:
diff changeset
1128 if File.Page_Length /= 0
kono
parents:
diff changeset
1129 and then File.Line > File.Page_Length
kono
parents:
diff changeset
1130 then
kono
parents:
diff changeset
1131 Putc (PM, File);
kono
parents:
diff changeset
1132 File.Line := 1;
kono
parents:
diff changeset
1133 File.Page := File.Page + 1;
kono
parents:
diff changeset
1134 end if;
kono
parents:
diff changeset
1135 end loop;
kono
parents:
diff changeset
1136
kono
parents:
diff changeset
1137 File.Col := 1;
kono
parents:
diff changeset
1138 end New_Line;
kono
parents:
diff changeset
1139
kono
parents:
diff changeset
1140 procedure New_Line (Spacing : Positive_Count := 1) is
kono
parents:
diff changeset
1141 begin
kono
parents:
diff changeset
1142 New_Line (Current_Out, Spacing);
kono
parents:
diff changeset
1143 end New_Line;
kono
parents:
diff changeset
1144
kono
parents:
diff changeset
1145 --------------
kono
parents:
diff changeset
1146 -- New_Page --
kono
parents:
diff changeset
1147 --------------
kono
parents:
diff changeset
1148
kono
parents:
diff changeset
1149 procedure New_Page (File : File_Type) is
kono
parents:
diff changeset
1150 begin
kono
parents:
diff changeset
1151 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1152
kono
parents:
diff changeset
1153 if File.Col /= 1 or else File.Line = 1 then
kono
parents:
diff changeset
1154 Putc (LM, File);
kono
parents:
diff changeset
1155 end if;
kono
parents:
diff changeset
1156
kono
parents:
diff changeset
1157 Putc (PM, File);
kono
parents:
diff changeset
1158 File.Page := File.Page + 1;
kono
parents:
diff changeset
1159 File.Line := 1;
kono
parents:
diff changeset
1160 File.Col := 1;
kono
parents:
diff changeset
1161 end New_Page;
kono
parents:
diff changeset
1162
kono
parents:
diff changeset
1163 procedure New_Page is
kono
parents:
diff changeset
1164 begin
kono
parents:
diff changeset
1165 New_Page (Current_Out);
kono
parents:
diff changeset
1166 end New_Page;
kono
parents:
diff changeset
1167
kono
parents:
diff changeset
1168 -----------
kono
parents:
diff changeset
1169 -- Nextc --
kono
parents:
diff changeset
1170 -----------
kono
parents:
diff changeset
1171
kono
parents:
diff changeset
1172 function Nextc (File : File_Type) return int is
kono
parents:
diff changeset
1173 ch : int;
kono
parents:
diff changeset
1174
kono
parents:
diff changeset
1175 begin
kono
parents:
diff changeset
1176 ch := fgetc (File.Stream);
kono
parents:
diff changeset
1177
kono
parents:
diff changeset
1178 if ch = EOF then
kono
parents:
diff changeset
1179 if ferror (File.Stream) /= 0 then
kono
parents:
diff changeset
1180 raise Device_Error;
kono
parents:
diff changeset
1181 end if;
kono
parents:
diff changeset
1182
kono
parents:
diff changeset
1183 else
kono
parents:
diff changeset
1184 if ungetc (ch, File.Stream) = EOF then
kono
parents:
diff changeset
1185 raise Device_Error;
kono
parents:
diff changeset
1186 end if;
kono
parents:
diff changeset
1187 end if;
kono
parents:
diff changeset
1188
kono
parents:
diff changeset
1189 return ch;
kono
parents:
diff changeset
1190 end Nextc;
kono
parents:
diff changeset
1191
kono
parents:
diff changeset
1192 ----------
kono
parents:
diff changeset
1193 -- Open --
kono
parents:
diff changeset
1194 ----------
kono
parents:
diff changeset
1195
kono
parents:
diff changeset
1196 procedure Open
kono
parents:
diff changeset
1197 (File : in out File_Type;
kono
parents:
diff changeset
1198 Mode : File_Mode;
kono
parents:
diff changeset
1199 Name : String;
kono
parents:
diff changeset
1200 Form : String := "")
kono
parents:
diff changeset
1201 is
kono
parents:
diff changeset
1202 Dummy_File_Control_Block : Text_AFCB;
kono
parents:
diff changeset
1203 pragma Warnings (Off, Dummy_File_Control_Block);
kono
parents:
diff changeset
1204 -- Yes, we know this is never assigned a value, only the tag
kono
parents:
diff changeset
1205 -- is used for dispatching purposes, so that's expected.
kono
parents:
diff changeset
1206
kono
parents:
diff changeset
1207 begin
kono
parents:
diff changeset
1208 FIO.Open (File_Ptr => AP (File),
kono
parents:
diff changeset
1209 Dummy_FCB => Dummy_File_Control_Block,
kono
parents:
diff changeset
1210 Mode => To_FCB (Mode),
kono
parents:
diff changeset
1211 Name => Name,
kono
parents:
diff changeset
1212 Form => Form,
kono
parents:
diff changeset
1213 Amethod => 'T',
kono
parents:
diff changeset
1214 Creat => False,
kono
parents:
diff changeset
1215 Text => True);
kono
parents:
diff changeset
1216
kono
parents:
diff changeset
1217 File.Self := File;
kono
parents:
diff changeset
1218 Set_WCEM (File);
kono
parents:
diff changeset
1219 end Open;
kono
parents:
diff changeset
1220
kono
parents:
diff changeset
1221 ----------
kono
parents:
diff changeset
1222 -- Page --
kono
parents:
diff changeset
1223 ----------
kono
parents:
diff changeset
1224
kono
parents:
diff changeset
1225 -- Note: we assume that it is impossible in practice for the page
kono
parents:
diff changeset
1226 -- to exceed the value of Count'Last, i.e. no check is required for
kono
parents:
diff changeset
1227 -- overflow raising layout error.
kono
parents:
diff changeset
1228
kono
parents:
diff changeset
1229 function Page (File : File_Type) return Positive_Count is
kono
parents:
diff changeset
1230 begin
kono
parents:
diff changeset
1231 FIO.Check_File_Open (AP (File));
kono
parents:
diff changeset
1232 return File.Page;
kono
parents:
diff changeset
1233 end Page;
kono
parents:
diff changeset
1234
kono
parents:
diff changeset
1235 function Page return Positive_Count is
kono
parents:
diff changeset
1236 begin
kono
parents:
diff changeset
1237 return Page (Current_Out);
kono
parents:
diff changeset
1238 end Page;
kono
parents:
diff changeset
1239
kono
parents:
diff changeset
1240 -----------------
kono
parents:
diff changeset
1241 -- Page_Length --
kono
parents:
diff changeset
1242 -----------------
kono
parents:
diff changeset
1243
kono
parents:
diff changeset
1244 function Page_Length (File : File_Type) return Count is
kono
parents:
diff changeset
1245 begin
kono
parents:
diff changeset
1246 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1247 return File.Page_Length;
kono
parents:
diff changeset
1248 end Page_Length;
kono
parents:
diff changeset
1249
kono
parents:
diff changeset
1250 function Page_Length return Count is
kono
parents:
diff changeset
1251 begin
kono
parents:
diff changeset
1252 return Page_Length (Current_Out);
kono
parents:
diff changeset
1253 end Page_Length;
kono
parents:
diff changeset
1254
kono
parents:
diff changeset
1255 ---------
kono
parents:
diff changeset
1256 -- Put --
kono
parents:
diff changeset
1257 ---------
kono
parents:
diff changeset
1258
kono
parents:
diff changeset
1259 procedure Put
kono
parents:
diff changeset
1260 (File : File_Type;
kono
parents:
diff changeset
1261 Item : Character)
kono
parents:
diff changeset
1262 is
kono
parents:
diff changeset
1263 begin
kono
parents:
diff changeset
1264 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1265
kono
parents:
diff changeset
1266 if File.Line_Length /= 0 and then File.Col > File.Line_Length then
kono
parents:
diff changeset
1267 New_Line (File);
kono
parents:
diff changeset
1268 end if;
kono
parents:
diff changeset
1269
kono
parents:
diff changeset
1270 -- If lower half character, or brackets encoding, output directly
kono
parents:
diff changeset
1271
kono
parents:
diff changeset
1272 if Character'Pos (Item) < 16#80#
kono
parents:
diff changeset
1273 or else File.WC_Method = WCEM_Brackets
kono
parents:
diff changeset
1274 then
kono
parents:
diff changeset
1275 if fputc (Character'Pos (Item), File.Stream) = EOF then
kono
parents:
diff changeset
1276 raise Device_Error;
kono
parents:
diff changeset
1277 end if;
kono
parents:
diff changeset
1278
kono
parents:
diff changeset
1279 -- Case of upper half character with non-brackets encoding
kono
parents:
diff changeset
1280
kono
parents:
diff changeset
1281 else
kono
parents:
diff changeset
1282 Put_Encoded (File, Item);
kono
parents:
diff changeset
1283 end if;
kono
parents:
diff changeset
1284
kono
parents:
diff changeset
1285 File.Col := File.Col + 1;
kono
parents:
diff changeset
1286 end Put;
kono
parents:
diff changeset
1287
kono
parents:
diff changeset
1288 procedure Put (Item : Character) is
kono
parents:
diff changeset
1289 begin
kono
parents:
diff changeset
1290 Put (Current_Out, Item);
kono
parents:
diff changeset
1291 end Put;
kono
parents:
diff changeset
1292
kono
parents:
diff changeset
1293 ---------
kono
parents:
diff changeset
1294 -- Put --
kono
parents:
diff changeset
1295 ---------
kono
parents:
diff changeset
1296
kono
parents:
diff changeset
1297 procedure Put
kono
parents:
diff changeset
1298 (File : File_Type;
kono
parents:
diff changeset
1299 Item : String)
kono
parents:
diff changeset
1300 is
kono
parents:
diff changeset
1301 begin
kono
parents:
diff changeset
1302 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1303
kono
parents:
diff changeset
1304 -- Only have something to do if string is non-null
kono
parents:
diff changeset
1305
kono
parents:
diff changeset
1306 if Item'Length > 0 then
kono
parents:
diff changeset
1307
kono
parents:
diff changeset
1308 -- If we have bounded lines, or if the file encoding is other than
kono
parents:
diff changeset
1309 -- Brackets and the string has at least one upper half character,
kono
parents:
diff changeset
1310 -- then output the string character by character.
kono
parents:
diff changeset
1311
kono
parents:
diff changeset
1312 if File.Line_Length /= 0
kono
parents:
diff changeset
1313 or else (File.WC_Method /= WCEM_Brackets
kono
parents:
diff changeset
1314 and then Has_Upper_Half_Character (Item))
kono
parents:
diff changeset
1315 then
kono
parents:
diff changeset
1316 for J in Item'Range loop
kono
parents:
diff changeset
1317 Put (File, Item (J));
kono
parents:
diff changeset
1318 end loop;
kono
parents:
diff changeset
1319
kono
parents:
diff changeset
1320 -- Otherwise we can output the entire string at once. Note that if
kono
parents:
diff changeset
1321 -- there are LF or FF characters in the string, we do not bother to
kono
parents:
diff changeset
1322 -- count them as line or page terminators.
kono
parents:
diff changeset
1323
kono
parents:
diff changeset
1324 else
kono
parents:
diff changeset
1325 FIO.Write_Buf (AP (File), Item'Address, Item'Length);
kono
parents:
diff changeset
1326 File.Col := File.Col + Item'Length;
kono
parents:
diff changeset
1327 end if;
kono
parents:
diff changeset
1328 end if;
kono
parents:
diff changeset
1329 end Put;
kono
parents:
diff changeset
1330
kono
parents:
diff changeset
1331 procedure Put (Item : String) is
kono
parents:
diff changeset
1332 begin
kono
parents:
diff changeset
1333 Put (Current_Out, Item);
kono
parents:
diff changeset
1334 end Put;
kono
parents:
diff changeset
1335
kono
parents:
diff changeset
1336 -----------------
kono
parents:
diff changeset
1337 -- Put_Encoded --
kono
parents:
diff changeset
1338 -----------------
kono
parents:
diff changeset
1339
kono
parents:
diff changeset
1340 procedure Put_Encoded (File : File_Type; Char : Character) is
kono
parents:
diff changeset
1341 procedure Out_Char (C : Character);
kono
parents:
diff changeset
1342 -- Procedure to output one character of an upper half encoded sequence
kono
parents:
diff changeset
1343
kono
parents:
diff changeset
1344 procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char);
kono
parents:
diff changeset
1345
kono
parents:
diff changeset
1346 --------------
kono
parents:
diff changeset
1347 -- Out_Char --
kono
parents:
diff changeset
1348 --------------
kono
parents:
diff changeset
1349
kono
parents:
diff changeset
1350 procedure Out_Char (C : Character) is
kono
parents:
diff changeset
1351 begin
kono
parents:
diff changeset
1352 Putc (Character'Pos (C), File);
kono
parents:
diff changeset
1353 end Out_Char;
kono
parents:
diff changeset
1354
kono
parents:
diff changeset
1355 -- Start of processing for Put_Encoded
kono
parents:
diff changeset
1356
kono
parents:
diff changeset
1357 begin
kono
parents:
diff changeset
1358 WC_Out (Wide_Character'Val (Character'Pos (Char)), File.WC_Method);
kono
parents:
diff changeset
1359 end Put_Encoded;
kono
parents:
diff changeset
1360
kono
parents:
diff changeset
1361 --------------
kono
parents:
diff changeset
1362 -- Put_Line --
kono
parents:
diff changeset
1363 --------------
kono
parents:
diff changeset
1364
kono
parents:
diff changeset
1365 procedure Put_Line
kono
parents:
diff changeset
1366 (File : File_Type;
kono
parents:
diff changeset
1367 Item : String)
kono
parents:
diff changeset
1368 is
kono
parents:
diff changeset
1369 Ilen : Natural := Item'Length;
kono
parents:
diff changeset
1370 Istart : Natural := Item'First;
kono
parents:
diff changeset
1371
kono
parents:
diff changeset
1372 begin
kono
parents:
diff changeset
1373 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1374
kono
parents:
diff changeset
1375 -- If we have bounded lines, or if the file encoding is other than
kono
parents:
diff changeset
1376 -- Brackets and the string has at least one upper half character, then
kono
parents:
diff changeset
1377 -- output the string character by character.
kono
parents:
diff changeset
1378
kono
parents:
diff changeset
1379 if File.Line_Length /= 0
kono
parents:
diff changeset
1380 or else (File.WC_Method /= WCEM_Brackets
kono
parents:
diff changeset
1381 and then Has_Upper_Half_Character (Item))
kono
parents:
diff changeset
1382 then
kono
parents:
diff changeset
1383 for J in Item'Range loop
kono
parents:
diff changeset
1384 Put (File, Item (J));
kono
parents:
diff changeset
1385 end loop;
kono
parents:
diff changeset
1386
kono
parents:
diff changeset
1387 New_Line (File);
kono
parents:
diff changeset
1388 return;
kono
parents:
diff changeset
1389 end if;
kono
parents:
diff changeset
1390
kono
parents:
diff changeset
1391 -- Normal case where we do not need to output character by character
kono
parents:
diff changeset
1392
kono
parents:
diff changeset
1393 -- We setup a single string that has the necessary terminators and
kono
parents:
diff changeset
1394 -- then write it with a single call. The reason for doing this is
kono
parents:
diff changeset
1395 -- that it gives better behavior for the use of Put_Line in multi-
kono
parents:
diff changeset
1396 -- tasking programs, since often the OS will treat the entire put
kono
parents:
diff changeset
1397 -- operation as an atomic operation.
kono
parents:
diff changeset
1398
kono
parents:
diff changeset
1399 -- We only do this if the message is 512 characters or less in length,
kono
parents:
diff changeset
1400 -- since otherwise Put_Line would use an unbounded amount of stack
kono
parents:
diff changeset
1401 -- space and could cause undetected stack overflow. If we have a
kono
parents:
diff changeset
1402 -- longer string, then output the first part separately to avoid this.
kono
parents:
diff changeset
1403
kono
parents:
diff changeset
1404 if Ilen > 512 then
kono
parents:
diff changeset
1405 FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512));
kono
parents:
diff changeset
1406 Istart := Istart + Ilen - 512;
kono
parents:
diff changeset
1407 Ilen := 512;
kono
parents:
diff changeset
1408 end if;
kono
parents:
diff changeset
1409
kono
parents:
diff changeset
1410 -- Now prepare the string with its terminator
kono
parents:
diff changeset
1411
kono
parents:
diff changeset
1412 declare
kono
parents:
diff changeset
1413 Buffer : String (1 .. Ilen + 2);
kono
parents:
diff changeset
1414 Plen : size_t;
kono
parents:
diff changeset
1415
kono
parents:
diff changeset
1416 begin
kono
parents:
diff changeset
1417 Buffer (1 .. Ilen) := Item (Istart .. Item'Last);
kono
parents:
diff changeset
1418 Buffer (Ilen + 1) := Character'Val (LM);
kono
parents:
diff changeset
1419
kono
parents:
diff changeset
1420 if File.Page_Length /= 0
kono
parents:
diff changeset
1421 and then File.Line > File.Page_Length
kono
parents:
diff changeset
1422 then
kono
parents:
diff changeset
1423 Buffer (Ilen + 2) := Character'Val (PM);
kono
parents:
diff changeset
1424 Plen := size_t (Ilen) + 2;
kono
parents:
diff changeset
1425 File.Line := 1;
kono
parents:
diff changeset
1426 File.Page := File.Page + 1;
kono
parents:
diff changeset
1427
kono
parents:
diff changeset
1428 else
kono
parents:
diff changeset
1429 Plen := size_t (Ilen) + 1;
kono
parents:
diff changeset
1430 File.Line := File.Line + 1;
kono
parents:
diff changeset
1431 end if;
kono
parents:
diff changeset
1432
kono
parents:
diff changeset
1433 FIO.Write_Buf (AP (File), Buffer'Address, Plen);
kono
parents:
diff changeset
1434
kono
parents:
diff changeset
1435 File.Col := 1;
kono
parents:
diff changeset
1436 end;
kono
parents:
diff changeset
1437 end Put_Line;
kono
parents:
diff changeset
1438
kono
parents:
diff changeset
1439 procedure Put_Line (Item : String) is
kono
parents:
diff changeset
1440 begin
kono
parents:
diff changeset
1441 Put_Line (Current_Out, Item);
kono
parents:
diff changeset
1442 end Put_Line;
kono
parents:
diff changeset
1443
kono
parents:
diff changeset
1444 ----------
kono
parents:
diff changeset
1445 -- Putc --
kono
parents:
diff changeset
1446 ----------
kono
parents:
diff changeset
1447
kono
parents:
diff changeset
1448 procedure Putc (ch : int; File : File_Type) is
kono
parents:
diff changeset
1449 begin
kono
parents:
diff changeset
1450 if fputc (ch, File.Stream) = EOF then
kono
parents:
diff changeset
1451 raise Device_Error;
kono
parents:
diff changeset
1452 end if;
kono
parents:
diff changeset
1453 end Putc;
kono
parents:
diff changeset
1454
kono
parents:
diff changeset
1455 ----------
kono
parents:
diff changeset
1456 -- Read --
kono
parents:
diff changeset
1457 ----------
kono
parents:
diff changeset
1458
kono
parents:
diff changeset
1459 -- This is the primitive Stream Read routine, used when a Text_IO file
kono
parents:
diff changeset
1460 -- is treated directly as a stream using Text_IO.Streams.Stream.
kono
parents:
diff changeset
1461
kono
parents:
diff changeset
1462 procedure Read
kono
parents:
diff changeset
1463 (File : in out Text_AFCB;
kono
parents:
diff changeset
1464 Item : out Stream_Element_Array;
kono
parents:
diff changeset
1465 Last : out Stream_Element_Offset)
kono
parents:
diff changeset
1466 is
kono
parents:
diff changeset
1467 Discard_ch : int;
kono
parents:
diff changeset
1468 pragma Warnings (Off, Discard_ch);
kono
parents:
diff changeset
1469
kono
parents:
diff changeset
1470 begin
kono
parents:
diff changeset
1471 -- Need to deal with Before_Upper_Half_Character ???
kono
parents:
diff changeset
1472
kono
parents:
diff changeset
1473 if File.Mode /= FCB.In_File then
kono
parents:
diff changeset
1474 raise Mode_Error;
kono
parents:
diff changeset
1475 end if;
kono
parents:
diff changeset
1476
kono
parents:
diff changeset
1477 -- Deal with case where our logical and physical position do not match
kono
parents:
diff changeset
1478 -- because of being after an LM or LM-PM sequence when in fact we are
kono
parents:
diff changeset
1479 -- logically positioned before it.
kono
parents:
diff changeset
1480
kono
parents:
diff changeset
1481 if File.Before_LM then
kono
parents:
diff changeset
1482
kono
parents:
diff changeset
1483 -- If we are before a PM, then it is possible for a stream read
kono
parents:
diff changeset
1484 -- to leave us after the LM and before the PM, which is a bit
kono
parents:
diff changeset
1485 -- odd. The easiest way to deal with this is to unget the PM,
kono
parents:
diff changeset
1486 -- so we are indeed positioned between the characters. This way
kono
parents:
diff changeset
1487 -- further stream read operations will work correctly, and the
kono
parents:
diff changeset
1488 -- effect on text processing is a little weird, but what can
kono
parents:
diff changeset
1489 -- be expected if stream and text input are mixed this way?
kono
parents:
diff changeset
1490
kono
parents:
diff changeset
1491 if File.Before_LM_PM then
kono
parents:
diff changeset
1492 Discard_ch := ungetc (PM, File.Stream);
kono
parents:
diff changeset
1493 File.Before_LM_PM := False;
kono
parents:
diff changeset
1494 end if;
kono
parents:
diff changeset
1495
kono
parents:
diff changeset
1496 File.Before_LM := False;
kono
parents:
diff changeset
1497
kono
parents:
diff changeset
1498 Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF));
kono
parents:
diff changeset
1499
kono
parents:
diff changeset
1500 if Item'Length = 1 then
kono
parents:
diff changeset
1501 Last := Item'Last;
kono
parents:
diff changeset
1502
kono
parents:
diff changeset
1503 else
kono
parents:
diff changeset
1504 Last :=
kono
parents:
diff changeset
1505 Item'First +
kono
parents:
diff changeset
1506 Stream_Element_Offset
kono
parents:
diff changeset
1507 (fread (buffer => Item'Address,
kono
parents:
diff changeset
1508 index => size_t (Item'First + 1),
kono
parents:
diff changeset
1509 size => 1,
kono
parents:
diff changeset
1510 count => Item'Length - 1,
kono
parents:
diff changeset
1511 stream => File.Stream));
kono
parents:
diff changeset
1512 end if;
kono
parents:
diff changeset
1513
kono
parents:
diff changeset
1514 return;
kono
parents:
diff changeset
1515 end if;
kono
parents:
diff changeset
1516
kono
parents:
diff changeset
1517 -- Now we do the read. Since this is a text file, it is normally in
kono
parents:
diff changeset
1518 -- text mode, but stream data must be read in binary mode, so we
kono
parents:
diff changeset
1519 -- temporarily set binary mode for the read, resetting it after.
kono
parents:
diff changeset
1520 -- These calls have no effect in a system (like Unix) where there is
kono
parents:
diff changeset
1521 -- no distinction between text and binary files.
kono
parents:
diff changeset
1522
kono
parents:
diff changeset
1523 set_binary_mode (fileno (File.Stream));
kono
parents:
diff changeset
1524
kono
parents:
diff changeset
1525 Last :=
kono
parents:
diff changeset
1526 Item'First +
kono
parents:
diff changeset
1527 Stream_Element_Offset
kono
parents:
diff changeset
1528 (fread (Item'Address, 1, Item'Length, File.Stream)) - 1;
kono
parents:
diff changeset
1529
kono
parents:
diff changeset
1530 if Last < Item'Last then
kono
parents:
diff changeset
1531 if ferror (File.Stream) /= 0 then
kono
parents:
diff changeset
1532 raise Device_Error;
kono
parents:
diff changeset
1533 end if;
kono
parents:
diff changeset
1534 end if;
kono
parents:
diff changeset
1535
kono
parents:
diff changeset
1536 set_text_mode (fileno (File.Stream));
kono
parents:
diff changeset
1537 end Read;
kono
parents:
diff changeset
1538
kono
parents:
diff changeset
1539 -----------
kono
parents:
diff changeset
1540 -- Reset --
kono
parents:
diff changeset
1541 -----------
kono
parents:
diff changeset
1542
kono
parents:
diff changeset
1543 procedure Reset
kono
parents:
diff changeset
1544 (File : in out File_Type;
kono
parents:
diff changeset
1545 Mode : File_Mode)
kono
parents:
diff changeset
1546 is
kono
parents:
diff changeset
1547 begin
kono
parents:
diff changeset
1548 -- Don't allow change of mode for current file (RM A.10.2(5))
kono
parents:
diff changeset
1549
kono
parents:
diff changeset
1550 if (File = Current_In or else
kono
parents:
diff changeset
1551 File = Current_Out or else
kono
parents:
diff changeset
1552 File = Current_Error)
kono
parents:
diff changeset
1553 and then To_FCB (Mode) /= File.Mode
kono
parents:
diff changeset
1554 then
kono
parents:
diff changeset
1555 raise Mode_Error;
kono
parents:
diff changeset
1556 end if;
kono
parents:
diff changeset
1557
kono
parents:
diff changeset
1558 Terminate_Line (File);
kono
parents:
diff changeset
1559 FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode));
kono
parents:
diff changeset
1560 File.Page := 1;
kono
parents:
diff changeset
1561 File.Line := 1;
kono
parents:
diff changeset
1562 File.Col := 1;
kono
parents:
diff changeset
1563 File.Line_Length := 0;
kono
parents:
diff changeset
1564 File.Page_Length := 0;
kono
parents:
diff changeset
1565 File.Before_LM := False;
kono
parents:
diff changeset
1566 File.Before_LM_PM := False;
kono
parents:
diff changeset
1567 end Reset;
kono
parents:
diff changeset
1568
kono
parents:
diff changeset
1569 procedure Reset (File : in out File_Type) is
kono
parents:
diff changeset
1570 begin
kono
parents:
diff changeset
1571 Terminate_Line (File);
kono
parents:
diff changeset
1572 FIO.Reset (AP (File)'Unrestricted_Access);
kono
parents:
diff changeset
1573 File.Page := 1;
kono
parents:
diff changeset
1574 File.Line := 1;
kono
parents:
diff changeset
1575 File.Col := 1;
kono
parents:
diff changeset
1576 File.Line_Length := 0;
kono
parents:
diff changeset
1577 File.Page_Length := 0;
kono
parents:
diff changeset
1578 File.Before_LM := False;
kono
parents:
diff changeset
1579 File.Before_LM_PM := False;
kono
parents:
diff changeset
1580 end Reset;
kono
parents:
diff changeset
1581
kono
parents:
diff changeset
1582 -------------
kono
parents:
diff changeset
1583 -- Set_Col --
kono
parents:
diff changeset
1584 -------------
kono
parents:
diff changeset
1585
kono
parents:
diff changeset
1586 procedure Set_Col
kono
parents:
diff changeset
1587 (File : File_Type;
kono
parents:
diff changeset
1588 To : Positive_Count)
kono
parents:
diff changeset
1589 is
kono
parents:
diff changeset
1590 ch : int;
kono
parents:
diff changeset
1591
kono
parents:
diff changeset
1592 begin
kono
parents:
diff changeset
1593 -- Raise Constraint_Error if out of range value. The reason for this
kono
parents:
diff changeset
1594 -- explicit test is that we don't want junk values around, even if
kono
parents:
diff changeset
1595 -- checks are off in the caller.
kono
parents:
diff changeset
1596
kono
parents:
diff changeset
1597 if not To'Valid then
kono
parents:
diff changeset
1598 raise Constraint_Error;
kono
parents:
diff changeset
1599 end if;
kono
parents:
diff changeset
1600
kono
parents:
diff changeset
1601 FIO.Check_File_Open (AP (File));
kono
parents:
diff changeset
1602
kono
parents:
diff changeset
1603 -- Output case
kono
parents:
diff changeset
1604
kono
parents:
diff changeset
1605 if Mode (File) >= Out_File then
kono
parents:
diff changeset
1606
kono
parents:
diff changeset
1607 -- Error if we attempt to set Col to a value greater than the
kono
parents:
diff changeset
1608 -- maximum permissible line length.
kono
parents:
diff changeset
1609
kono
parents:
diff changeset
1610 if File.Line_Length /= 0 and then To > File.Line_Length then
kono
parents:
diff changeset
1611 raise Layout_Error;
kono
parents:
diff changeset
1612 end if;
kono
parents:
diff changeset
1613
kono
parents:
diff changeset
1614 -- If we are behind current position, then go to start of new line
kono
parents:
diff changeset
1615
kono
parents:
diff changeset
1616 if To < File.Col then
kono
parents:
diff changeset
1617 New_Line (File);
kono
parents:
diff changeset
1618 end if;
kono
parents:
diff changeset
1619
kono
parents:
diff changeset
1620 -- Loop to output blanks till we are at the required column
kono
parents:
diff changeset
1621
kono
parents:
diff changeset
1622 while File.Col < To loop
kono
parents:
diff changeset
1623 Put (File, ' ');
kono
parents:
diff changeset
1624 end loop;
kono
parents:
diff changeset
1625
kono
parents:
diff changeset
1626 -- Input case
kono
parents:
diff changeset
1627
kono
parents:
diff changeset
1628 else
kono
parents:
diff changeset
1629 -- If we are logically before a LM, but physically after it, the
kono
parents:
diff changeset
1630 -- file position still reflects the position before the LM, so eat
kono
parents:
diff changeset
1631 -- it now and adjust the file position appropriately.
kono
parents:
diff changeset
1632
kono
parents:
diff changeset
1633 if File.Before_LM then
kono
parents:
diff changeset
1634 File.Before_LM := False;
kono
parents:
diff changeset
1635 File.Before_LM_PM := False;
kono
parents:
diff changeset
1636 File.Line := File.Line + 1;
kono
parents:
diff changeset
1637 File.Col := 1;
kono
parents:
diff changeset
1638 end if;
kono
parents:
diff changeset
1639
kono
parents:
diff changeset
1640 -- Loop reading characters till we get one at the required Col value
kono
parents:
diff changeset
1641
kono
parents:
diff changeset
1642 loop
kono
parents:
diff changeset
1643 -- Read next character. The reason we have to read ahead is to
kono
parents:
diff changeset
1644 -- skip formatting characters, the effect of Set_Col is to set
kono
parents:
diff changeset
1645 -- us to a real character with the right Col value, and format
kono
parents:
diff changeset
1646 -- characters don't count.
kono
parents:
diff changeset
1647
kono
parents:
diff changeset
1648 ch := Getc (File);
kono
parents:
diff changeset
1649
kono
parents:
diff changeset
1650 -- Error if we hit an end of file
kono
parents:
diff changeset
1651
kono
parents:
diff changeset
1652 if ch = EOF then
kono
parents:
diff changeset
1653 raise End_Error;
kono
parents:
diff changeset
1654
kono
parents:
diff changeset
1655 -- If line mark, eat it and adjust file position
kono
parents:
diff changeset
1656
kono
parents:
diff changeset
1657 elsif ch = LM then
kono
parents:
diff changeset
1658 File.Line := File.Line + 1;
kono
parents:
diff changeset
1659 File.Col := 1;
kono
parents:
diff changeset
1660
kono
parents:
diff changeset
1661 -- If recognized page mark, eat it, and adjust file position
kono
parents:
diff changeset
1662
kono
parents:
diff changeset
1663 elsif ch = PM and then File.Is_Regular_File then
kono
parents:
diff changeset
1664 File.Page := File.Page + 1;
kono
parents:
diff changeset
1665 File.Line := 1;
kono
parents:
diff changeset
1666 File.Col := 1;
kono
parents:
diff changeset
1667
kono
parents:
diff changeset
1668 -- Otherwise this is the character we are looking for, so put it
kono
parents:
diff changeset
1669 -- back in the input stream (we have not adjusted the file
kono
parents:
diff changeset
1670 -- position yet, so everything is set right after this ungetc).
kono
parents:
diff changeset
1671
kono
parents:
diff changeset
1672 elsif To = File.Col then
kono
parents:
diff changeset
1673 Ungetc (ch, File);
kono
parents:
diff changeset
1674 return;
kono
parents:
diff changeset
1675
kono
parents:
diff changeset
1676 -- Keep skipping characters if we are not there yet, updating the
kono
parents:
diff changeset
1677 -- file position past the skipped character.
kono
parents:
diff changeset
1678
kono
parents:
diff changeset
1679 else
kono
parents:
diff changeset
1680 File.Col := File.Col + 1;
kono
parents:
diff changeset
1681 end if;
kono
parents:
diff changeset
1682 end loop;
kono
parents:
diff changeset
1683 end if;
kono
parents:
diff changeset
1684 end Set_Col;
kono
parents:
diff changeset
1685
kono
parents:
diff changeset
1686 procedure Set_Col (To : Positive_Count) is
kono
parents:
diff changeset
1687 begin
kono
parents:
diff changeset
1688 Set_Col (Current_Out, To);
kono
parents:
diff changeset
1689 end Set_Col;
kono
parents:
diff changeset
1690
kono
parents:
diff changeset
1691 ---------------
kono
parents:
diff changeset
1692 -- Set_Error --
kono
parents:
diff changeset
1693 ---------------
kono
parents:
diff changeset
1694
kono
parents:
diff changeset
1695 procedure Set_Error (File : File_Type) is
kono
parents:
diff changeset
1696 begin
kono
parents:
diff changeset
1697 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1698 Current_Err := File;
kono
parents:
diff changeset
1699 end Set_Error;
kono
parents:
diff changeset
1700
kono
parents:
diff changeset
1701 ---------------
kono
parents:
diff changeset
1702 -- Set_Input --
kono
parents:
diff changeset
1703 ---------------
kono
parents:
diff changeset
1704
kono
parents:
diff changeset
1705 procedure Set_Input (File : File_Type) is
kono
parents:
diff changeset
1706 begin
kono
parents:
diff changeset
1707 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
1708 Current_In := File;
kono
parents:
diff changeset
1709 end Set_Input;
kono
parents:
diff changeset
1710
kono
parents:
diff changeset
1711 --------------
kono
parents:
diff changeset
1712 -- Set_Line --
kono
parents:
diff changeset
1713 --------------
kono
parents:
diff changeset
1714
kono
parents:
diff changeset
1715 procedure Set_Line
kono
parents:
diff changeset
1716 (File : File_Type;
kono
parents:
diff changeset
1717 To : Positive_Count)
kono
parents:
diff changeset
1718 is
kono
parents:
diff changeset
1719 begin
kono
parents:
diff changeset
1720 -- Raise Constraint_Error if out of range value. The reason for this
kono
parents:
diff changeset
1721 -- explicit test is that we don't want junk values around, even if
kono
parents:
diff changeset
1722 -- checks are off in the caller.
kono
parents:
diff changeset
1723
kono
parents:
diff changeset
1724 if not To'Valid then
kono
parents:
diff changeset
1725 raise Constraint_Error;
kono
parents:
diff changeset
1726 end if;
kono
parents:
diff changeset
1727
kono
parents:
diff changeset
1728 FIO.Check_File_Open (AP (File));
kono
parents:
diff changeset
1729
kono
parents:
diff changeset
1730 if To = File.Line then
kono
parents:
diff changeset
1731 return;
kono
parents:
diff changeset
1732 end if;
kono
parents:
diff changeset
1733
kono
parents:
diff changeset
1734 if Mode (File) >= Out_File then
kono
parents:
diff changeset
1735 if File.Page_Length /= 0 and then To > File.Page_Length then
kono
parents:
diff changeset
1736 raise Layout_Error;
kono
parents:
diff changeset
1737 end if;
kono
parents:
diff changeset
1738
kono
parents:
diff changeset
1739 if To < File.Line then
kono
parents:
diff changeset
1740 New_Page (File);
kono
parents:
diff changeset
1741 end if;
kono
parents:
diff changeset
1742
kono
parents:
diff changeset
1743 while File.Line < To loop
kono
parents:
diff changeset
1744 New_Line (File);
kono
parents:
diff changeset
1745 end loop;
kono
parents:
diff changeset
1746
kono
parents:
diff changeset
1747 else
kono
parents:
diff changeset
1748 while To /= File.Line loop
kono
parents:
diff changeset
1749 Skip_Line (File);
kono
parents:
diff changeset
1750 end loop;
kono
parents:
diff changeset
1751 end if;
kono
parents:
diff changeset
1752 end Set_Line;
kono
parents:
diff changeset
1753
kono
parents:
diff changeset
1754 procedure Set_Line (To : Positive_Count) is
kono
parents:
diff changeset
1755 begin
kono
parents:
diff changeset
1756 Set_Line (Current_Out, To);
kono
parents:
diff changeset
1757 end Set_Line;
kono
parents:
diff changeset
1758
kono
parents:
diff changeset
1759 ---------------------
kono
parents:
diff changeset
1760 -- Set_Line_Length --
kono
parents:
diff changeset
1761 ---------------------
kono
parents:
diff changeset
1762
kono
parents:
diff changeset
1763 procedure Set_Line_Length (File : File_Type; To : Count) is
kono
parents:
diff changeset
1764 begin
kono
parents:
diff changeset
1765 -- Raise Constraint_Error if out of range value. The reason for this
kono
parents:
diff changeset
1766 -- explicit test is that we don't want junk values around, even if
kono
parents:
diff changeset
1767 -- checks are off in the caller.
kono
parents:
diff changeset
1768
kono
parents:
diff changeset
1769 if not To'Valid then
kono
parents:
diff changeset
1770 raise Constraint_Error;
kono
parents:
diff changeset
1771 end if;
kono
parents:
diff changeset
1772
kono
parents:
diff changeset
1773 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1774 File.Line_Length := To;
kono
parents:
diff changeset
1775 end Set_Line_Length;
kono
parents:
diff changeset
1776
kono
parents:
diff changeset
1777 procedure Set_Line_Length (To : Count) is
kono
parents:
diff changeset
1778 begin
kono
parents:
diff changeset
1779 Set_Line_Length (Current_Out, To);
kono
parents:
diff changeset
1780 end Set_Line_Length;
kono
parents:
diff changeset
1781
kono
parents:
diff changeset
1782 ----------------
kono
parents:
diff changeset
1783 -- Set_Output --
kono
parents:
diff changeset
1784 ----------------
kono
parents:
diff changeset
1785
kono
parents:
diff changeset
1786 procedure Set_Output (File : File_Type) is
kono
parents:
diff changeset
1787 begin
kono
parents:
diff changeset
1788 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1789 Current_Out := File;
kono
parents:
diff changeset
1790 end Set_Output;
kono
parents:
diff changeset
1791
kono
parents:
diff changeset
1792 ---------------------
kono
parents:
diff changeset
1793 -- Set_Page_Length --
kono
parents:
diff changeset
1794 ---------------------
kono
parents:
diff changeset
1795
kono
parents:
diff changeset
1796 procedure Set_Page_Length (File : File_Type; To : Count) is
kono
parents:
diff changeset
1797 begin
kono
parents:
diff changeset
1798 -- Raise Constraint_Error if out of range value. The reason for this
kono
parents:
diff changeset
1799 -- explicit test is that we don't want junk values around, even if
kono
parents:
diff changeset
1800 -- checks are off in the caller.
kono
parents:
diff changeset
1801
kono
parents:
diff changeset
1802 if not To'Valid then
kono
parents:
diff changeset
1803 raise Constraint_Error;
kono
parents:
diff changeset
1804 end if;
kono
parents:
diff changeset
1805
kono
parents:
diff changeset
1806 FIO.Check_Write_Status (AP (File));
kono
parents:
diff changeset
1807 File.Page_Length := To;
kono
parents:
diff changeset
1808 end Set_Page_Length;
kono
parents:
diff changeset
1809
kono
parents:
diff changeset
1810 procedure Set_Page_Length (To : Count) is
kono
parents:
diff changeset
1811 begin
kono
parents:
diff changeset
1812 Set_Page_Length (Current_Out, To);
kono
parents:
diff changeset
1813 end Set_Page_Length;
kono
parents:
diff changeset
1814
kono
parents:
diff changeset
1815 --------------
kono
parents:
diff changeset
1816 -- Set_WCEM --
kono
parents:
diff changeset
1817 --------------
kono
parents:
diff changeset
1818
kono
parents:
diff changeset
1819 procedure Set_WCEM (File : in out File_Type) is
kono
parents:
diff changeset
1820 Start : Natural;
kono
parents:
diff changeset
1821 Stop : Natural;
kono
parents:
diff changeset
1822
kono
parents:
diff changeset
1823 begin
kono
parents:
diff changeset
1824 FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop);
kono
parents:
diff changeset
1825
kono
parents:
diff changeset
1826 if Start = 0 then
kono
parents:
diff changeset
1827 File.WC_Method := Default_WCEM;
kono
parents:
diff changeset
1828
kono
parents:
diff changeset
1829 else
kono
parents:
diff changeset
1830 if Stop = Start then
kono
parents:
diff changeset
1831 for J in WC_Encoding_Letters'Range loop
kono
parents:
diff changeset
1832 if File.Form (Start) = WC_Encoding_Letters (J) then
kono
parents:
diff changeset
1833 File.WC_Method := J;
kono
parents:
diff changeset
1834 return;
kono
parents:
diff changeset
1835 end if;
kono
parents:
diff changeset
1836 end loop;
kono
parents:
diff changeset
1837 end if;
kono
parents:
diff changeset
1838
kono
parents:
diff changeset
1839 Close (File);
kono
parents:
diff changeset
1840 raise Use_Error with "invalid WCEM form parameter";
kono
parents:
diff changeset
1841 end if;
kono
parents:
diff changeset
1842 end Set_WCEM;
kono
parents:
diff changeset
1843
kono
parents:
diff changeset
1844 ---------------
kono
parents:
diff changeset
1845 -- Skip_Line --
kono
parents:
diff changeset
1846 ---------------
kono
parents:
diff changeset
1847
kono
parents:
diff changeset
1848 procedure Skip_Line
kono
parents:
diff changeset
1849 (File : File_Type;
kono
parents:
diff changeset
1850 Spacing : Positive_Count := 1)
kono
parents:
diff changeset
1851 is
kono
parents:
diff changeset
1852 ch : int;
kono
parents:
diff changeset
1853
kono
parents:
diff changeset
1854 begin
kono
parents:
diff changeset
1855 -- Raise Constraint_Error if out of range value. The reason for this
kono
parents:
diff changeset
1856 -- explicit test is that we don't want junk values around, even if
kono
parents:
diff changeset
1857 -- checks are off in the caller.
kono
parents:
diff changeset
1858
kono
parents:
diff changeset
1859 if not Spacing'Valid then
kono
parents:
diff changeset
1860 raise Constraint_Error;
kono
parents:
diff changeset
1861 end if;
kono
parents:
diff changeset
1862
kono
parents:
diff changeset
1863 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
1864
kono
parents:
diff changeset
1865 for L in 1 .. Spacing loop
kono
parents:
diff changeset
1866 if File.Before_LM then
kono
parents:
diff changeset
1867 File.Before_LM := False;
kono
parents:
diff changeset
1868
kono
parents:
diff changeset
1869 -- Note that if File.Before_LM_PM is currently set, we also have
kono
parents:
diff changeset
1870 -- to reset it (because it makes sense for Before_LM_PM to be set
kono
parents:
diff changeset
1871 -- only when Before_LM is also set). This is done later on in this
kono
parents:
diff changeset
1872 -- subprogram, as soon as Before_LM_PM has been taken into account
kono
parents:
diff changeset
1873 -- for the purpose of page and line counts.
kono
parents:
diff changeset
1874
kono
parents:
diff changeset
1875 else
kono
parents:
diff changeset
1876 ch := Getc (File);
kono
parents:
diff changeset
1877
kono
parents:
diff changeset
1878 -- If at end of file now, then immediately raise End_Error. Note
kono
parents:
diff changeset
1879 -- that we can never be positioned between a line mark and a page
kono
parents:
diff changeset
1880 -- mark, so if we are at the end of file, we cannot logically be
kono
parents:
diff changeset
1881 -- before the implicit page mark that is at the end of the file.
kono
parents:
diff changeset
1882
kono
parents:
diff changeset
1883 -- For the same reason, we do not need an explicit check for a
kono
parents:
diff changeset
1884 -- page mark. If there is a FF in the middle of a line, the file
kono
parents:
diff changeset
1885 -- is not in canonical format and we do not care about the page
kono
parents:
diff changeset
1886 -- numbers for files other than ones in canonical format.
kono
parents:
diff changeset
1887
kono
parents:
diff changeset
1888 if ch = EOF then
kono
parents:
diff changeset
1889 raise End_Error;
kono
parents:
diff changeset
1890 end if;
kono
parents:
diff changeset
1891
kono
parents:
diff changeset
1892 -- If not at end of file, then loop till we get to an LM or EOF.
kono
parents:
diff changeset
1893 -- The latter case happens only in non-canonical files where the
kono
parents:
diff changeset
1894 -- last line is not terminated by LM, but we don't want to blow
kono
parents:
diff changeset
1895 -- up for such files, so we assume an implicit LM in this case.
kono
parents:
diff changeset
1896
kono
parents:
diff changeset
1897 loop
kono
parents:
diff changeset
1898 exit when ch = LM or else ch = EOF;
kono
parents:
diff changeset
1899 ch := Getc (File);
kono
parents:
diff changeset
1900 end loop;
kono
parents:
diff changeset
1901 end if;
kono
parents:
diff changeset
1902
kono
parents:
diff changeset
1903 -- We have got past a line mark, now, for a regular file only,
kono
parents:
diff changeset
1904 -- see if a page mark immediately follows this line mark and
kono
parents:
diff changeset
1905 -- if so, skip past the page mark as well. We do not do this
kono
parents:
diff changeset
1906 -- for non-regular files, since it would cause an undesirable
kono
parents:
diff changeset
1907 -- wait for an additional character.
kono
parents:
diff changeset
1908
kono
parents:
diff changeset
1909 File.Col := 1;
kono
parents:
diff changeset
1910 File.Line := File.Line + 1;
kono
parents:
diff changeset
1911
kono
parents:
diff changeset
1912 if File.Before_LM_PM then
kono
parents:
diff changeset
1913 File.Page := File.Page + 1;
kono
parents:
diff changeset
1914 File.Line := 1;
kono
parents:
diff changeset
1915 File.Before_LM_PM := False;
kono
parents:
diff changeset
1916
kono
parents:
diff changeset
1917 elsif File.Is_Regular_File then
kono
parents:
diff changeset
1918 ch := Getc (File);
kono
parents:
diff changeset
1919
kono
parents:
diff changeset
1920 -- Page mark can be explicit, or implied at the end of the file
kono
parents:
diff changeset
1921
kono
parents:
diff changeset
1922 if (ch = PM or else ch = EOF)
kono
parents:
diff changeset
1923 and then File.Is_Regular_File
kono
parents:
diff changeset
1924 then
kono
parents:
diff changeset
1925 File.Page := File.Page + 1;
kono
parents:
diff changeset
1926 File.Line := 1;
kono
parents:
diff changeset
1927 else
kono
parents:
diff changeset
1928 Ungetc (ch, File);
kono
parents:
diff changeset
1929 end if;
kono
parents:
diff changeset
1930 end if;
kono
parents:
diff changeset
1931 end loop;
kono
parents:
diff changeset
1932
kono
parents:
diff changeset
1933 File.Before_Upper_Half_Character := False;
kono
parents:
diff changeset
1934 end Skip_Line;
kono
parents:
diff changeset
1935
kono
parents:
diff changeset
1936 procedure Skip_Line (Spacing : Positive_Count := 1) is
kono
parents:
diff changeset
1937 begin
kono
parents:
diff changeset
1938 Skip_Line (Current_In, Spacing);
kono
parents:
diff changeset
1939 end Skip_Line;
kono
parents:
diff changeset
1940
kono
parents:
diff changeset
1941 ---------------
kono
parents:
diff changeset
1942 -- Skip_Page --
kono
parents:
diff changeset
1943 ---------------
kono
parents:
diff changeset
1944
kono
parents:
diff changeset
1945 procedure Skip_Page (File : File_Type) is
kono
parents:
diff changeset
1946 ch : int;
kono
parents:
diff changeset
1947
kono
parents:
diff changeset
1948 begin
kono
parents:
diff changeset
1949 FIO.Check_Read_Status (AP (File));
kono
parents:
diff changeset
1950
kono
parents:
diff changeset
1951 -- If at page mark already, just skip it
kono
parents:
diff changeset
1952
kono
parents:
diff changeset
1953 if File.Before_LM_PM then
kono
parents:
diff changeset
1954 File.Before_LM := False;
kono
parents:
diff changeset
1955 File.Before_LM_PM := False;
kono
parents:
diff changeset
1956 File.Page := File.Page + 1;
kono
parents:
diff changeset
1957 File.Line := 1;
kono
parents:
diff changeset
1958 File.Col := 1;
kono
parents:
diff changeset
1959 return;
kono
parents:
diff changeset
1960 end if;
kono
parents:
diff changeset
1961
kono
parents:
diff changeset
1962 -- This is a bit tricky, if we are logically before an LM then
kono
parents:
diff changeset
1963 -- it is not an error if we are at an end of file now, since we
kono
parents:
diff changeset
1964 -- are not really at it.
kono
parents:
diff changeset
1965
kono
parents:
diff changeset
1966 if File.Before_LM then
kono
parents:
diff changeset
1967 File.Before_LM := False;
kono
parents:
diff changeset
1968 File.Before_LM_PM := False;
kono
parents:
diff changeset
1969 ch := Getc (File);
kono
parents:
diff changeset
1970
kono
parents:
diff changeset
1971 -- Otherwise we do raise End_Error if we are at the end of file now
kono
parents:
diff changeset
1972
kono
parents:
diff changeset
1973 else
kono
parents:
diff changeset
1974 ch := Getc (File);
kono
parents:
diff changeset
1975
kono
parents:
diff changeset
1976 if ch = EOF then
kono
parents:
diff changeset
1977 raise End_Error;
kono
parents:
diff changeset
1978 end if;
kono
parents:
diff changeset
1979 end if;
kono
parents:
diff changeset
1980
kono
parents:
diff changeset
1981 -- Now we can just rumble along to the next page mark, or to the
kono
parents:
diff changeset
1982 -- end of file, if that comes first. The latter case happens when
kono
parents:
diff changeset
1983 -- the page mark is implied at the end of file.
kono
parents:
diff changeset
1984
kono
parents:
diff changeset
1985 loop
kono
parents:
diff changeset
1986 exit when ch = EOF
kono
parents:
diff changeset
1987 or else (ch = PM and then File.Is_Regular_File);
kono
parents:
diff changeset
1988 ch := Getc (File);
kono
parents:
diff changeset
1989 end loop;
kono
parents:
diff changeset
1990
kono
parents:
diff changeset
1991 File.Page := File.Page + 1;
kono
parents:
diff changeset
1992 File.Line := 1;
kono
parents:
diff changeset
1993 File.Col := 1;
kono
parents:
diff changeset
1994 File.Before_Upper_Half_Character := False;
kono
parents:
diff changeset
1995 end Skip_Page;
kono
parents:
diff changeset
1996
kono
parents:
diff changeset
1997 procedure Skip_Page is
kono
parents:
diff changeset
1998 begin
kono
parents:
diff changeset
1999 Skip_Page (Current_In);
kono
parents:
diff changeset
2000 end Skip_Page;
kono
parents:
diff changeset
2001
kono
parents:
diff changeset
2002 --------------------
kono
parents:
diff changeset
2003 -- Standard_Error --
kono
parents:
diff changeset
2004 --------------------
kono
parents:
diff changeset
2005
kono
parents:
diff changeset
2006 function Standard_Error return File_Type is
kono
parents:
diff changeset
2007 begin
kono
parents:
diff changeset
2008 return Standard_Err;
kono
parents:
diff changeset
2009 end Standard_Error;
kono
parents:
diff changeset
2010
kono
parents:
diff changeset
2011 function Standard_Error return File_Access is
kono
parents:
diff changeset
2012 begin
kono
parents:
diff changeset
2013 return Standard_Err'Access;
kono
parents:
diff changeset
2014 end Standard_Error;
kono
parents:
diff changeset
2015
kono
parents:
diff changeset
2016 --------------------
kono
parents:
diff changeset
2017 -- Standard_Input --
kono
parents:
diff changeset
2018 --------------------
kono
parents:
diff changeset
2019
kono
parents:
diff changeset
2020 function Standard_Input return File_Type is
kono
parents:
diff changeset
2021 begin
kono
parents:
diff changeset
2022 return Standard_In;
kono
parents:
diff changeset
2023 end Standard_Input;
kono
parents:
diff changeset
2024
kono
parents:
diff changeset
2025 function Standard_Input return File_Access is
kono
parents:
diff changeset
2026 begin
kono
parents:
diff changeset
2027 return Standard_In'Access;
kono
parents:
diff changeset
2028 end Standard_Input;
kono
parents:
diff changeset
2029
kono
parents:
diff changeset
2030 ---------------------
kono
parents:
diff changeset
2031 -- Standard_Output --
kono
parents:
diff changeset
2032 ---------------------
kono
parents:
diff changeset
2033
kono
parents:
diff changeset
2034 function Standard_Output return File_Type is
kono
parents:
diff changeset
2035 begin
kono
parents:
diff changeset
2036 return Standard_Out;
kono
parents:
diff changeset
2037 end Standard_Output;
kono
parents:
diff changeset
2038
kono
parents:
diff changeset
2039 function Standard_Output return File_Access is
kono
parents:
diff changeset
2040 begin
kono
parents:
diff changeset
2041 return Standard_Out'Access;
kono
parents:
diff changeset
2042 end Standard_Output;
kono
parents:
diff changeset
2043
kono
parents:
diff changeset
2044 --------------------
kono
parents:
diff changeset
2045 -- Terminate_Line --
kono
parents:
diff changeset
2046 --------------------
kono
parents:
diff changeset
2047
kono
parents:
diff changeset
2048 procedure Terminate_Line (File : File_Type) is
kono
parents:
diff changeset
2049 begin
kono
parents:
diff changeset
2050 FIO.Check_File_Open (AP (File));
kono
parents:
diff changeset
2051
kono
parents:
diff changeset
2052 -- For file other than In_File, test for needing to terminate last line
kono
parents:
diff changeset
2053
kono
parents:
diff changeset
2054 if Mode (File) /= In_File then
kono
parents:
diff changeset
2055
kono
parents:
diff changeset
2056 -- If not at start of line definition need new line
kono
parents:
diff changeset
2057
kono
parents:
diff changeset
2058 if File.Col /= 1 then
kono
parents:
diff changeset
2059 New_Line (File);
kono
parents:
diff changeset
2060
kono
parents:
diff changeset
2061 -- For files other than standard error and standard output, we
kono
parents:
diff changeset
2062 -- make sure that an empty file has a single line feed, so that
kono
parents:
diff changeset
2063 -- it is properly formatted. We avoid this for the standard files
kono
parents:
diff changeset
2064 -- because it is too much of a nuisance to have these odd line
kono
parents:
diff changeset
2065 -- feeds when nothing has been written to the file.
kono
parents:
diff changeset
2066
kono
parents:
diff changeset
2067 -- We also avoid this for files opened in append mode, in
kono
parents:
diff changeset
2068 -- accordance with (RM A.8.2(10))
kono
parents:
diff changeset
2069
kono
parents:
diff changeset
2070 elsif (File /= Standard_Err and then File /= Standard_Out)
kono
parents:
diff changeset
2071 and then (File.Line = 1 and then File.Page = 1)
kono
parents:
diff changeset
2072 and then Mode (File) = Out_File
kono
parents:
diff changeset
2073 then
kono
parents:
diff changeset
2074 New_Line (File);
kono
parents:
diff changeset
2075 end if;
kono
parents:
diff changeset
2076 end if;
kono
parents:
diff changeset
2077 end Terminate_Line;
kono
parents:
diff changeset
2078
kono
parents:
diff changeset
2079 ------------
kono
parents:
diff changeset
2080 -- Ungetc --
kono
parents:
diff changeset
2081 ------------
kono
parents:
diff changeset
2082
kono
parents:
diff changeset
2083 procedure Ungetc (ch : int; File : File_Type) is
kono
parents:
diff changeset
2084 begin
kono
parents:
diff changeset
2085 if ch /= EOF then
kono
parents:
diff changeset
2086 if ungetc (ch, File.Stream) = EOF then
kono
parents:
diff changeset
2087 raise Device_Error;
kono
parents:
diff changeset
2088 end if;
kono
parents:
diff changeset
2089 end if;
kono
parents:
diff changeset
2090 end Ungetc;
kono
parents:
diff changeset
2091
kono
parents:
diff changeset
2092 -----------
kono
parents:
diff changeset
2093 -- Write --
kono
parents:
diff changeset
2094 -----------
kono
parents:
diff changeset
2095
kono
parents:
diff changeset
2096 -- This is the primitive Stream Write routine, used when a Text_IO file
kono
parents:
diff changeset
2097 -- is treated directly as a stream using Text_IO.Streams.Stream.
kono
parents:
diff changeset
2098
kono
parents:
diff changeset
2099 procedure Write
kono
parents:
diff changeset
2100 (File : in out Text_AFCB;
kono
parents:
diff changeset
2101 Item : Stream_Element_Array)
kono
parents:
diff changeset
2102 is
kono
parents:
diff changeset
2103 pragma Warnings (Off, File);
kono
parents:
diff changeset
2104 -- Because in this implementation we don't need IN OUT, we only read
kono
parents:
diff changeset
2105
kono
parents:
diff changeset
2106 function Has_Translated_Characters return Boolean;
kono
parents:
diff changeset
2107 -- return True if Item array contains a character which will be
kono
parents:
diff changeset
2108 -- translated under the text file mode. There is only one such
kono
parents:
diff changeset
2109 -- character under DOS based systems which is character 10.
kono
parents:
diff changeset
2110
kono
parents:
diff changeset
2111 text_translation_required : Boolean;
kono
parents:
diff changeset
2112 for text_translation_required'Size use Character'Size;
kono
parents:
diff changeset
2113 pragma Import (C, text_translation_required,
kono
parents:
diff changeset
2114 "__gnat_text_translation_required");
kono
parents:
diff changeset
2115
kono
parents:
diff changeset
2116 Siz : constant size_t := Item'Length;
kono
parents:
diff changeset
2117
kono
parents:
diff changeset
2118 -------------------------------
kono
parents:
diff changeset
2119 -- Has_Translated_Characters --
kono
parents:
diff changeset
2120 -------------------------------
kono
parents:
diff changeset
2121
kono
parents:
diff changeset
2122 function Has_Translated_Characters return Boolean is
kono
parents:
diff changeset
2123 begin
kono
parents:
diff changeset
2124 for K in Item'Range loop
kono
parents:
diff changeset
2125 if Item (K) = 10 then
kono
parents:
diff changeset
2126 return True;
kono
parents:
diff changeset
2127 end if;
kono
parents:
diff changeset
2128 end loop;
kono
parents:
diff changeset
2129 return False;
kono
parents:
diff changeset
2130 end Has_Translated_Characters;
kono
parents:
diff changeset
2131
kono
parents:
diff changeset
2132 Needs_Binary_Write : constant Boolean :=
kono
parents:
diff changeset
2133 text_translation_required and then Has_Translated_Characters;
kono
parents:
diff changeset
2134
kono
parents:
diff changeset
2135 -- Start of processing for Write
kono
parents:
diff changeset
2136
kono
parents:
diff changeset
2137 begin
kono
parents:
diff changeset
2138 if File.Mode = FCB.In_File then
kono
parents:
diff changeset
2139 raise Mode_Error;
kono
parents:
diff changeset
2140 end if;
kono
parents:
diff changeset
2141
kono
parents:
diff changeset
2142 -- Now we do the write. Since this is a text file, it is normally in
kono
parents:
diff changeset
2143 -- text mode, but stream data must be written in binary mode, so we
kono
parents:
diff changeset
2144 -- temporarily set binary mode for the write, resetting it after. This
kono
parents:
diff changeset
2145 -- is done only if needed (i.e. there is some characters in Item which
kono
parents:
diff changeset
2146 -- needs to be written using the binary mode).
kono
parents:
diff changeset
2147 -- These calls have no effect in a system (like Unix) where there is
kono
parents:
diff changeset
2148 -- no distinction between text and binary files.
kono
parents:
diff changeset
2149
kono
parents:
diff changeset
2150 -- Since the character translation is done at the time the buffer is
kono
parents:
diff changeset
2151 -- written (this is true under Windows) we first flush current buffer
kono
parents:
diff changeset
2152 -- with text mode if needed.
kono
parents:
diff changeset
2153
kono
parents:
diff changeset
2154 if Needs_Binary_Write then
kono
parents:
diff changeset
2155 if fflush (File.Stream) = -1 then
kono
parents:
diff changeset
2156 raise Device_Error;
kono
parents:
diff changeset
2157 end if;
kono
parents:
diff changeset
2158
kono
parents:
diff changeset
2159 set_binary_mode (fileno (File.Stream));
kono
parents:
diff changeset
2160 end if;
kono
parents:
diff changeset
2161
kono
parents:
diff changeset
2162 if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then
kono
parents:
diff changeset
2163 raise Device_Error;
kono
parents:
diff changeset
2164 end if;
kono
parents:
diff changeset
2165
kono
parents:
diff changeset
2166 -- At this point we need to flush the buffer using the binary mode then
kono
parents:
diff changeset
2167 -- we reset to text mode.
kono
parents:
diff changeset
2168
kono
parents:
diff changeset
2169 if Needs_Binary_Write then
kono
parents:
diff changeset
2170 if fflush (File.Stream) = -1 then
kono
parents:
diff changeset
2171 raise Device_Error;
kono
parents:
diff changeset
2172 end if;
kono
parents:
diff changeset
2173
kono
parents:
diff changeset
2174 set_text_mode (fileno (File.Stream));
kono
parents:
diff changeset
2175 end if;
kono
parents:
diff changeset
2176 end Write;
kono
parents:
diff changeset
2177
kono
parents:
diff changeset
2178 begin
kono
parents:
diff changeset
2179 -- Initialize Standard Files
kono
parents:
diff changeset
2180
kono
parents:
diff changeset
2181 for J in WC_Encoding_Method loop
kono
parents:
diff changeset
2182 if WC_Encoding = WC_Encoding_Letters (J) then
kono
parents:
diff changeset
2183 Default_WCEM := J;
kono
parents:
diff changeset
2184 end if;
kono
parents:
diff changeset
2185 end loop;
kono
parents:
diff changeset
2186
kono
parents:
diff changeset
2187 Initialize_Standard_Files;
kono
parents:
diff changeset
2188
kono
parents:
diff changeset
2189 FIO.Chain_File (AP (Standard_In));
kono
parents:
diff changeset
2190 FIO.Chain_File (AP (Standard_Out));
kono
parents:
diff changeset
2191 FIO.Chain_File (AP (Standard_Err));
kono
parents:
diff changeset
2192
kono
parents:
diff changeset
2193 end Ada.Text_IO;