annotate gcc/ada/libgnat/a-textio.adb @ 131:84e7813d76e9

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