#include "config.h"
#include <string.h>
#include "libgfortran.h"
#include "io.h"
#define READ_CHUNK 4096
static void
formatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
gfc_offset base;
char *p;
int n;
base = file_position (u->s) - 1;
do
{
n = (base < READ_CHUNK) ? base : READ_CHUNK;
base -= n;
p = salloc_r_at (u->s, &n, base);
if (p == NULL)
goto io_error;
n--;
while (n >= 0)
{
if (p[n] == '\n')
{
base += n + 1;
goto done;
}
n--;
}
}
while (base != 0);
done:
if (sseek (u->s, base) == FAILURE)
goto io_error;
u->last_record--;
u->endfile = NO_ENDFILE;
return;
io_error:
generate_error (&fpp->common, ERROR_OS, NULL);
}
static void
unformatted_backspace (st_parameter_filepos *fpp, gfc_unit *u)
{
gfc_offset m, new;
GFC_INTEGER_4 m4;
GFC_INTEGER_8 m8;
int length, length_read;
int continued;
char *p;
if (compile_options.record_marker == 0)
length = sizeof (GFC_INTEGER_4);
else
length = compile_options.record_marker;
do
{
length_read = length;
p = salloc_r_at (u->s, &length_read,
file_position (u->s) - length);
if (p == NULL || length_read != length)
goto io_error;
if (u->flags.convert == CONVERT_NATIVE)
{
switch (length)
{
case sizeof(GFC_INTEGER_4):
memcpy (&m4, p, sizeof (m4));
m = m4;
break;
case sizeof(GFC_INTEGER_8):
memcpy (&m8, p, sizeof (m8));
m = m8;
break;
default:
runtime_error ("Illegal value for record marker");
break;
}
}
else
{
switch (length)
{
case sizeof(GFC_INTEGER_4):
reverse_memcpy (&m4, p, sizeof (m4));
m = m4;
break;
case sizeof(GFC_INTEGER_8):
reverse_memcpy (&m8, p, sizeof (m8));
m = m8;
break;
default:
runtime_error ("Illegal value for record marker");
break;
}
}
continued = m < 0;
if (continued)
m = -m;
if ((new = file_position (u->s) - m - 2*length) < 0)
new = 0;
if (sseek (u->s, new) == FAILURE)
goto io_error;
} while (continued);
u->last_record--;
return;
io_error:
generate_error (&fpp->common, ERROR_OS, NULL);
}
extern void st_backspace (st_parameter_filepos *);
export_proto(st_backspace);
void
st_backspace (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u == NULL)
{
generate_error (&fpp->common, ERROR_BAD_UNIT, NULL);
goto done;
}
if (u->flags.access == ACCESS_DIRECT || u->flags.access == ACCESS_STREAM)
goto done;
if (u->endfile == AFTER_ENDFILE)
{
u->endfile = AT_ENDFILE;
flush (u->s);
struncate (u->s);
}
else
{
if (file_position (u->s) == 0)
goto done;
if (u->mode == WRITING)
{
flush (u->s);
struncate (u->s);
u->mode = READING;
}
if (u->flags.form == FORM_FORMATTED)
formatted_backspace (fpp, u);
else
unformatted_backspace (fpp, u);
u->endfile = NO_ENDFILE;
u->current_record = 0;
u->bytes_left = 0;
}
done:
if (u != NULL)
unlock_unit (u);
library_end ();
}
extern void st_endfile (st_parameter_filepos *);
export_proto(st_endfile);
void
st_endfile (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u != NULL)
{
if (u->current_record)
{
st_parameter_dt dtp;
dtp.common = fpp->common;
memset (&dtp.u.p, 0, sizeof (dtp.u.p));
dtp.u.p.current_unit = u;
next_record (&dtp, 1);
}
flush (u->s);
struncate (u->s);
u->endfile = AFTER_ENDFILE;
unlock_unit (u);
}
library_end ();
}
extern void st_rewind (st_parameter_filepos *);
export_proto(st_rewind);
void
st_rewind (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u != NULL)
{
if (u->flags.access == ACCESS_DIRECT)
generate_error (&fpp->common, ERROR_BAD_OPTION,
"Cannot REWIND a file opened for DIRECT access");
else
{
flush (u->s);
if (u->mode == WRITING && u->flags.access != ACCESS_STREAM)
struncate (u->s);
u->mode = READING;
u->last_record = 0;
if (sseek (u->s, 0) == FAILURE)
generate_error (&fpp->common, ERROR_OS, NULL);
u->endfile = NO_ENDFILE;
u->current_record = 0;
u->strm_pos = 1;
u->read_bad = 0;
test_endfile (u);
}
u->flags.position = POSITION_REWIND;
unlock_unit (u);
}
library_end ();
}
extern void st_flush (st_parameter_filepos *);
export_proto(st_flush);
void
st_flush (st_parameter_filepos *fpp)
{
gfc_unit *u;
library_start (&fpp->common);
u = find_unit (fpp->common.unit);
if (u != NULL)
{
flush (u->s);
unlock_unit (u);
}
else
generate_error (&fpp->common, ERROR_BAD_OPTION,
"Specified UNIT in FLUSH is not connected");
library_end ();
}