gcc/libgfortran/io/fbuf.c
Jerry DeLisle cea93abbe2 re PR libfortran/35863 ([F2003] Implement ENCODING="UTF-8")
2008-06-13  Jerry DeLisle  <jvdelisle@gcc.gnu.org>

	PR fortran/35863
	* libgfortran.h: Change l8_to_l4_offset to big_endian and add endian_off.
	* runtime/main.c: Fix error in comment. Change l8_to_l4_offset to
	big_endian. (determine_endianness): Add endian_off and set its value
	according to big_endian.
	* gfortran.map: Add symbol for new _gfortran_transfer_character_wide.
	* io/io.h: Add prototype declarations for new functions.
	* io/list_read.c (list_formatted_read_scalar): Modify to handle kind=4.
	(list_formatted_read): Calculate stride based on kind for character type
	and use it when calling list_formatted_read_scalar.
	* io/inquire.c (inquire_via_unit): Change l8_to_l4_offset to big_endian.
	* io/open.c (st_open): Change l8_to_l4_offset to big_endian.
	* io/read.c (read_a_char4): New function to handle formatted read.
	* io/write.c: Define GFC_CHAR4(x) to improve readability of code.
	(write_a_char4): New function to handle formatted write.
	(write_character): Modify to accept the kind parameter and adjust for
	endianess of the machine. (list_formatted_write): Calculate the stride
	resulting from the kind and adjust the list_formatted_write_scalar call
	accordingly. (nml_write_obj): Adjust calls to write_character.
	(namelist_write): Likewise.
	* io/transfer.c (formatted_transfer_scaler): Rename 'len' argument to
	'kind' argument to better describe what it is. Add calls to new
	functions for kind == 4. (formatted_transfer): Modify to handle the case
	of type character and kind equals 4 to pass in the kind to the transfer
	routines. (transfer_character_wide): Add this new function.
	(transfer_array): Don't set kind to the character string length. Adjust
	strides bases on character kind.
	(unformatted_read): Adjust size based on kind for character types.
	(unformatted_write): Likewise. (data_transfer_init): Change
	l8_to_l4_offset to big_endian.

From-SVN: r136763
2008-06-13 20:28:08 +00:00

165 lines
4.4 KiB
C

/* Copyright (C) 2008 Free Software Foundation, Inc.
Contributed by Janne Blomqvist
This file is part of the GNU Fortran runtime library (libgfortran).
Libgfortran is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
In addition to the permissions in the GNU General Public License, the
Free Software Foundation gives you unlimited permission to link the
compiled version of this file into combinations with other programs,
and to distribute those combinations without any restriction coming
from the use of this file. (The General Public License restrictions
do apply in other respects; for example, they cover modification of
the file, and distribution when not linked into a combine
executable.)
Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with Libgfortran; see the file COPYING. If not, write to
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
Boston, MA 02110-1301, USA. */
#include "io.h"
#include <string.h>
#include <stdlib.h>
void
fbuf_init (gfc_unit * u, size_t len)
{
if (len == 0)
len = 512; /* Default size. */
u->fbuf = get_mem (sizeof (fbuf));
u->fbuf->buf = get_mem (len);
u->fbuf->len = len;
u->fbuf->act = u->fbuf->flushed = u->fbuf->pos = 0;
}
void
fbuf_reset (gfc_unit * u)
{
u->fbuf->act = u->fbuf->flushed = u->fbuf->pos = 0;
}
void
fbuf_destroy (gfc_unit * u)
{
if (u->fbuf == NULL)
return;
if (u->fbuf->buf)
free_mem (u->fbuf->buf);
free_mem (u->fbuf);
}
/* Return a pointer to the current position in the buffer, and increase
the pointer by len. Makes sure that the buffer is big enough,
reallocating if necessary. If the buffer is not big enough, there are
three cases to consider:
1. If we haven't flushed anything, realloc
2. If we have flushed enough that by discarding the flushed bytes
the request fits into the buffer, do that.
3. Else allocate a new buffer, memcpy unflushed active bytes from old
buffer. */
char *
fbuf_alloc (gfc_unit * u, size_t len)
{
size_t newlen;
char *dest;
if (u->fbuf->pos + len > u->fbuf->len)
{
if (u->fbuf->flushed == 0)
{
/* Round up to nearest multiple of the current buffer length. */
newlen = ((u->fbuf->pos + len) / u->fbuf->len + 1) * u->fbuf->len;
dest = realloc (u->fbuf->buf, newlen);
if (dest == NULL)
return NULL;
u->fbuf->buf = dest;
u->fbuf->len = newlen;
}
else if (u->fbuf->act - u->fbuf->flushed + len < u->fbuf->len)
{
memmove (u->fbuf->buf, u->fbuf->buf + u->fbuf->flushed,
u->fbuf->act - u->fbuf->flushed);
u->fbuf->act -= u->fbuf->flushed;
u->fbuf->pos -= u->fbuf->flushed;
u->fbuf->flushed = 0;
}
else
{
/* Most general case, flushed != 0, request doesn't fit. */
newlen = ((u->fbuf->pos - u->fbuf->flushed + len)
/ u->fbuf->len + 1) * u->fbuf->len;
dest = get_mem (newlen);
memcpy (dest, u->fbuf->buf + u->fbuf->flushed,
u->fbuf->act - u->fbuf->flushed);
u->fbuf->act -= u->fbuf->flushed;
u->fbuf->pos -= u->fbuf->flushed;
u->fbuf->flushed = 0;
u->fbuf->buf = dest;
u->fbuf->len = newlen;
}
}
dest = u->fbuf->buf + u->fbuf->pos;
u->fbuf->pos += len;
if (u->fbuf->pos > u->fbuf->act)
u->fbuf->act = u->fbuf->pos;
return dest;
}
int
fbuf_flush (gfc_unit * u, int record_done)
{
int status;
size_t nbytes;
if (!u->fbuf)
return 0;
if (u->fbuf->act - u->fbuf->flushed != 0)
{
if (record_done)
nbytes = u->fbuf->act - u->fbuf->flushed;
else
nbytes = u->fbuf->pos - u->fbuf->flushed;
status = swrite (u->s, u->fbuf->buf + u->fbuf->flushed, &nbytes);
u->fbuf->flushed += nbytes;
}
else
status = 0;
if (record_done)
fbuf_reset (u);
return status;
}
int
fbuf_seek (gfc_unit * u, gfc_offset off)
{
gfc_offset pos = u->fbuf->pos + off;
/* Moving to the left past the flushed marked would imply moving past
the left tab limit, which is never allowed. So return error if
that is attempted. */
if (pos < (gfc_offset) u->fbuf->flushed)
return -1;
u->fbuf->pos = pos;
return 0;
}