OSDN Git Service

2006-08-15 Jerry DeLisle <jvdelisle@gcc.gnu.org>
[pf3gnuchains/gcc-fork.git] / libgfortran / io / file_pos.c
1 /* Copyright (C) 2002-2003, 2005, 2006 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 "config.h"
31 #include <string.h>
32 #include "libgfortran.h"
33 #include "io.h"
34
35 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
36    ENDFILE, and REWIND as well as the FLUSH statement.  */
37
38
39 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
40    current position is after the newline that terminates the previous
41    record, and we have to sift backwards to find the newline before
42    that or the start of the file, whichever comes first.  */
43
44 #define READ_CHUNK 4096
45
46 static void
47 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
48 {
49   gfc_offset base;
50   char *p;
51   int n;
52
53   base = file_position (u->s) - 1;
54
55   do
56     {
57       n = (base < READ_CHUNK) ? base : READ_CHUNK;
58       base -= n;
59
60       p = salloc_r_at (u->s, &n, base);
61       if (p == NULL)
62         goto io_error;
63
64       /* We have moved backwards from the current position, it should
65          not be possible to get a short read.  Because it is not
66          clear what to do about such thing, we ignore the possibility.  */
67
68       /* There is no memrchr() in the C library, so we have to do it
69          ourselves.  */
70
71       n--;
72       while (n >= 0)
73         {
74           if (p[n] == '\n')
75             {
76               base += n + 1;
77               goto done;
78             }
79           n--;
80         }
81
82     }
83   while (base != 0);
84
85   /* base is the new pointer.  Seek to it exactly.  */
86  done:
87   if (sseek (u->s, base) == FAILURE)
88     goto io_error;
89   u->last_record--;
90   u->endfile = NO_ENDFILE;
91
92   return;
93
94  io_error:
95   generate_error (&fpp->common, ERROR_OS, NULL);
96 }
97
98
99 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
100    sequential file.  We are guaranteed to be between records on entry and 
101    we have to shift to the previous record.  */
102
103 static void
104 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
105 {
106   gfc_offset m, new;
107   GFC_INTEGER_4 m4;
108   GFC_INTEGER_8 m8;
109   int length, length_read;
110   char *p;
111
112   if (compile_options.record_marker == 0)
113     length = sizeof (gfc_offset);
114   else
115     length = compile_options.record_marker;
116
117   length_read = length;
118
119   p = salloc_r_at (u->s, &length_read,
120                    file_position (u->s) - length);
121   if (p == NULL || length_read != length)
122     goto io_error;
123
124   /* Only CONVERT_NATIVE and CONVERT_SWAP are valid here.  */
125   if (u->flags.convert == CONVERT_NATIVE)
126     {
127       switch (compile_options.record_marker)
128         {
129         case 0:
130           memcpy (&m, p, sizeof(gfc_offset));
131           break;
132
133         case sizeof(GFC_INTEGER_4):
134           memcpy (&m4, p, sizeof (m4));
135           m = m4;
136           break;
137
138         case sizeof(GFC_INTEGER_8):
139           memcpy (&m8, p, sizeof (m8));
140           m = m8;
141           break;
142
143         default:
144           runtime_error ("Illegal value for record marker");
145           break;
146         }
147     }
148   else
149     {
150       switch (compile_options.record_marker)
151         {
152         case 0:
153           reverse_memcpy (&m, p, sizeof(gfc_offset));
154           break;
155
156         case sizeof(GFC_INTEGER_4):
157           reverse_memcpy (&m4, p, sizeof (m4));
158           m = m4;
159           break;
160
161         case sizeof(GFC_INTEGER_8):
162           reverse_memcpy (&m8, p, sizeof (m8));
163           m = m8;
164           break;
165
166         default:
167           runtime_error ("Illegal value for record marker");
168           break;
169         }
170
171     }
172
173   if ((new = file_position (u->s) - m - 2*length) < 0)
174     new = 0;
175
176   if (sseek (u->s, new) == FAILURE)
177     goto io_error;
178
179   u->last_record--;
180   return;
181
182  io_error:
183   generate_error (&fpp->common, ERROR_OS, NULL);
184 }
185
186
187 extern void st_backspace (st_parameter_filepos *);
188 export_proto(st_backspace);
189
190 void
191 st_backspace (st_parameter_filepos *fpp)
192 {
193   gfc_unit *u;
194
195   library_start (&fpp->common);
196
197   u = find_unit (fpp->common.unit);
198   if (u == NULL)
199     {
200       generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
201       goto done;
202     }
203
204   /* Ignore direct access.  Non-advancing I/O is only allowed for formatted
205      sequential I/O and the next direct access transfer repositions the file 
206      anyway.  */
207
208   if (u->flags.access == ACCESS_DIRECT)
209     goto done;
210
211   /* Check for special cases involving the ENDFILE record first.  */
212
213   if (u->endfile == AFTER_ENDFILE)
214     {
215       u->endfile = AT_ENDFILE;
216       flush (u->s);
217       struncate (u->s);
218     }
219   else
220     {
221       if (file_position (u->s) == 0)
222         goto done;              /* Common special case */
223
224       if (u->mode == WRITING)
225         {
226           flush (u->s);
227           struncate (u->s);
228           u->mode = READING;
229         }
230
231       if (u->flags.form == FORM_FORMATTED)
232         formatted_backspace (fpp, u);
233       else
234         unformatted_backspace (fpp, u);
235
236       u->endfile = NO_ENDFILE;
237       u->current_record = 0;
238       u->bytes_left = 0;
239     }
240
241  done:
242   if (u != NULL)
243     unlock_unit (u);
244
245   library_end ();
246 }
247
248
249 extern void st_endfile (st_parameter_filepos *);
250 export_proto(st_endfile);
251
252 void
253 st_endfile (st_parameter_filepos *fpp)
254 {
255   gfc_unit *u;
256
257   library_start (&fpp->common);
258
259   u = find_unit (fpp->common.unit);
260   if (u != NULL)
261     {
262       if (u->current_record)
263         {
264           st_parameter_dt dtp;
265           dtp.common = fpp->common;
266           memset (&dtp.u.p, 0, sizeof (dtp.u.p));
267           dtp.u.p.current_unit = u;
268           next_record (&dtp, 1);
269         }
270
271       flush (u->s);
272       struncate (u->s);
273       u->endfile = AFTER_ENDFILE;
274       unlock_unit (u);
275     }
276
277   library_end ();
278 }
279
280
281 extern void st_rewind (st_parameter_filepos *);
282 export_proto(st_rewind);
283
284 void
285 st_rewind (st_parameter_filepos *fpp)
286 {
287   gfc_unit *u;
288
289   library_start (&fpp->common);
290
291   u = find_unit (fpp->common.unit);
292   if (u != NULL)
293     {
294       if (u->flags.access != ACCESS_SEQUENTIAL)
295         generate_error (&fpp->common, ERROR_BAD_OPTION,
296                         "Cannot REWIND a file opened for DIRECT access");
297       else
298         {
299           /* Flush the buffers.  If we have been writing to the file, the last
300                written record is the last record in the file, so truncate the
301                file now.  Reset to read mode so two consecutive rewind
302                statements do not delete the file contents.  */
303           flush (u->s);
304           if (u->mode == WRITING)
305             struncate (u->s);
306
307           u->mode = READING;
308           u->last_record = 0;
309           if (sseek (u->s, 0) == FAILURE)
310             generate_error (&fpp->common, ERROR_OS, NULL);
311
312           u->endfile = NO_ENDFILE;
313           u->current_record = 0;
314           u->bytes_left = 0;
315           u->read_bad = 0;
316           test_endfile (u);
317         }
318       /* Update position for INQUIRE.  */
319       u->flags.position = POSITION_REWIND;
320       unlock_unit (u);
321     }
322
323   library_end ();
324 }
325
326
327 extern void st_flush (st_parameter_filepos *);
328 export_proto(st_flush);
329
330 void
331 st_flush (st_parameter_filepos *fpp)
332 {
333   gfc_unit *u;
334
335   library_start (&fpp->common);
336
337   u = find_unit (fpp->common.unit);
338   if (u != NULL)
339     {
340       flush (u->s);
341       unlock_unit (u);
342     }
343   else
344     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */ 
345     generate_error (&fpp->common, ERROR_BAD_OPTION,
346                         "Specified UNIT in FLUSH is not connected");
347
348   library_end ();
349 }