void
st_close (st_parameter_close *clp)
{
close_status status;
gfc_unit *u;
#if !HAVE_UNLINK_OPEN_FILE
char * path;
path = NULL;
#endif
library_start (&clp->common);
status = !(clp->common.flags & IOPARM_CLOSE_HAS_STATUS) ? CLOSE_UNSPECIFIED :
find_option (&clp->common, clp->status, clp->status_len,
status_opt, "Bad STATUS parameter in CLOSE statement");
if ((clp->common.flags & IOPARM_LIBRETURN_MASK) != IOPARM_LIBRETURN_OK)
{
library_end ();
return;
}
u = find_unit (clp->common.unit);
if (u != NULL)
{
if (u->flags.status == STATUS_SCRATCH)
{
if (status == CLOSE_KEEP)
generate_error (&clp->common, LIBERROR_BAD_OPTION,
"Can't KEEP a scratch file on CLOSE");
#if !HAVE_UNLINK_OPEN_FILE
path = (char *) gfc_alloca (u->file_len + 1);
unpack_filename (path, u->file, u->file_len);
#endif
}
else
{
if (status == CLOSE_DELETE)
{
#if HAVE_UNLINK_OPEN_FILE
delete_file (u);
#else
path = (char *) gfc_alloca (u->file_len + 1);
unpack_filename (path, u->file, u->file_len);
#endif
}
}
close_unit (u);
#if !HAVE_UNLINK_OPEN_FILE
if (path != NULL)
unlink (path);
#endif
}
/* CLOSE on unconnected unit is legal and a no-op: F95 std., 9.3.5. */
library_end ();
}
void
link_i8_sub (char *path1, char *path2, GFC_INTEGER_8 *status,
gfc_charlen_type path1_len, gfc_charlen_type path2_len)
{
int val;
char *str1, *str2;
/* Trim trailing spaces from paths. */
while (path1_len > 0 && path1[path1_len - 1] == ' ')
path1_len--;
while (path2_len > 0 && path2[path2_len - 1] == ' ')
path2_len--;
/* Make a null terminated copy of the strings. */
str1 = gfc_alloca (path1_len + 1);
memcpy (str1, path1, path1_len);
str1[path1_len] = '\0';
str2 = gfc_alloca (path2_len + 1);
memcpy (str2, path2, path2_len);
str2[path2_len] = '\0';
val = link (str1, str2);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
static void
read_default_char4 (st_parameter_dt *dtp, char *p, int len, size_t width)
{
char *s;
gfc_char4_t *dest;
int m, n, status;
s = gfc_alloca (width);
status = read_block_form (dtp, s, &width);
if (status == FAILURE)
return;
if (width > (size_t) len)
s += (width - len);
m = ((int) width > len) ? len : (int) width;
dest = (gfc_char4_t *) p;
for (n = 0; n < m; n++, dest++, s++)
*dest = (unsigned char ) *s;
for (n = 0; n < len - (int) width; n++, dest++)
*dest = (unsigned char) ' ';
}
int
chmod_func (char *name, char *mode, gfc_charlen_type name_len,
gfc_charlen_type mode_len)
{
char * file, * m;
pid_t pid;
int status;
/* Trim trailing spaces. */
while (name_len > 0 && name[name_len - 1] == ' ')
name_len--;
while (mode_len > 0 && mode[mode_len - 1] == ' ')
mode_len--;
/* Make a null terminated copy of the strings. */
file = gfc_alloca (name_len + 1);
memcpy (file, name, name_len);
file[name_len] = '\0';
m = gfc_alloca (mode_len + 1);
memcpy (m, mode, mode_len);
m[mode_len]= '\0';
/* Execute /bin/chmod. */
if ((pid = fork()) < 0)
return errno;
if (pid == 0)
{
/* Child process. */
execl ("/bin/chmod", "chmod", m, file, (char *) NULL);
return errno;
}
else
wait (&status);
if (WIFEXITED(status))
return WEXITSTATUS(status);
else
return -1;
}
static void
already_open (st_parameter_open *opp, gfc_unit * u, unit_flags * flags)
{
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
{
edit_modes (opp, u, flags);
return;
}
/* If the file is connected to something else, close it and open a
new unit. */
if (!compare_file_filename (u, opp->file, opp->file_len))
{
#if !HAVE_UNLINK_OPEN_FILE
char *path = NULL;
if (u->file && u->flags.status == STATUS_SCRATCH)
{
path = (char *) gfc_alloca (u->file_len + 1);
unpack_filename (path, u->file, u->file_len);
}
#endif
if (sclose (u->s) == FAILURE)
{
unlock_unit (u);
generate_error (&opp->common, LIBERROR_OS,
"Error closing file in OPEN statement");
return;
}
u->s = NULL;
if (u->file)
free_mem (u->file);
u->file = NULL;
u->file_len = 0;
#if !HAVE_UNLINK_OPEN_FILE
if (path != NULL)
unlink (path);
#endif
u = new_unit (opp, u, flags);
if (u != NULL)
unlock_unit (u);
return;
}
edit_modes (opp, u, flags);
}
void
perror_sub (char *string, gfc_charlen_type string_len)
{
char * str;
/* Trim trailing spaces from paths. */
while (string_len > 0 && string[string_len - 1] == ' ')
string_len--;
/* Make a null terminated copy of the strings. */
str = gfc_alloca (string_len + 1);
memcpy (str, string, string_len);
str[string_len] = '\0';
perror (str);
}
void
read_l (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
char *p;
size_t w;
w = f->u.w;
p = gfc_alloca (w);
if (read_block_form (dtp, p, &w) == FAILURE)
return;
while (*p == ' ')
{
if (--w == 0)
goto bad;
p++;
}
if (*p == '.')
{
if (--w == 0)
goto bad;
p++;
}
switch (*p)
{
case 't':
case 'T':
set_integer (dest, (GFC_INTEGER_LARGEST) 1, length);
break;
case 'f':
case 'F':
set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
break;
default:
bad:
generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value on logical read");
next_record (dtp, 1);
break;
}
}
void
chdir_i8_sub (char *dir, GFC_INTEGER_8 *status, gfc_charlen_type dir_len)
{
int val;
char *str;
/* Trim trailing spaces from paths. */
while (dir_len > 0 && dir[dir_len - 1] == ' ')
dir_len--;
/* Make a null terminated copy of the strings. */
str = gfc_alloca (dir_len + 1);
memcpy (str, dir, dir_len);
str[dir_len] = '\0';
val = chdir (str);
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
void
unlink_i4_sub (char *name, GFC_INTEGER_4 *status, gfc_charlen_type name_len)
{
char *str;
GFC_INTEGER_4 stat;
/* Trim trailing spaces from name. */
while (name_len > 0 && name[name_len - 1] == ' ')
name_len--;
/* Make a null terminated copy of the string. */
str = gfc_alloca (name_len + 1);
memcpy (str, name, name_len);
str[name_len] = '\0';
stat = unlink (str);
if (status != NULL)
*status = (stat == 0) ? stat : errno;
}
static void
read_default_char1 (st_parameter_dt *dtp, char *p, int len, size_t width)
{
char *s;
int m, n, status;
s = gfc_alloca (width);
status = read_block_form (dtp, s, &width);
if (status == FAILURE)
return;
if (width > (size_t) len)
s += (width - len);
m = ((int) width > len) ? len : (int) width;
memcpy (p, s, m);
n = len - width;
if (n > 0)
memset (p + m, ' ', n);
}
void
PREFIX(getenv) (char * name, char * value, gfc_charlen_type name_len,
gfc_charlen_type value_len)
{
char *name_nt;
char *res = NULL;
int res_len;
if (name == NULL || value == NULL)
runtime_error ("Both arguments to getenv are mandatory.");
if (value_len < 1 || name_len < 1)
runtime_error ("Zero length string(s) passed to getenv.");
else
memset (value, ' ', value_len); /* Blank the string. */
/* Trim trailing spaces from name. */
while (name_len > 0 && name[name_len - 1] == ' ')
name_len--;
/* Make a null terminated copy of the string. */
name_nt = gfc_alloca (name_len + 1);
memcpy (name_nt, name, name_len);
name_nt[name_len] = '\0';
res = getenv(name_nt);
/* If res is NULL, it means that the environment variable didn't
exist, so just return. */
if (res == NULL)
return;
res_len = strlen(res);
if (value_len < res_len)
memcpy (value, res, value_len);
else
memcpy (value, res, res_len);
}
void
read_radix (st_parameter_dt *dtp, const fnode *f, char *dest, int length,
int radix)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_r;
GFC_INTEGER_LARGEST v;
int w, negative;
char c, *p;
size_t wu;
wu = f->u.w;
p = gfc_alloca (wu);
if (read_block_form (dtp, p, &wu) == FAILURE)
return;
w = wu;
p = eat_leading_spaces (&w, p);
if (w == 0)
{
set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
return;
}
maxv = max_value (length, 0);
maxv_r = maxv / radix;
negative = 0;
value = 0;
switch (*p)
{
case '-':
negative = 1;
/* Fall through */
case '+':
p++;
if (--w == 0)
goto bad;
/* Fall through */
default:
break;
}
/* At this point we have a digit-string */
value = 0;
for (;;)
{
c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
if (dtp->u.p.blank_status == BLANK_NULL) continue;
if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
switch (radix)
{
case 2:
if (c < '0' || c > '1')
goto bad;
break;
case 8:
if (c < '0' || c > '7')
goto bad;
break;
case 16:
switch (c)
{
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
break;
case 'a':
case 'b':
case 'c':
case 'd':
case 'e':
case 'f':
c = c - 'a' + '9' + 1;
break;
case 'A':
case 'B':
case 'C':
case 'D':
case 'E':
case 'F':
c = c - 'A' + '9' + 1;
break;
default:
goto bad;
}
break;
}
if (value > maxv_r)
goto overflow;
c -= '0';
value = radix * value;
if (maxv - c < value)
goto overflow;
value += c;
}
v = value;
if (negative)
v = -v;
set_integer (dest, v, length);
return;
bad:
generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during integer read");
next_record (dtp, 1);
return;
overflow:
generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
"Value overflowed during integer read");
next_record (dtp, 1);
}
int
chmod_func (char *name, char *mode, gfc_charlen_type name_len,
gfc_charlen_type mode_len)
{
char * file;
int i;
bool ugo[3];
bool rwxXstugo[9];
int set_mode, part;
bool honor_umask, continue_clause = false;
#ifndef __MINGW32__
bool is_dir;
#endif
mode_t mode_mask, file_mode, new_mode;
struct stat stat_buf;
/* Trim trailing spaces of the file name. */
while (name_len > 0 && name[name_len - 1] == ' ')
name_len--;
/* Make a null terminated copy of the file name. */
file = gfc_alloca (name_len + 1);
memcpy (file, name, name_len);
file[name_len] = '\0';
if (mode_len == 0)
return 1;
if (mode[0] >= '0' && mode[0] <= '9')
{
#ifdef __MINGW32__
unsigned fmode;
if (sscanf (mode, "%o", &fmode) != 1)
return 1;
file_mode = (mode_t) fmode;
#else
if (sscanf (mode, "%o", &file_mode) != 1)
return 1;
#endif
return chmod (file, file_mode);
}
/* Read the current file mode. */
if (stat (file, &stat_buf))
return 1;
file_mode = stat_buf.st_mode & ~S_IFMT;
#ifndef __MINGW32__
is_dir = stat_buf.st_mode & S_IFDIR;
#endif
#ifdef HAVE_UMASK
/* Obtain the umask without distroying the setting. */
mode_mask = 0;
mode_mask = umask (mode_mask);
(void) umask (mode_mask);
#else
honor_umask = false;
#endif
for (i = 0; i < mode_len; i++)
{
if (!continue_clause)
{
ugo[0] = false;
ugo[1] = false;
ugo[2] = false;
#ifdef HAVE_UMASK
honor_umask = true;
#endif
}
continue_clause = false;
rwxXstugo[0] = false;
rwxXstugo[1] = false;
rwxXstugo[2] = false;
rwxXstugo[3] = false;
rwxXstugo[4] = false;
rwxXstugo[5] = false;
rwxXstugo[6] = false;
rwxXstugo[7] = false;
rwxXstugo[8] = false;
part = 0;
set_mode = -1;
for (; i < mode_len; i++)
{
switch (mode[i])
{
/* User setting: a[ll]/u[ser]/g[roup]/o[ther]. */
case 'a':
if (part > 1)
return 1;
ugo[0] = true;
ugo[1] = true;
ugo[2] = true;
part = 1;
#ifdef HAVE_UMASK
honor_umask = false;
#endif
break;
case 'u':
if (part == 2)
{
rwxXstugo[6] = true;
part = 4;
break;
}
if (part > 1)
return 1;
ugo[0] = true;
part = 1;
#ifdef HAVE_UMASK
honor_umask = false;
#endif
break;
case 'g':
if (part == 2)
{
rwxXstugo[7] = true;
part = 4;
break;
}
if (part > 1)
return 1;
ugo[1] = true;
part = 1;
#ifdef HAVE_UMASK
honor_umask = false;
#endif
break;
case 'o':
if (part == 2)
{
rwxXstugo[8] = true;
part = 4;
break;
}
if (part > 1)
return 1;
ugo[2] = true;
part = 1;
#ifdef HAVE_UMASK
honor_umask = false;
#endif
break;
/* Mode setting: =+-. */
case '=':
if (part > 2)
{
continue_clause = true;
i--;
part = 2;
goto clause_done;
}
set_mode = 1;
part = 2;
break;
case '-':
if (part > 2)
{
continue_clause = true;
i--;
part = 2;
goto clause_done;
}
set_mode = 2;
part = 2;
break;
case '+':
if (part > 2)
{
continue_clause = true;
i--;
part = 2;
goto clause_done;
}
set_mode = 3;
part = 2;
break;
/* Permissions: rwxXst - for ugo see above. */
case 'r':
if (part != 2 && part != 3)
return 1;
rwxXstugo[0] = true;
part = 3;
break;
case 'w':
if (part != 2 && part != 3)
return 1;
rwxXstugo[1] = true;
part = 3;
break;
case 'x':
if (part != 2 && part != 3)
return 1;
rwxXstugo[2] = true;
part = 3;
break;
case 'X':
if (part != 2 && part != 3)
return 1;
rwxXstugo[3] = true;
part = 3;
break;
case 's':
if (part != 2 && part != 3)
return 1;
rwxXstugo[4] = true;
part = 3;
break;
case 't':
if (part != 2 && part != 3)
return 1;
rwxXstugo[5] = true;
part = 3;
break;
/* Tailing blanks are valid in Fortran. */
case ' ':
for (i++; i < mode_len; i++)
if (mode[i] != ' ')
break;
if (i != mode_len)
return 1;
goto clause_done;
case ',':
goto clause_done;
default:
return 1;
}
}
clause_done:
if (part < 2)
return 1;
new_mode = 0;
#ifdef __MINGW32__
/* Read. */
if (rwxXstugo[0] && (ugo[0] || honor_umask))
new_mode |= _S_IREAD;
/* Write. */
if (rwxXstugo[1] && (ugo[0] || honor_umask))
new_mode |= _S_IWRITE;
#else
/* Read. */
if (rwxXstugo[0])
{
if (ugo[0] || honor_umask)
new_mode |= S_IRUSR;
if (ugo[1] || honor_umask)
new_mode |= S_IRGRP;
if (ugo[2] || honor_umask)
new_mode |= S_IROTH;
}
/* Write. */
if (rwxXstugo[1])
{
if (ugo[0] || honor_umask)
new_mode |= S_IWUSR;
if (ugo[1] || honor_umask)
new_mode |= S_IWGRP;
if (ugo[2] || honor_umask)
new_mode |= S_IWOTH;
}
/* Execute. */
if (rwxXstugo[2])
{
if (ugo[0] || honor_umask)
new_mode |= S_IXUSR;
if (ugo[1] || honor_umask)
new_mode |= S_IXGRP;
if (ugo[2] || honor_umask)
new_mode |= S_IXOTH;
}
/* 'X' execute. */
if (rwxXstugo[3]
&& (is_dir || (file_mode & (S_IXUSR | S_IXGRP | S_IXOTH))))
new_mode |= (S_IXUSR | S_IXGRP | S_IXOTH);
/* 's'. */
if (rwxXstugo[4])
{
if (ugo[0] || honor_umask)
new_mode |= S_ISUID;
if (ugo[1] || honor_umask)
new_mode |= S_ISGID;
}
/* As original 'u'. */
if (rwxXstugo[6])
{
if (ugo[1] || honor_umask)
{
if (file_mode & S_IRUSR)
new_mode |= S_IRGRP;
if (file_mode & S_IWUSR)
new_mode |= S_IWGRP;
if (file_mode & S_IXUSR)
new_mode |= S_IXGRP;
}
if (ugo[2] || honor_umask)
{
if (file_mode & S_IRUSR)
new_mode |= S_IROTH;
if (file_mode & S_IWUSR)
new_mode |= S_IWOTH;
if (file_mode & S_IXUSR)
new_mode |= S_IXOTH;
}
}
/* As original 'g'. */
if (rwxXstugo[7])
{
if (ugo[0] || honor_umask)
{
if (file_mode & S_IRGRP)
new_mode |= S_IRUSR;
if (file_mode & S_IWGRP)
new_mode |= S_IWUSR;
if (file_mode & S_IXGRP)
new_mode |= S_IXUSR;
}
if (ugo[2] || honor_umask)
{
if (file_mode & S_IRGRP)
new_mode |= S_IROTH;
if (file_mode & S_IWGRP)
new_mode |= S_IWOTH;
if (file_mode & S_IXGRP)
new_mode |= S_IXOTH;
}
}
/* As original 'o'. */
if (rwxXstugo[8])
{
if (ugo[0] || honor_umask)
{
if (file_mode & S_IROTH)
new_mode |= S_IRUSR;
if (file_mode & S_IWOTH)
new_mode |= S_IWUSR;
if (file_mode & S_IXOTH)
new_mode |= S_IXUSR;
}
if (ugo[1] || honor_umask)
{
if (file_mode & S_IROTH)
new_mode |= S_IRGRP;
if (file_mode & S_IWOTH)
new_mode |= S_IWGRP;
if (file_mode & S_IXOTH)
new_mode |= S_IXGRP;
}
}
#endif /* __MINGW32__ */
#ifdef HAVE_UMASK
if (honor_umask)
new_mode &= ~mode_mask;
#endif
if (set_mode == 1)
{
#ifdef __MINGW32__
if (ugo[0] || honor_umask)
file_mode = (file_mode & ~(_S_IWRITE | _S_IREAD))
| (new_mode & (_S_IWRITE | _S_IREAD));
#else
/* Set '='. */
if ((ugo[0] || honor_umask) && !rwxXstugo[6])
file_mode = (file_mode & ~(S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR))
| (new_mode & (S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR));
if ((ugo[1] || honor_umask) && !rwxXstugo[7])
file_mode = (file_mode & ~(S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP))
| (new_mode & (S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP));
if ((ugo[2] || honor_umask) && !rwxXstugo[8])
file_mode = (file_mode & ~(S_IROTH | S_IWOTH | S_IXOTH))
| (new_mode & (S_IROTH | S_IWOTH | S_IXOTH));
#ifndef __VXWORKS__
if (is_dir && rwxXstugo[5])
file_mode |= S_ISVTX;
else if (!is_dir)
file_mode &= ~S_ISVTX;
#endif
#endif
}
else if (set_mode == 2)
{
/* Clear '-'. */
file_mode &= ~new_mode;
#if !defined( __MINGW32__) && !defined (__VXWORKS__)
if (rwxXstugo[5] || !is_dir)
file_mode &= ~S_ISVTX;
#endif
}
else if (set_mode == 3)
{
file_mode |= new_mode;
#if !defined (__MINGW32__) && !defined (__VXWORKS__)
if (rwxXstugo[5] && is_dir)
file_mode |= S_ISVTX;
else if (!is_dir)
file_mode &= ~S_ISVTX;
#endif
}
}
return chmod (file, file_mode);
}
void
read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
int w, seen_dp, exponent;
int exponent_sign;
const char *p;
char *buffer;
char *out;
int seen_int_digit; /* Seen a digit before the decimal point? */
int seen_dec_digit; /* Seen a digit after the decimal point? */
seen_dp = 0;
seen_int_digit = 0;
seen_dec_digit = 0;
exponent_sign = 1;
exponent = 0;
w = f->u.w;
/* Read in the next block. */
p = read_block_form (dtp, &w);
if (p == NULL)
return;
p = eat_leading_spaces (&w, (char*) p);
if (w == 0)
goto zero;
/* In this buffer we're going to re-format the number cleanly to be parsed
by convert_real in the end; this assures we're using strtod from the
C library for parsing and thus probably get the best accuracy possible.
This process may add a '+0.0' in front of the number as well as change the
exponent because of an implicit decimal point or the like. Thus allocating
strlen ("+0.0e-1000") == 10 characters plus one for NUL more than the
original buffer had should be enough. */
buffer = gfc_alloca (w + 11);
out = buffer;
/* Optional sign */
if (*p == '-' || *p == '+')
{
if (*p == '-')
*(out++) = '-';
++p;
--w;
}
p = eat_leading_spaces (&w, (char*) p);
if (w == 0)
goto zero;
/* Process the mantissa string. */
while (w > 0)
{
switch (*p)
{
case ',':
if (dtp->u.p.current_unit->decimal_status != DECIMAL_COMMA)
goto bad_float;
/* Fall through. */
case '.':
if (seen_dp)
goto bad_float;
if (!seen_int_digit)
*(out++) = '0';
*(out++) = '.';
seen_dp = 1;
break;
case ' ':
if (dtp->u.p.blank_status == BLANK_ZERO)
{
*(out++) = '0';
goto found_digit;
}
else if (dtp->u.p.blank_status == BLANK_NULL)
break;
else
/* TODO: Should we check instead that there are only trailing
blanks here, as is done below for exponents? */
goto done;
/* Fall through. */
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
*(out++) = *p;
found_digit:
if (!seen_dp)
seen_int_digit = 1;
else
seen_dec_digit = 1;
break;
case '-':
case '+':
goto exponent;
case 'e':
case 'E':
case 'd':
case 'D':
++p;
--w;
goto exponent;
default:
goto bad_float;
}
++p;
--w;
}
/* No exponent has been seen, so we use the current scale factor. */
exponent = - dtp->u.p.scale_factor;
goto done;
/* At this point the start of an exponent has been found. */
exponent:
p = eat_leading_spaces (&w, (char*) p);
if (*p == '-' || *p == '+')
{
if (*p == '-')
exponent_sign = -1;
++p;
--w;
}
/* At this point a digit string is required. We calculate the value
of the exponent in order to take account of the scale factor and
the d parameter before explict conversion takes place. */
if (w == 0)
goto bad_float;
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
{
while (w > 0 && isdigit (*p))
{
exponent *= 10;
exponent += *p - '0';
++p;
--w;
}
/* Only allow trailing blanks. */
while (w > 0)
{
if (*p != ' ')
goto bad_float;
++p;
--w;
}
}
else /* BZ or BN status is enabled. */
{
while (w > 0)
{
if (*p == ' ')
{
if (dtp->u.p.blank_status == BLANK_ZERO)
exponent *= 10;
else
assert (dtp->u.p.blank_status == BLANK_NULL);
}
else if (!isdigit (*p))
goto bad_float;
else
{
exponent *= 10;
exponent += *p - '0';
}
++p;
--w;
}
}
exponent *= exponent_sign;
done:
/* Use the precision specified in the format if no decimal point has been
seen. */
if (!seen_dp)
exponent -= f->u.real.d;
/* Output a trailing '0' after decimal point if not yet found. */
if (seen_dp && !seen_dec_digit)
*(out++) = '0';
/* Print out the exponent to finish the reformatted number. Maximum 4
digits for the exponent. */
if (exponent != 0)
{
int dig;
*(out++) = 'e';
if (exponent < 0)
{
*(out++) = '-';
exponent = - exponent;
}
assert (exponent < 10000);
for (dig = 3; dig >= 0; --dig)
{
out[dig] = (char) ('0' + exponent % 10);
exponent /= 10;
}
out += 4;
}
*(out++) = '\0';
/* Do the actual conversion. */
convert_real (dtp, dest, buffer, length);
return;
/* The value read is zero. */
zero:
switch (length)
{
case 4:
*((GFC_REAL_4 *) dest) = 0.0;
break;
case 8:
*((GFC_REAL_8 *) dest) = 0.0;
break;
#ifdef HAVE_GFC_REAL_10
case 10:
*((GFC_REAL_10 *) dest) = 0.0;
break;
#endif
#ifdef HAVE_GFC_REAL_16
case 16:
*((GFC_REAL_16 *) dest) = 0.0;
break;
#endif
default:
internal_error (&dtp->common, "Unsupported real kind during IO");
}
return;
bad_float:
generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during floating point read");
next_record (dtp, 1);
return;
}
void
read_decimal (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
GFC_UINTEGER_LARGEST value, maxv, maxv_10;
GFC_INTEGER_LARGEST v;
int w, negative;
size_t wu;
char c, *p;
wu = f->u.w;
p = gfc_alloca (wu);
if (read_block_form (dtp, p, &wu) == FAILURE)
return;
w = wu;
p = eat_leading_spaces (&w, p);
if (w == 0)
{
set_integer (dest, (GFC_INTEGER_LARGEST) 0, length);
return;
}
maxv = max_value (length, 1);
maxv_10 = maxv / 10;
negative = 0;
value = 0;
switch (*p)
{
case '-':
negative = 1;
/* Fall through */
case '+':
p++;
if (--w == 0)
goto bad;
/* Fall through */
default:
break;
}
/* At this point we have a digit-string */
value = 0;
for (;;)
{
c = next_char (dtp, &p, &w);
if (c == '\0')
break;
if (c == ' ')
{
if (dtp->u.p.blank_status == BLANK_NULL) continue;
if (dtp->u.p.blank_status == BLANK_ZERO) c = '0';
}
if (c < '0' || c > '9')
goto bad;
if (value > maxv_10 && compile_options.range_check == 1)
goto overflow;
c -= '0';
value = 10 * value;
if (value > maxv - c && compile_options.range_check == 1)
goto overflow;
value += c;
}
v = value;
if (negative)
v = -v;
set_integer (dest, v, length);
return;
bad:
generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during integer read");
next_record (dtp, 1);
return;
overflow:
generate_error (&dtp->common, LIBERROR_READ_OVERFLOW,
"Value overflowed during integer read");
next_record (dtp, 1);
}
gfc_unit *
new_unit (st_parameter_open *opp, gfc_unit *u, unit_flags * flags)
{
gfc_unit *u2;
stream *s;
char tmpname[5 /* fort. */ + 10 /* digits of unit number */ + 1 /* 0 */];
/* Change unspecifieds to defaults. Leave (flags->action ==
ACTION_UNSPECIFIED) alone so open_external() can set it based on
what type of open actually works. */
if (flags->access == ACCESS_UNSPECIFIED)
flags->access = ACCESS_SEQUENTIAL;
if (flags->form == FORM_UNSPECIFIED)
flags->form = (flags->access == ACCESS_SEQUENTIAL)
? FORM_FORMATTED : FORM_UNFORMATTED;
if (flags->async == ASYNC_UNSPECIFIED)
flags->async = ASYNC_NO;
if (flags->status == STATUS_UNSPECIFIED)
flags->status = STATUS_UNKNOWN;
/* Checks. */
if (flags->delim == DELIM_UNSPECIFIED)
flags->delim = DELIM_NONE;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DELIM parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->blank == BLANK_UNSPECIFIED)
flags->blank = BLANK_NULL;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"BLANK parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->pad == PAD_UNSPECIFIED)
flags->pad = PAD_YES;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"PAD parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->decimal == DECIMAL_UNSPECIFIED)
flags->decimal = DECIMAL_POINT;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"DECIMAL parameter conflicts with UNFORMATTED form "
"in OPEN statement");
goto fail;
}
}
if (flags->encoding == ENCODING_UNSPECIFIED)
flags->encoding = ENCODING_DEFAULT;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ENCODING parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
/* NB: the value for ROUND when it's not specified by the user does not
have to be PROCESSOR_DEFINED; the standard says that it is
processor dependent, and requires that it is one of the
possible value (see F2003, 9.4.5.13). */
if (flags->round == ROUND_UNSPECIFIED)
flags->round = ROUND_PROCDEFINED;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ROUND parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->sign == SIGN_UNSPECIFIED)
flags->sign = SIGN_PROCDEFINED;
else
{
if (flags->form == FORM_UNFORMATTED)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"SIGN parameter conflicts with UNFORMATTED form in "
"OPEN statement");
goto fail;
}
}
if (flags->position != POSITION_ASIS && flags->access == ACCESS_DIRECT)
{
generate_error (&opp->common, LIBERROR_OPTION_CONFLICT,
"ACCESS parameter conflicts with SEQUENTIAL access in "
"OPEN statement");
goto fail;
}
else
if (flags->position == POSITION_UNSPECIFIED)
flags->position = POSITION_ASIS;
if (flags->access == ACCESS_DIRECT
&& (opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) == 0)
{
generate_error (&opp->common, LIBERROR_MISSING_OPTION,
"Missing RECL parameter in OPEN statement");
goto fail;
}
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN) && opp->recl_in <= 0)
{
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"RECL parameter is non-positive in OPEN statement");
goto fail;
}
switch (flags->status)
{
case STATUS_SCRATCH:
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) == 0)
{
opp->file = NULL;
break;
}
generate_error (&opp->common, LIBERROR_BAD_OPTION,
"FILE parameter must not be present in OPEN statement");
goto fail;
case STATUS_OLD:
case STATUS_NEW:
case STATUS_REPLACE:
case STATUS_UNKNOWN:
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE))
break;
opp->file = tmpname;
opp->file_len = snprintf(opp->file, sizeof (tmpname), "fort.%d",
(int) opp->common.unit);
break;
default:
internal_error (&opp->common, "new_unit(): Bad status");
}
/* Make sure the file isn't already open someplace else.
Do not error if opening file preconnected to stdin, stdout, stderr. */
u2 = NULL;
if ((opp->common.flags & IOPARM_OPEN_HAS_FILE) != 0)
u2 = find_file (opp->file, opp->file_len);
if (u2 != NULL
&& (options.stdin_unit < 0 || u2->unit_number != options.stdin_unit)
&& (options.stdout_unit < 0 || u2->unit_number != options.stdout_unit)
&& (options.stderr_unit < 0 || u2->unit_number != options.stderr_unit))
{
unlock_unit (u2);
generate_error (&opp->common, LIBERROR_ALREADY_OPEN, NULL);
goto cleanup;
}
if (u2 != NULL)
unlock_unit (u2);
/* Open file. */
s = open_external (opp, flags);
if (s == NULL)
{
char *path, *msg;
size_t msglen;
path = (char *) gfc_alloca (opp->file_len + 1);
msglen = opp->file_len + 51;
msg = (char *) gfc_alloca (msglen);
unpack_filename (path, opp->file, opp->file_len);
switch (errno)
{
case ENOENT:
snprintf (msg, msglen, "File '%s' does not exist", path);
break;
case EEXIST:
snprintf (msg, msglen, "File '%s' already exists", path);
break;
case EACCES:
snprintf (msg, msglen,
"Permission denied trying to open file '%s'", path);
break;
case EISDIR:
snprintf (msg, msglen, "'%s' is a directory", path);
break;
default:
msg = NULL;
}
generate_error (&opp->common, LIBERROR_OS, msg);
goto cleanup;
}
if (flags->status == STATUS_NEW || flags->status == STATUS_REPLACE)
flags->status = STATUS_OLD;
/* Create the unit structure. */
u->file = xmalloc (opp->file_len);
if (u->unit_number != opp->common.unit)
internal_error (&opp->common, "Unit number changed");
u->s = s;
u->flags = *flags;
u->read_bad = 0;
u->endfile = NO_ENDFILE;
u->last_record = 0;
u->current_record = 0;
u->mode = READING;
u->maxrec = 0;
u->bytes_left = 0;
u->saved_pos = 0;
if (flags->position == POSITION_APPEND)
{
if (sseek (u->s, 0, SEEK_END) < 0)
generate_error (&opp->common, LIBERROR_OS, NULL);
u->endfile = AT_ENDFILE;
}
/* Unspecified recl ends up with a processor dependent value. */
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
{
u->flags.has_recl = 1;
u->recl = opp->recl_in;
u->recl_subrecord = u->recl;
u->bytes_left = u->recl;
}
else
{
u->flags.has_recl = 0;
u->recl = max_offset;
if (compile_options.max_subrecord_length)
{
u->recl_subrecord = compile_options.max_subrecord_length;
}
else
{
switch (compile_options.record_marker)
{
case 0:
/* Fall through */
case sizeof (GFC_INTEGER_4):
u->recl_subrecord = GFC_MAX_SUBRECORD_LENGTH;
break;
case sizeof (GFC_INTEGER_8):
u->recl_subrecord = max_offset - 16;
break;
default:
runtime_error ("Illegal value for record marker");
break;
}
}
}
/* If the file is direct access, calculate the maximum record number
via a division now instead of letting the multiplication overflow
later. */
if (flags->access == ACCESS_DIRECT)
u->maxrec = max_offset / u->recl;
if (flags->access == ACCESS_STREAM)
{
u->maxrec = max_offset;
u->recl = 1;
u->bytes_left = 1;
u->strm_pos = stell (u->s) + 1;
}
memmove (u->file, opp->file, opp->file_len);
u->file_len = opp->file_len;
/* Curiously, the standard requires that the
position specifier be ignored for new files so a newly connected
file starts out at the initial point. We still need to figure
out if the file is at the end or not. */
test_endfile (u);
if (flags->status == STATUS_SCRATCH && opp->file != NULL)
free (opp->file);
if (flags->form == FORM_FORMATTED)
{
if ((opp->common.flags & IOPARM_OPEN_HAS_RECL_IN))
fbuf_init (u, u->recl);
else
fbuf_init (u, 0);
}
else
u->fbuf = NULL;
return u;
cleanup:
/* Free memory associated with a temporary filename. */
if (flags->status == STATUS_SCRATCH && opp->file != NULL)
free (opp->file);
fail:
close_unit (u);
return NULL;
}
static void
stat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
gfc_charlen_type name_len, int is_lstat __attribute__ ((unused)))
{
int val;
char *str;
struct stat sb;
/* If the rank of the array is not 1, abort. */
if (GFC_DESCRIPTOR_RANK (sarray) != 1)
runtime_error ("Array rank of SARRAY is not 1.");
/* If the array is too small, abort. */
if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
runtime_error ("Array size of SARRAY is too small.");
/* Trim trailing spaces from name. */
while (name_len > 0 && name[name_len - 1] == ' ')
name_len--;
/* Make a null terminated copy of the string. */
str = gfc_alloca (name_len + 1);
memcpy (str, name, name_len);
str[name_len] = '\0';
/* On platforms that don't provide lstat(), we use stat() instead. */
#ifdef HAVE_LSTAT
if (is_lstat)
val = lstat(str, &sb);
else
#endif
val = stat(str, &sb);
if (val == 0)
{
/* Device ID */
sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;
/* Inode number */
sarray->data[1 * sarray->dim[0].stride] = sb.st_ino;
/* File mode */
sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
/* Number of (hard) links */
sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
/* Owner's uid */
sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
/* Owner's gid */
sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
/* ID of device containing directory entry for file (0 if not available) */
#if HAVE_STRUCT_STAT_ST_RDEV
sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
#else
sarray->data[6 * sarray->dim[0].stride] = 0;
#endif
/* File size (bytes) */
sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
/* Last access time */
sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
/* Last modification time */
sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
/* Last file status change time */
sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
/* Preferred I/O block size (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLKSIZE
sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
#else
sarray->data[11 * sarray->dim[0].stride] = -1;
#endif
/* Number of blocks allocated (-1 if not available) */
#if HAVE_STRUCT_STAT_ST_BLOCKS
sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
#else
sarray->data[12 * sarray->dim[0].stride] = -1;
#endif
}
if (status != NULL)
*status = (val == 0) ? 0 : errno;
}
void
get_environment_variable_i4 (char *name, char *value, GFC_INTEGER_4 *length,
GFC_INTEGER_4 *status, GFC_LOGICAL_4 *trim_name,
gfc_charlen_type name_len,
gfc_charlen_type value_len)
{
int stat = GFC_SUCCESS, res_len = 0;
char *name_nt;
char *res;
if (name == NULL)
runtime_error ("Name is required for get_environment_variable.");
if (value == NULL && length == NULL && status == NULL && trim_name == NULL)
return;
if (name_len < 1)
runtime_error ("Zero-length string passed as name to "
"get_environment_variable.");
if (value != NULL)
{
if (value_len < 1)
runtime_error ("Zero-length string passed as value to "
"get_environment_variable.");
else
memset (value, ' ', value_len); /* Blank the string. */
}
if ((!trim_name) || *trim_name)
{
/* Trim trailing spaces from name. */
while (name_len > 0 && name[name_len - 1] == ' ')
name_len--;
}
/* Make a null terminated copy of the name. */
name_nt = gfc_alloca (name_len + 1);
memcpy (name_nt, name, name_len);
name_nt[name_len] = '\0';
res = getenv(name_nt);
if (res == NULL)
stat = GFC_NAME_DOES_NOT_EXIST;
else
{
res_len = strlen(res);
if (value != NULL)
{
if (value_len < res_len)
{
memcpy (value, res, value_len);
stat = GFC_VALUE_TOO_SHORT;
}
else
memcpy (value, res, res_len);
}
}
if (status != NULL)
*status = stat;
if (length != NULL)
*length = res_len;
}
void
read_f (st_parameter_dt *dtp, const fnode *f, char *dest, int length)
{
size_t wu;
int w, seen_dp, exponent;
int exponent_sign, val_sign;
int ndigits;
int edigits;
int i;
char *p, *buffer;
char *digits;
char scratch[SCRATCH_SIZE];
val_sign = 1;
seen_dp = 0;
wu = f->u.w;
p = gfc_alloca (wu);
if (read_block_form (dtp, p, &wu) == FAILURE)
return;
w = wu;
p = eat_leading_spaces (&w, p);
if (w == 0)
goto zero;
/* Optional sign */
if (*p == '-' || *p == '+')
{
if (*p == '-')
val_sign = -1;
p++;
w--;
}
exponent_sign = 1;
p = eat_leading_spaces (&w, p);
if (w == 0)
goto zero;
/* A digit, a '.' or a exponent character ('e', 'E', 'd' or 'D')
is required at this point */
if (!isdigit (*p) && *p != '.' && *p != ',' && *p != 'd' && *p != 'D'
&& *p != 'e' && *p != 'E')
goto bad_float;
/* Remember the position of the first digit. */
digits = p;
ndigits = 0;
/* Scan through the string to find the exponent. */
while (w > 0)
{
switch (*p)
{
case ',':
if (dtp->u.p.current_unit->decimal_status == DECIMAL_COMMA
&& *p == ',')
*p = '.';
else
goto bad_float;
/* Fall through */
case '.':
if (seen_dp)
goto bad_float;
seen_dp = 1;
/* Fall through */
case '0':
case '1':
case '2':
case '3':
case '4':
case '5':
case '6':
case '7':
case '8':
case '9':
case ' ':
ndigits++;
p++;
w--;
break;
case '-':
exponent_sign = -1;
/* Fall through */
case '+':
p++;
w--;
goto exp2;
case 'd':
case 'e':
case 'D':
case 'E':
p++;
w--;
goto exp1;
default:
goto bad_float;
}
}
/* No exponent has been seen, so we use the current scale factor */
exponent = -dtp->u.p.scale_factor;
goto done;
bad_float:
generate_error (&dtp->common, LIBERROR_READ_VALUE,
"Bad value during floating point read");
next_record (dtp, 1);
return;
/* The value read is zero */
zero:
switch (length)
{
case 4:
*((GFC_REAL_4 *) dest) = 0;
break;
case 8:
*((GFC_REAL_8 *) dest) = 0;
break;
#ifdef HAVE_GFC_REAL_10
case 10:
*((GFC_REAL_10 *) dest) = 0;
break;
#endif
#ifdef HAVE_GFC_REAL_16
case 16:
*((GFC_REAL_16 *) dest) = 0;
break;
#endif
default:
internal_error (&dtp->common, "Unsupported real kind during IO");
}
return;
/* At this point the start of an exponent has been found */
exp1:
while (w > 0 && *p == ' ')
{
w--;
p++;
}
switch (*p)
{
case '-':
exponent_sign = -1;
/* Fall through */
case '+':
p++;
w--;
break;
}
if (w == 0)
goto bad_float;
/* At this point a digit string is required. We calculate the value
of the exponent in order to take account of the scale factor and
the d parameter before explict conversion takes place. */
exp2:
/* Normal processing of exponent */
exponent = 0;
if (dtp->u.p.blank_status == BLANK_UNSPECIFIED)
{
while (w > 0 && isdigit (*p))
{
exponent = 10 * exponent + *p - '0';
p++;
w--;
}
/* Only allow trailing blanks */
while (w > 0)
{
if (*p != ' ')
goto bad_float;
p++;
w--;
}
}
else /* BZ or BN status is enabled */
{
while (w > 0)
{
if (*p == ' ')
{
if (dtp->u.p.blank_status == BLANK_ZERO) *p = '0';
if (dtp->u.p.blank_status == BLANK_NULL)
{
p++;
w--;
continue;
}
}
else if (!isdigit (*p))
goto bad_float;
exponent = 10 * exponent + *p - '0';
p++;
w--;
}
}
exponent = exponent * exponent_sign;
done:
/* Use the precision specified in the format if no decimal point has been
seen. */
if (!seen_dp)
exponent -= f->u.real.d;
if (exponent > 0)
{
edigits = 2;
i = exponent;
}
else
{
edigits = 3;
i = -exponent;
}
while (i >= 10)
{
i /= 10;
edigits++;
}
i = ndigits + edigits + 1;
if (val_sign < 0)
i++;
if (i < SCRATCH_SIZE)
buffer = scratch;
else
buffer = get_mem (i);
/* Reformat the string into a temporary buffer. As we're using atof it's
easiest to just leave the decimal point in place. */
p = buffer;
if (val_sign < 0)
*(p++) = '-';
for (; ndigits > 0; ndigits--)
{
if (*digits == ' ')
{
if (dtp->u.p.blank_status == BLANK_ZERO) *digits = '0';
if (dtp->u.p.blank_status == BLANK_NULL)
{
digits++;
continue;
}
}
*p = *digits;
p++;
digits++;
}
*(p++) = 'e';
sprintf (p, "%d", exponent);
/* Do the actual conversion. */
convert_real (dtp, dest, buffer, length);
if (buffer != scratch)
free_mem (buffer);
}
