OSDN Git Service

2007-12-13 Thomas Koenig <tkoenig@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / io / file_pos.c
1 /* Copyright (C) 2002-2003, 2005, 2006, 2007 Free Software Foundation, Inc.
2    Contributed by Andy Vaught and Janne Blomqvist
3
4 This file is part of the GNU Fortran runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2, or (at your option)
9 any later version.
10
11 In addition to the permissions in the GNU General Public License, the
12 Free Software Foundation gives you unlimited permission to link the
13 compiled version of this file into combinations with other programs,
14 and to distribute those combinations without any restriction coming
15 from the use of this file.  (The General Public License restrictions
16 do apply in other respects; for example, they cover modification of
17 the file, and distribution when not linked into a combine
18 executable.)
19
20 Libgfortran is distributed in the hope that it will be useful,
21 but WITHOUT ANY WARRANTY; without even the implied warranty of
22 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
23 GNU General Public License for more details.
24
25 You should have received a copy of the GNU General Public License
26 along with Libgfortran; see the file COPYING.  If not, write to
27 the Free Software Foundation, 51 Franklin Street, Fifth Floor,
28 Boston, MA 02110-1301, USA.  */
29
30 #include "io.h"
31 #include <string.h>
32
33 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
34    ENDFILE, and REWIND as well as the FLUSH statement.  */
35
36
37 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
38    current position is after the newline that terminates the previous
39    record, and we have to sift backwards to find the newline before
40    that or the start of the file, whichever comes first.  */
41
42 #define READ_CHUNK 4096
43
44 static void
45 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
46 {
47   gfc_offset base;
48   char *p;
49   int n;
50
51   base = file_position (u->s) - 1;
52
53   do
54     {
55       n = (base < READ_CHUNK) ? base : READ_CHUNK;
56       base -= n;
57
58       p = salloc_r_at (u->s, &n, base);
59       if (p == NULL)
60         goto io_error;
61
62       /* We have moved backwards from the current position, it should
63          not be possible to get a short read.  Because it is not
64          clear what to do about such thing, we ignore the possibility.  */
65
66       /* There is no memrchr() in the C library, so we have to do it
67          ourselves.  */
68
69       n--;
70       while (n >= 0)
71         {
72           if (p[n] == '\n')
73             {
74               base += n + 1;
75               goto done;
76             }
77           n--;
78         }
79
80     }
81   while (base != 0);
82
83   /* base is the new pointer.  Seek to it exactly.  */
84  done:
85   if (sseek (u->s, base) == FAILURE)
86     goto io_error;
87   u->last_record--;
88   u->endfile = NO_ENDFILE;
89
90   return;
91
92  io_error:
93   generate_error (&fpp->common, LIBERROR_OS, NULL);
94 }
95
96
97 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
98    sequential file.  We are guaranteed to be between records on entry and 
99    we have to shift to the previous record.  Loop over subrecords.  */
100
101 static void
102 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
103 {
104   gfc_offset m, new;
105   GFC_INTEGER_4 m4;
106   GFC_INTEGER_8 m8;
107   int length, length_read;
108   int continued;
109   char *p;
110
111   if (compile_options.record_marker == 0)
112     length = sizeof (GFC_INTEGER_4);
113   else
114     length = compile_options.record_marker;
115
116   do
117     {
118       length_read = length;
119
120       p = salloc_r_at (u->s, &length_read,
121                        file_position (u->s) - length);
122       if (p == NULL || length_read != length)
123         goto io_error;
124
125       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
126       if (u->flags.convert == GFC_CONVERT_NATIVE)
127         {
128           switch (length)
129             {
130             case sizeof(GFC_INTEGER_4):
131               memcpy (&m4, p, sizeof (m4));
132               m = m4;
133               break;
134
135             case sizeof(GFC_INTEGER_8):
136               memcpy (&m8, p, sizeof (m8));
137               m = m8;
138               break;
139
140             default:
141               runtime_error ("Illegal value for record marker");
142               break;
143             }
144         }
145       else
146         {
147           switch (length)
148             {
149             case sizeof(GFC_INTEGER_4):
150               reverse_memcpy (&m4, p, sizeof (m4));
151               m = m4;
152               break;
153
154             case sizeof(GFC_INTEGER_8):
155               reverse_memcpy (&m8, p, sizeof (m8));
156               m = m8;
157               break;
158
159             default:
160               runtime_error ("Illegal value for record marker");
161               break;
162             }
163
164         }
165
166       continued = m < 0;
167       if (continued)
168         m = -m;
169
170       if ((new = file_position (u->s) - m - 2*length) < 0)
171         new = 0;
172
173       if (sseek (u->s, new) == FAILURE)
174         goto io_error;
175     } while (continued);
176
177   u->last_record--;
178   return;
179
180  io_error:
181   generate_error (&fpp->common, LIBERROR_OS, NULL);
182 }
183
184
185 extern void st_backspace (st_parameter_filepos *);
186 export_proto(st_backspace);
187
188 void
189 st_backspace (st_parameter_filepos *fpp)
190 {
191   gfc_unit *u;
192
193   library_start (&fpp->common);
194
195   u = find_unit (fpp->common.unit);
196   if (u == NULL)
197     {
198       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
199       goto done;
200     }
201
202   /* Direct access is prohibited, and so is unformatted stream access.  */
203
204
205   if (u->flags.access == ACCESS_DIRECT)
206     {
207       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
208                       "Cannot BACKSPACE a file opened for DIRECT access");
209       goto done;
210     }
211
212     if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
213       {
214         generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
215                         "Cannot BACKSPACE an unformatted stream file");
216         goto done;
217       }
218
219   /* Check for special cases involving the ENDFILE record first.  */
220
221   if (u->endfile == AFTER_ENDFILE)
222     {
223       u->endfile = AT_ENDFILE;
224       u->flags.position = POSITION_APPEND;
225       flush (u->s);
226     }
227   else
228     {
229       if (file_position (u->s) == 0)
230         {
231           u->flags.position = POSITION_REWIND;
232           goto done;            /* Common special case */
233         }
234
235       if (u->mode == WRITING)
236         {
237           /* If there are previously written bytes from a write with
238              ADVANCE="no", add a record marker before performing the
239              BACKSPACE.  */
240
241           if (u->previous_nonadvancing_write)
242             finish_last_advance_record (u);
243
244           u->previous_nonadvancing_write = 0;
245
246           flush (u->s);
247           struncate (u->s);
248           u->mode = READING;
249         }
250
251       if (u->flags.form == FORM_FORMATTED)
252         formatted_backspace (fpp, u);
253       else
254         unformatted_backspace (fpp, u);
255
256       update_position (u);
257       u->endfile = NO_ENDFILE;
258       u->current_record = 0;
259       u->bytes_left = 0;
260     }
261
262  done:
263   if (u != NULL)
264     unlock_unit (u);
265
266   library_end ();
267 }
268
269
270 extern void st_endfile (st_parameter_filepos *);
271 export_proto(st_endfile);
272
273 void
274 st_endfile (st_parameter_filepos *fpp)
275 {
276   gfc_unit *u;
277
278   library_start (&fpp->common);
279
280   u = find_unit (fpp->common.unit);
281   if (u != NULL)
282     {
283       if (u->flags.access == ACCESS_DIRECT)
284         {
285           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
286                           "Cannot perform ENDFILE on a file opened"
287                           " for DIRECT access");
288           goto done;
289         }
290
291       /* If there are previously written bytes from a write with ADVANCE="no",
292          add a record marker before performing the ENDFILE.  */
293
294       if (u->previous_nonadvancing_write)
295         finish_last_advance_record (u);
296
297       u->previous_nonadvancing_write = 0;
298
299       if (u->current_record)
300         {
301           st_parameter_dt dtp;
302           dtp.common = fpp->common;
303           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
304           dtp.u.p.current_unit = u;
305           next_record (&dtp, 1);
306         }
307
308       flush (u->s);
309       struncate (u->s);
310       u->endfile = AFTER_ENDFILE;
311       update_position (u);
312     done:
313       unlock_unit (u);
314     }
315
316   library_end ();
317 }
318
319
320 extern void st_rewind (st_parameter_filepos *);
321 export_proto(st_rewind);
322
323 void
324 st_rewind (st_parameter_filepos *fpp)
325 {
326   gfc_unit *u;
327
328   library_start (&fpp->common);
329
330   u = find_unit (fpp->common.unit);
331   if (u != NULL)
332     {
333       if (u->flags.access == ACCESS_DIRECT)
334         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
335                         "Cannot REWIND a file opened for DIRECT access");
336       else
337         {
338           /* If there are previously written bytes from a write with ADVANCE="no",
339              add a record marker before performing the ENDFILE.  */
340
341           if (u->previous_nonadvancing_write)
342             finish_last_advance_record (u);
343
344           u->previous_nonadvancing_write = 0;
345
346           /* Flush the buffers.  If we have been writing to the file, the last
347                written record is the last record in the file, so truncate the
348                file now.  Reset to read mode so two consecutive rewind
349                statements do not delete the file contents.  */
350           flush (u->s);
351           if (u->mode == WRITING && u->flags.access != ACCESS_STREAM)
352             struncate (u->s);
353
354           u->mode = READING;
355           u->last_record = 0;
356
357           if (file_position (u->s) != 0 && sseek (u->s, 0) == FAILURE)
358             generate_error (&fpp->common, LIBERROR_OS, NULL);
359
360           /* Handle special files like /dev/null differently.  */
361           if (!is_special (u->s))
362             {
363               /* We are rewinding so we are not at the end.  */
364               u->endfile = NO_ENDFILE;
365             }
366           else
367             {
368               /* Set this for compatibilty with g77 for /dev/null.  */
369               if (file_length (u->s) == 0  && file_position (u->s) == 0)
370                 u->endfile = AT_ENDFILE;
371               /* Future refinements on special files can go here.  */
372             }
373
374           u->current_record = 0;
375           u->strm_pos = 1;
376           u->read_bad = 0;
377         }
378       /* Update position for INQUIRE.  */
379       u->flags.position = POSITION_REWIND;
380       unlock_unit (u);
381     }
382
383   library_end ();
384 }
385
386
387 extern void st_flush (st_parameter_filepos *);
388 export_proto(st_flush);
389
390 void
391 st_flush (st_parameter_filepos *fpp)
392 {
393   gfc_unit *u;
394
395   library_start (&fpp->common);
396
397   u = find_unit (fpp->common.unit);
398   if (u != NULL)
399     {
400       flush (u->s);
401       unlock_unit (u);
402     }
403   else
404     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ 
405     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
406                         "Specified UNIT in FLUSH is not connected");
407
408   library_end ();
409 }