OSDN Git Service

2010-06-18 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / io / file_pos.c
1 /* Copyright (C) 2002-2003, 2005, 2006, 2007, 2009 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 3, or (at your option)
9 any later version.
10
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 GNU General Public License for more details.
15
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
19
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
23 <http://www.gnu.org/licenses/>.  */
24
25 #include "io.h"
26 #include "fbuf.h"
27 #include "unix.h"
28 #include <string.h>
29
30 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
31    ENDFILE, and REWIND as well as the FLUSH statement.  */
32
33
34 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
35    current position is after the newline that terminates the previous
36    record, and we have to sift backwards to find the newline before
37    that or the start of the file, whichever comes first.  */
38
39 static const int READ_CHUNK = 4096;
40
41 static void
42 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
43 {
44   gfc_offset base;
45   char p[READ_CHUNK];
46   ssize_t n;
47
48   base = stell (u->s) - 1;
49
50   do
51     {
52       n = (base < READ_CHUNK) ? base : READ_CHUNK;
53       base -= n;
54       if (sseek (u->s, base, SEEK_SET) < 0)
55         goto io_error;
56       if (sread (u->s, p, n) != n)
57         goto io_error;
58
59       /* We have moved backwards from the current position, it should
60          not be possible to get a short read.  Because it is not
61          clear what to do about such thing, we ignore the possibility.  */
62
63       /* There is no memrchr() in the C library, so we have to do it
64          ourselves.  */
65
66       while (n > 0)
67         {
68           n--;
69           if (p[n] == '\n')
70             {
71               base += n + 1;
72               goto done;
73             }
74         }
75
76     }
77   while (base != 0);
78
79   /* base is the new pointer.  Seek to it exactly.  */
80  done:
81   if (sseek (u->s, base, SEEK_SET) < 0)
82     goto io_error;
83   u->last_record--;
84   u->endfile = NO_ENDFILE;
85
86   return;
87
88  io_error:
89   generate_error (&fpp->common, LIBERROR_OS, NULL);
90 }
91
92
93 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
94    sequential file.  We are guaranteed to be between records on entry and 
95    we have to shift to the previous record.  Loop over subrecords.  */
96
97 static void
98 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
99 {
100   gfc_offset m, slen;
101   GFC_INTEGER_4 m4;
102   GFC_INTEGER_8 m8;
103   ssize_t length;
104   int continued;
105   char p[sizeof (GFC_INTEGER_8)];
106
107   if (compile_options.record_marker == 0)
108     length = sizeof (GFC_INTEGER_4);
109   else
110     length = compile_options.record_marker;
111
112   do
113     {
114       slen = - (gfc_offset) length;
115       if (sseek (u->s, slen, SEEK_CUR) < 0)
116         goto io_error;
117       if (sread (u->s, p, length) != length)
118         goto io_error;
119
120       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
121       if (likely (u->flags.convert == GFC_CONVERT_NATIVE))
122         {
123           switch (length)
124             {
125             case sizeof(GFC_INTEGER_4):
126               memcpy (&m4, p, sizeof (m4));
127               m = m4;
128               break;
129
130             case sizeof(GFC_INTEGER_8):
131               memcpy (&m8, p, sizeof (m8));
132               m = m8;
133               break;
134
135             default:
136               runtime_error ("Illegal value for record marker");
137               break;
138             }
139         }
140       else
141         {
142           switch (length)
143             {
144             case sizeof(GFC_INTEGER_4):
145               reverse_memcpy (&m4, p, sizeof (m4));
146               m = m4;
147               break;
148
149             case sizeof(GFC_INTEGER_8):
150               reverse_memcpy (&m8, p, sizeof (m8));
151               m = m8;
152               break;
153
154             default:
155               runtime_error ("Illegal value for record marker");
156               break;
157             }
158
159         }
160
161       continued = m < 0;
162       if (continued)
163         m = -m;
164
165       if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
166         goto io_error;
167     } while (continued);
168
169   u->last_record--;
170   return;
171
172  io_error:
173   generate_error (&fpp->common, LIBERROR_OS, NULL);
174 }
175
176
177 extern void st_backspace (st_parameter_filepos *);
178 export_proto(st_backspace);
179
180 void
181 st_backspace (st_parameter_filepos *fpp)
182 {
183   gfc_unit *u;
184
185   library_start (&fpp->common);
186
187   u = find_unit (fpp->common.unit);
188   if (u == NULL)
189     {
190       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
191       goto done;
192     }
193
194   /* Direct access is prohibited, and so is unformatted stream access.  */
195
196
197   if (u->flags.access == ACCESS_DIRECT)
198     {
199       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
200                       "Cannot BACKSPACE a file opened for DIRECT access");
201       goto done;
202     }
203
204   if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
205     {
206       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
207                       "Cannot BACKSPACE an unformatted stream file");
208       goto done;
209     }
210
211   /* Make sure format buffer is flushed and reset.  */
212   if (u->flags.form == FORM_FORMATTED)
213     {
214       int pos = fbuf_reset (u);
215       if (pos != 0)
216         sseek (u->s, pos, SEEK_CUR);
217     }
218
219   
220   /* Check for special cases involving the ENDFILE record first.  */
221
222   if (u->endfile == AFTER_ENDFILE)
223     {
224       u->endfile = AT_ENDFILE;
225       u->flags.position = POSITION_APPEND;
226       sflush (u->s);
227     }
228   else
229     {
230       if (stell (u->s) == 0)
231         {
232           u->flags.position = POSITION_REWIND;
233           goto done;            /* Common special case */
234         }
235
236       if (u->mode == WRITING)
237         {
238           /* If there are previously written bytes from a write with
239              ADVANCE="no", add a record marker before performing the
240              BACKSPACE.  */
241
242           if (u->previous_nonadvancing_write)
243             finish_last_advance_record (u);
244
245           u->previous_nonadvancing_write = 0;
246
247           unit_truncate (u, stell (u->s), &fpp->common);
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       u->flags.position = POSITION_UNSPECIFIED;
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 (u->flags.access == ACCESS_SEQUENTIAL
292           && u->endfile == AFTER_ENDFILE)
293         {
294           generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
295                           "Cannot perform ENDFILE on a file already "
296                           "positioned after the EOF marker");
297           goto done;
298         }
299
300       /* If there are previously written bytes from a write with ADVANCE="no",
301          add a record marker before performing the ENDFILE.  */
302
303       if (u->previous_nonadvancing_write)
304         finish_last_advance_record (u);
305
306       u->previous_nonadvancing_write = 0;
307
308       if (u->current_record)
309         {
310           st_parameter_dt dtp;
311           dtp.common = fpp->common;
312           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
313           dtp.u.p.current_unit = u;
314           next_record (&dtp, 1);
315         }
316
317       unit_truncate (u, stell (u->s), &fpp->common);
318       u->endfile = AFTER_ENDFILE;
319       if (0 == stell (u->s))
320         u->flags.position = POSITION_REWIND;
321     }
322   else
323     {
324       if (fpp->common.unit < 0)
325         {
326           generate_error (&fpp->common, LIBERROR_BAD_OPTION,
327                           "Bad unit number in statement");
328           return;
329         }
330
331       u = find_or_create_unit (fpp->common.unit);
332       if (u->s == NULL)
333         {
334           /* Open the unit with some default flags.  */
335           st_parameter_open opp;
336           unit_flags u_flags;
337
338           memset (&u_flags, '\0', sizeof (u_flags));
339           u_flags.access = ACCESS_SEQUENTIAL;
340           u_flags.action = ACTION_READWRITE;
341           u_flags.form = FORM_UNSPECIFIED;
342           u_flags.delim = DELIM_UNSPECIFIED;
343           u_flags.blank = BLANK_UNSPECIFIED;
344           u_flags.pad = PAD_UNSPECIFIED;
345           u_flags.decimal = DECIMAL_UNSPECIFIED;
346           u_flags.encoding = ENCODING_UNSPECIFIED;
347           u_flags.async = ASYNC_UNSPECIFIED;
348           u_flags.round = ROUND_UNSPECIFIED;
349           u_flags.sign = SIGN_UNSPECIFIED;
350           u_flags.status = STATUS_UNKNOWN;
351           u_flags.convert = GFC_CONVERT_NATIVE;
352
353           opp.common = fpp->common;
354           opp.common.flags &= IOPARM_COMMON_MASK;
355           u = new_unit (&opp, u, &u_flags);
356           if (u == NULL)
357             return;
358           u->endfile = AFTER_ENDFILE;
359         }
360     }
361
362   done:
363     unlock_unit (u);
364
365   library_end ();
366 }
367
368
369 extern void st_rewind (st_parameter_filepos *);
370 export_proto(st_rewind);
371
372 void
373 st_rewind (st_parameter_filepos *fpp)
374 {
375   gfc_unit *u;
376
377   library_start (&fpp->common);
378
379   u = find_unit (fpp->common.unit);
380   if (u != NULL)
381     {
382       if (u->flags.access == ACCESS_DIRECT)
383         generate_error (&fpp->common, LIBERROR_BAD_OPTION,
384                         "Cannot REWIND a file opened for DIRECT access");
385       else
386         {
387           /* If there are previously written bytes from a write with ADVANCE="no",
388              add a record marker before performing the ENDFILE.  */
389
390           if (u->previous_nonadvancing_write)
391             finish_last_advance_record (u);
392
393           u->previous_nonadvancing_write = 0;
394
395           fbuf_reset (u);
396
397           u->last_record = 0;
398
399           if (sseek (u->s, 0, SEEK_SET) < 0)
400             generate_error (&fpp->common, LIBERROR_OS, NULL);
401
402           /* Handle special files like /dev/null differently.  */
403           if (!is_special (u->s))
404             {
405               /* We are rewinding so we are not at the end.  */
406               u->endfile = NO_ENDFILE;
407             }
408           else
409             {
410               /* Set this for compatibilty with g77 for /dev/null.  */
411               if (file_length (u->s) == 0  && stell (u->s) == 0)
412                 u->endfile = AT_ENDFILE;
413               /* Future refinements on special files can go here.  */
414             }
415
416           u->current_record = 0;
417           u->strm_pos = 1;
418           u->read_bad = 0;
419         }
420       /* Update position for INQUIRE.  */
421       u->flags.position = POSITION_REWIND;
422       unlock_unit (u);
423     }
424
425   library_end ();
426 }
427
428
429 extern void st_flush (st_parameter_filepos *);
430 export_proto(st_flush);
431
432 void
433 st_flush (st_parameter_filepos *fpp)
434 {
435   gfc_unit *u;
436
437   library_start (&fpp->common);
438
439   u = find_unit (fpp->common.unit);
440   if (u != NULL)
441     {
442       /* Make sure format buffer is flushed.  */
443       if (u->flags.form == FORM_FORMATTED)
444         fbuf_flush (u, u->mode);
445
446       sflush (u->s);
447       unlock_unit (u);
448     }
449   else
450     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ 
451     generate_error (&fpp->common, LIBERROR_BAD_OPTION,
452                         "Specified UNIT in FLUSH is not connected");
453
454   library_end ();
455 }