xref: /netbsd-src/external/gpl3/gcc/dist/libgfortran/io/file_pos.c (revision b1e838363e3c6fc78a55519254d99869742dd33c)
1 /* Copyright (C) 2002-2022 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 "async.h"
29 #include <string.h>
30 
31 /* file_pos.c-- Implement the file positioning statements, i.e. BACKSPACE,
32    ENDFILE, and REWIND as well as the FLUSH statement.  */
33 
34 
35 /* formatted_backspace(fpp, u)-- Move the file back one line.  The
36    current position is after the newline that terminates the previous
37    record, and we have to sift backwards to find the newline before
38    that or the start of the file, whichever comes first.  */
39 
40 #define READ_CHUNK 4096
41 
42 static void
formatted_backspace(st_parameter_filepos * fpp,gfc_unit * u)43 formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
44 {
45   gfc_offset base;
46   char p[READ_CHUNK];
47   ssize_t n;
48 
49   base = stell (u->s) - 1;
50 
51   do
52     {
53       n = (base < READ_CHUNK) ? base : READ_CHUNK;
54       base -= n;
55       if (sseek (u->s, base, SEEK_SET) < 0)
56         goto io_error;
57       if (sread (u->s, p, n) != n)
58 	goto io_error;
59 
60       /* We have moved backwards from the current position, it should
61          not be possible to get a short read.  Because it is not
62          clear what to do about such thing, we ignore the possibility.  */
63 
64       /* There is no memrchr() in the C library, so we have to do it
65          ourselves.  */
66 
67       while (n > 0)
68 	{
69           n--;
70 	  if (p[n] == '\n')
71 	    {
72 	      base += n + 1;
73 	      goto done;
74 	    }
75 	}
76 
77     }
78   while (base != 0);
79 
80   /* base is the new pointer.  Seek to it exactly.  */
81  done:
82   if (sseek (u->s, base, SEEK_SET) < 0)
83     goto io_error;
84   u->last_record--;
85   u->endfile = NO_ENDFILE;
86   u->last_char = EOF - 1;
87   return;
88 
89  io_error:
90   generate_error (&fpp->common, LIBERROR_OS, NULL);
91 }
92 
93 
94 /* unformatted_backspace(fpp) -- Move the file backwards for an unformatted
95    sequential file.  We are guaranteed to be between records on entry and
96    we have to shift to the previous record.  Loop over subrecords.  */
97 
98 static void
unformatted_backspace(st_parameter_filepos * fpp,gfc_unit * u)99 unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
100 {
101   gfc_offset m, slen;
102   GFC_INTEGER_4 m4;
103   GFC_INTEGER_8 m8;
104   ssize_t length;
105   int continued;
106   char p[sizeof (GFC_INTEGER_8)];
107   int convert = u->flags.convert;
108 
109 #ifdef HAVE_GFC_REAL_17
110   convert &= ~(GFC_CONVERT_R16_IEEE | GFC_CONVERT_R16_IBM);
111 #endif
112 
113   if (compile_options.record_marker == 0)
114     length = sizeof (GFC_INTEGER_4);
115   else
116     length = compile_options.record_marker;
117 
118   do
119     {
120       slen = - (gfc_offset) length;
121       if (sseek (u->s, slen, SEEK_CUR) < 0)
122         goto io_error;
123       if (sread (u->s, p, length) != length)
124         goto io_error;
125 
126       /* Only GFC_CONVERT_NATIVE and GFC_CONVERT_SWAP are valid here.  */
127       if (likely (convert == GFC_CONVERT_NATIVE))
128 	{
129 	  switch (length)
130 	    {
131 	    case sizeof(GFC_INTEGER_4):
132 	      memcpy (&m4, p, sizeof (m4));
133 	      m = m4;
134 	      break;
135 
136 	    case sizeof(GFC_INTEGER_8):
137 	      memcpy (&m8, p, sizeof (m8));
138 	      m = m8;
139 	      break;
140 
141 	    default:
142 	      runtime_error ("Illegal value for record marker");
143 	      break;
144 	    }
145 	}
146       else
147 	{
148 	  uint32_t u32;
149 	  uint64_t u64;
150 	  switch (length)
151 	    {
152 	    case sizeof(GFC_INTEGER_4):
153 	      memcpy (&u32, p, sizeof (u32));
154 	      u32 = __builtin_bswap32 (u32);
155 	      memcpy (&m4, &u32, sizeof (m4));
156 	      m = m4;
157 	      break;
158 
159 	    case sizeof(GFC_INTEGER_8):
160 	      memcpy (&u64, p, sizeof (u64));
161 	      u64 = __builtin_bswap64 (u64);
162 	      memcpy (&m8, &u64, 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       continued = m < 0;
174       if (continued)
175 	m = -m;
176 
177       if (sseek (u->s, -m -2 * length, SEEK_CUR) < 0)
178 	goto io_error;
179     } while (continued);
180 
181   u->last_record--;
182   return;
183 
184  io_error:
185   generate_error (&fpp->common, LIBERROR_OS, NULL);
186 }
187 
188 
189 extern void st_backspace (st_parameter_filepos *);
190 export_proto(st_backspace);
191 
192 void
st_backspace(st_parameter_filepos * fpp)193 st_backspace (st_parameter_filepos *fpp)
194 {
195   gfc_unit *u;
196   bool needs_unlock = false;
197 
198   library_start (&fpp->common);
199 
200   u = find_unit (fpp->common.unit);
201   if (u == NULL)
202     {
203       generate_error (&fpp->common, LIBERROR_BAD_UNIT, NULL);
204       goto done;
205     }
206 
207   /* Direct access is prohibited, and so is unformatted stream access.  */
208 
209 
210   if (u->flags.access == ACCESS_DIRECT)
211     {
212       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
213 		      "Cannot BACKSPACE a file opened for DIRECT access");
214       goto done;
215     }
216 
217   if (u->flags.access == ACCESS_STREAM && u->flags.form == FORM_UNFORMATTED)
218     {
219       generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
220                       "Cannot BACKSPACE an unformatted stream file");
221       goto done;
222     }
223 
224   if (ASYNC_IO && u->au)
225     {
226       if (async_wait (&(fpp->common), u->au))
227 	return;
228       else
229 	{
230 	  needs_unlock = true;
231 	  LOCK (&u->au->io_lock);
232 	}
233     }
234 
235   /* Make sure format buffer is flushed and reset.  */
236   if (u->flags.form == FORM_FORMATTED)
237     {
238       int pos = fbuf_reset (u);
239       if (pos != 0)
240         sseek (u->s, pos, SEEK_CUR);
241     }
242 
243 
244   /* Check for special cases involving the ENDFILE record first.  */
245 
246   if (u->endfile == AFTER_ENDFILE)
247     {
248       u->endfile = AT_ENDFILE;
249       u->flags.position = POSITION_APPEND;
250       sflush (u->s);
251     }
252   else
253     {
254       if (stell (u->s) == 0)
255 	{
256 	  u->flags.position = POSITION_REWIND;
257 	  goto done;		/* Common special case */
258 	}
259 
260       if (u->mode == WRITING)
261 	{
262 	  /* If there are previously written bytes from a write with
263 	     ADVANCE="no", add a record marker before performing the
264 	     BACKSPACE.  */
265 
266 	  if (u->previous_nonadvancing_write)
267 	    finish_last_advance_record (u);
268 
269 	  u->previous_nonadvancing_write = 0;
270 
271 	  unit_truncate (u, stell (u->s), &fpp->common);
272 	  u->mode = READING;
273         }
274 
275       if (u->flags.form == FORM_FORMATTED)
276 	formatted_backspace (fpp, u);
277       else
278 	unformatted_backspace (fpp, u);
279 
280       u->flags.position = POSITION_UNSPECIFIED;
281       u->endfile = NO_ENDFILE;
282       u->current_record = 0;
283       u->bytes_left = 0;
284     }
285 
286  done:
287   if (u != NULL)
288     {
289       unlock_unit (u);
290 
291       if (ASYNC_IO && u->au && needs_unlock)
292 	UNLOCK (&u->au->io_lock);
293     }
294 
295   library_end ();
296 }
297 
298 
299 extern void st_endfile (st_parameter_filepos *);
300 export_proto(st_endfile);
301 
302 void
st_endfile(st_parameter_filepos * fpp)303 st_endfile (st_parameter_filepos *fpp)
304 {
305   gfc_unit *u;
306   bool needs_unlock = false;
307 
308   library_start (&fpp->common);
309 
310   u = find_unit (fpp->common.unit);
311   if (u != NULL)
312     {
313       if (u->flags.access == ACCESS_DIRECT)
314 	{
315 	  generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
316 			  "Cannot perform ENDFILE on a file opened "
317 			  "for DIRECT access");
318 	  goto done;
319 	}
320 
321       if (ASYNC_IO && u->au)
322 	{
323 	  if (async_wait (&(fpp->common), u->au))
324 	    return;
325 	  else
326 	    {
327 	      needs_unlock = true;
328 	      LOCK (&u->au->io_lock);
329 	    }
330 	}
331 
332       if (u->flags.access == ACCESS_SEQUENTIAL
333       	  && u->endfile == AFTER_ENDFILE)
334 	{
335 	  generate_error (&fpp->common, LIBERROR_OPTION_CONFLICT,
336 			  "Cannot perform ENDFILE on a file already "
337 			  "positioned after the EOF marker");
338 	  goto done;
339 	}
340 
341       /* If there are previously written bytes from a write with ADVANCE="no",
342 	 add a record marker before performing the ENDFILE.  */
343 
344       if (u->previous_nonadvancing_write)
345 	finish_last_advance_record (u);
346 
347       u->previous_nonadvancing_write = 0;
348 
349       if (u->current_record)
350 	{
351 	  st_parameter_dt dtp;
352 	  dtp.common = fpp->common;
353 	  memset (&dtp.u.p, 0, sizeof (dtp.u.p));
354 	  dtp.u.p.current_unit = u;
355 	  next_record (&dtp, 1);
356 	}
357 
358       unit_truncate (u, stell (u->s), &fpp->common);
359       u->endfile = AFTER_ENDFILE;
360       u->last_char = EOF - 1;
361       if (0 == stell (u->s))
362         u->flags.position = POSITION_REWIND;
363     }
364   else
365     {
366       if (fpp->common.unit < 0)
367 	{
368 	  generate_error (&fpp->common, LIBERROR_BAD_OPTION,
369 			  "Bad unit number in statement");
370 	  return;
371 	}
372 
373       u = find_or_create_unit (fpp->common.unit);
374       if (u->s == NULL)
375 	{
376 	  /* Open the unit with some default flags.  */
377 	  st_parameter_open opp;
378 	  unit_flags u_flags;
379 
380 	  memset (&u_flags, '\0', sizeof (u_flags));
381 	  u_flags.access = ACCESS_SEQUENTIAL;
382 	  u_flags.action = ACTION_READWRITE;
383 
384 	  /* Is it unformatted?  */
385 	  if (!(fpp->common.flags & (IOPARM_DT_HAS_FORMAT | IOPARM_DT_LIST_FORMAT
386 				     | IOPARM_DT_IONML_SET)))
387 	    u_flags.form = FORM_UNFORMATTED;
388 	  else
389 	    u_flags.form = FORM_UNSPECIFIED;
390 
391 	  u_flags.delim = DELIM_UNSPECIFIED;
392 	  u_flags.blank = BLANK_UNSPECIFIED;
393 	  u_flags.pad = PAD_UNSPECIFIED;
394 	  u_flags.decimal = DECIMAL_UNSPECIFIED;
395 	  u_flags.encoding = ENCODING_UNSPECIFIED;
396 	  u_flags.async = ASYNC_UNSPECIFIED;
397 	  u_flags.round = ROUND_UNSPECIFIED;
398 	  u_flags.sign = SIGN_UNSPECIFIED;
399 	  u_flags.status = STATUS_UNKNOWN;
400 	  u_flags.convert = GFC_CONVERT_NATIVE;
401 	  u_flags.share = SHARE_UNSPECIFIED;
402 	  u_flags.cc = CC_UNSPECIFIED;
403 
404 	  opp.common = fpp->common;
405 	  opp.common.flags &= IOPARM_COMMON_MASK;
406 	  u = new_unit (&opp, u, &u_flags);
407 	  if (u == NULL)
408 	    return;
409 	  u->endfile = AFTER_ENDFILE;
410 	  u->last_char = EOF - 1;
411 	}
412     }
413 
414  done:
415   if (ASYNC_IO && u->au && needs_unlock)
416     UNLOCK (&u->au->io_lock);
417 
418   unlock_unit (u);
419 
420   library_end ();
421 }
422 
423 
424 extern void st_rewind (st_parameter_filepos *);
425 export_proto(st_rewind);
426 
427 void
st_rewind(st_parameter_filepos * fpp)428 st_rewind (st_parameter_filepos *fpp)
429 {
430   gfc_unit *u;
431   bool needs_unlock = true;
432 
433   library_start (&fpp->common);
434 
435   u = find_unit (fpp->common.unit);
436   if (u != NULL)
437     {
438       if (u->flags.access == ACCESS_DIRECT)
439 	generate_error (&fpp->common, LIBERROR_BAD_OPTION,
440 			"Cannot REWIND a file opened for DIRECT access");
441       else
442 	{
443 	  if (ASYNC_IO && u->au)
444 	    {
445 	      if (async_wait (&(fpp->common), u->au))
446 		return;
447 	      else
448 		{
449 		  needs_unlock = true;
450 		  LOCK (&u->au->io_lock);
451 		}
452 	    }
453 
454 	  /* If there are previously written bytes from a write with ADVANCE="no",
455 	     add a record marker before performing the ENDFILE.  */
456 
457 	  if (u->previous_nonadvancing_write)
458 	    finish_last_advance_record (u);
459 
460 	  u->previous_nonadvancing_write = 0;
461 
462 	  fbuf_reset (u);
463 
464 	  u->last_record = 0;
465 
466 	  if (sseek (u->s, 0, SEEK_SET) < 0)
467 	    {
468 	      generate_error (&fpp->common, LIBERROR_OS, NULL);
469 	      library_end ();
470 	      return;
471 	    }
472 
473 	  /* Set this for compatibilty with g77 for /dev/null.  */
474 	  if (ssize (u->s) == 0)
475 	    u->endfile = AT_ENDFILE;
476 	  else
477 	    {
478 	      /* We are rewinding so we are not at the end.  */
479 	      u->endfile = NO_ENDFILE;
480 	    }
481 
482 	  u->current_record = 0;
483 	  u->strm_pos = 1;
484 	  u->read_bad = 0;
485 	  u->last_char = EOF - 1;
486 	}
487       /* Update position for INQUIRE.  */
488       u->flags.position = POSITION_REWIND;
489 
490       if (ASYNC_IO && u->au && needs_unlock)
491 	UNLOCK (&u->au->io_lock);
492 
493       unlock_unit (u);
494     }
495 
496   library_end ();
497 }
498 
499 
500 extern void st_flush (st_parameter_filepos *);
501 export_proto(st_flush);
502 
503 void
st_flush(st_parameter_filepos * fpp)504 st_flush (st_parameter_filepos *fpp)
505 {
506   gfc_unit *u;
507   bool needs_unlock = false;
508 
509   library_start (&fpp->common);
510 
511   u = find_unit (fpp->common.unit);
512   if (u != NULL)
513     {
514       if (ASYNC_IO && u->au)
515 	{
516 	  if (async_wait (&(fpp->common), u->au))
517 	    return;
518 	  else
519 	    {
520 	      needs_unlock = true;
521 	      LOCK (&u->au->io_lock);
522 	    }
523 	}
524 
525       /* Make sure format buffer is flushed.  */
526       if (u->flags.form == FORM_FORMATTED)
527         fbuf_flush (u, u->mode);
528 
529       sflush (u->s);
530       u->last_char = EOF - 1;
531       unlock_unit (u);
532     }
533   else
534     /* FLUSH on unconnected unit is illegal: F95 std., 9.3.5. */
535     generate_error (&fpp->common, -LIBERROR_BAD_UNIT,
536 			"Specified UNIT in FLUSH is not connected");
537 
538   if (needs_unlock)
539     UNLOCK (&u->au->io_lock);
540 
541   library_end ();
542 }
543