2005-05-15 10:25:52 +02:00
|
|
|
/* Copyright (C) 2002, 2003, 2005 Free Software Foundation, Inc.
|
2004-05-13 08:41:07 +02:00
|
|
|
Contributed by Andy Vaught
|
|
|
|
|
|
|
|
This file is part of the GNU Fortran 95 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.
|
|
|
|
|
2005-01-12 22:27:33 +01:00
|
|
|
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.)
|
|
|
|
|
2004-05-13 08:41:07 +02:00
|
|
|
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
|
2005-08-17 04:49:08 +02:00
|
|
|
the Free Software Foundation, 51 Franklin Street, Fifth Floor,
|
|
|
|
Boston, MA 02110-1301, USA. */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
#include "config.h"
|
|
|
|
#include <stdlib.h>
|
|
|
|
#include <string.h>
|
|
|
|
#include "libgfortran.h"
|
|
|
|
#include "io.h"
|
|
|
|
|
|
|
|
|
|
|
|
/* Subroutines related to units */
|
|
|
|
|
|
|
|
|
|
|
|
#define CACHE_SIZE 3
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
static gfc_unit internal_unit, *unit_cache[CACHE_SIZE];
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
|
|
|
|
/* This implementation is based on Stefan Nilsson's article in the
|
|
|
|
* July 1997 Doctor Dobb's Journal, "Treaps in Java". */
|
|
|
|
|
|
|
|
/* pseudo_random()-- Simple linear congruential pseudorandom number
|
|
|
|
* generator. The period of this generator is 44071, which is plenty
|
|
|
|
* for our purposes. */
|
|
|
|
|
|
|
|
static int
|
|
|
|
pseudo_random (void)
|
|
|
|
{
|
|
|
|
static int x0 = 5341;
|
|
|
|
|
|
|
|
x0 = (22611 * x0 + 10) % 44071;
|
|
|
|
return x0;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* rotate_left()-- Rotate the treap left */
|
|
|
|
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
static gfc_unit *
|
|
|
|
rotate_left (gfc_unit * t)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
gfc_unit *temp;
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
temp = t->right;
|
|
|
|
t->right = t->right->left;
|
|
|
|
temp->left = t;
|
|
|
|
|
|
|
|
return temp;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* rotate_right()-- Rotate the treap right */
|
|
|
|
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
static gfc_unit *
|
|
|
|
rotate_right (gfc_unit * t)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
gfc_unit *temp;
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
temp = t->left;
|
|
|
|
t->left = t->left->right;
|
|
|
|
temp->right = t;
|
|
|
|
|
|
|
|
return temp;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
static int
|
|
|
|
compare (int a, int b)
|
|
|
|
{
|
|
|
|
if (a < b)
|
|
|
|
return -1;
|
|
|
|
if (a > b)
|
|
|
|
return 1;
|
|
|
|
|
|
|
|
return 0;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* insert()-- Recursive insertion function. Returns the updated treap. */
|
|
|
|
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
static gfc_unit *
|
|
|
|
insert (gfc_unit * new, gfc_unit * t)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
int c;
|
|
|
|
|
|
|
|
if (t == NULL)
|
|
|
|
return new;
|
|
|
|
|
|
|
|
c = compare (new->unit_number, t->unit_number);
|
|
|
|
|
|
|
|
if (c < 0)
|
|
|
|
{
|
|
|
|
t->left = insert (new, t->left);
|
|
|
|
if (t->priority < t->left->priority)
|
|
|
|
t = rotate_right (t);
|
|
|
|
}
|
|
|
|
|
|
|
|
if (c > 0)
|
|
|
|
{
|
|
|
|
t->right = insert (new, t->right);
|
|
|
|
if (t->priority < t->right->priority)
|
|
|
|
t = rotate_left (t);
|
|
|
|
}
|
|
|
|
|
|
|
|
if (c == 0)
|
|
|
|
internal_error ("insert(): Duplicate key found!");
|
|
|
|
|
|
|
|
return t;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* insert_unit()-- Given a new node, insert it into the treap. It is
|
|
|
|
* an error to insert a key that already exists. */
|
|
|
|
|
|
|
|
void
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
insert_unit (gfc_unit * new)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
new->priority = pseudo_random ();
|
|
|
|
g.unit_root = insert (new, g.unit_root);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
static gfc_unit *
|
|
|
|
delete_root (gfc_unit * t)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
gfc_unit *temp;
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
if (t->left == NULL)
|
|
|
|
return t->right;
|
|
|
|
if (t->right == NULL)
|
|
|
|
return t->left;
|
|
|
|
|
|
|
|
if (t->left->priority > t->right->priority)
|
|
|
|
{
|
|
|
|
temp = rotate_right (t);
|
|
|
|
temp->right = delete_root (t);
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
temp = rotate_left (t);
|
|
|
|
temp->left = delete_root (t);
|
|
|
|
}
|
|
|
|
|
|
|
|
return temp;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* delete_treap()-- Delete an element from a tree. The 'old' value
|
|
|
|
* does not necessarily have to point to the element to be deleted, it
|
|
|
|
* must just point to a treap structure with the key to be deleted.
|
|
|
|
* Returns the new root node of the tree. */
|
|
|
|
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
static gfc_unit *
|
|
|
|
delete_treap (gfc_unit * old, gfc_unit * t)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
int c;
|
|
|
|
|
|
|
|
if (t == NULL)
|
|
|
|
return NULL;
|
|
|
|
|
|
|
|
c = compare (old->unit_number, t->unit_number);
|
|
|
|
|
|
|
|
if (c < 0)
|
|
|
|
t->left = delete_treap (old, t->left);
|
|
|
|
if (c > 0)
|
|
|
|
t->right = delete_treap (old, t->right);
|
|
|
|
if (c == 0)
|
|
|
|
t = delete_root (t);
|
|
|
|
|
|
|
|
return t;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* delete_unit()-- Delete a unit from a tree */
|
|
|
|
|
|
|
|
static void
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
delete_unit (gfc_unit * old)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
g.unit_root = delete_treap (old, g.unit_root);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* find_unit()-- Given an integer, return a pointer to the unit
|
|
|
|
* structure. Returns NULL if the unit does not exist. */
|
|
|
|
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
gfc_unit *
|
2004-05-13 08:41:07 +02:00
|
|
|
find_unit (int n)
|
|
|
|
{
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
gfc_unit *p;
|
2004-05-13 08:41:07 +02:00
|
|
|
int c;
|
|
|
|
|
|
|
|
for (c = 0; c < CACHE_SIZE; c++)
|
|
|
|
if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
|
|
|
|
{
|
|
|
|
p = unit_cache[c];
|
|
|
|
return p;
|
|
|
|
}
|
|
|
|
|
|
|
|
p = g.unit_root;
|
|
|
|
while (p != NULL)
|
|
|
|
{
|
|
|
|
c = compare (n, p->unit_number);
|
|
|
|
if (c < 0)
|
|
|
|
p = p->left;
|
|
|
|
if (c > 0)
|
|
|
|
p = p->right;
|
|
|
|
if (c == 0)
|
|
|
|
break;
|
|
|
|
}
|
|
|
|
|
|
|
|
if (p != NULL)
|
|
|
|
{
|
|
|
|
for (c = 0; c < CACHE_SIZE - 1; c++)
|
|
|
|
unit_cache[c] = unit_cache[c + 1];
|
|
|
|
|
|
|
|
unit_cache[CACHE_SIZE - 1] = p;
|
|
|
|
}
|
|
|
|
|
|
|
|
return p;
|
|
|
|
}
|
|
|
|
|
2005-09-14 22:18:19 +02:00
|
|
|
|
|
|
|
/* get_array_unit_len()-- return the number of records in the array. */
|
|
|
|
|
|
|
|
gfc_offset
|
|
|
|
get_array_unit_len (gfc_array_char *desc)
|
|
|
|
{
|
|
|
|
gfc_offset record_count;
|
|
|
|
int i, rank, stride;
|
|
|
|
rank = GFC_DESCRIPTOR_RANK(desc);
|
|
|
|
record_count = stride = 1;
|
|
|
|
for (i=0;i<rank;++i)
|
|
|
|
{
|
|
|
|
/* Check that array is contiguous */
|
|
|
|
|
|
|
|
if (desc->dim[i].stride != stride)
|
|
|
|
{
|
|
|
|
generate_error (ERROR_ARRAY_STRIDE, NULL);
|
libgfortran.h (GFC_ITOA_BUF_SIZE, [...]): Define.
* libgfortran.h (GFC_ITOA_BUF_SIZE, GFC_XTOA_BUF_SIZE,
GFC_OTOA_BUF_SIZE, GFC_BTOA_BUF_SIZE): Define.
(gfc_itoa, xtoa): Add 2 extra arguments.
* runtime/environ.c: Include stdio.h.
(check_buffered): Use sprintf.
* runtime/error.c: Include assert.h.
(gfc_itoa, xtoa): Add 2 extra arguments, avoid using static
buffers.
(st_printf, st_sprintf): Adjust callers.
* io/write.c (otoa, btoa): Add 2 extra arguments, avoid using
static buffers.
(write_int, write_decimal): Add 2 extra arguments to conv
function pointer, adjust caller.
(write_integer): Adjust gfc_itoa caller.
* io/unit.c (get_array_unit_len): Return 0 rather than NULL.
* io/read.c (read_f): Remove spurious pointer dereference.
From-SVN: r104855
2005-10-01 13:50:10 +02:00
|
|
|
return 0;
|
2005-09-14 22:18:19 +02:00
|
|
|
}
|
|
|
|
stride *= desc->dim[i].ubound;
|
|
|
|
record_count *= desc->dim[i].ubound;
|
|
|
|
}
|
|
|
|
return record_count;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2004-05-13 08:41:07 +02:00
|
|
|
/* get_unit()-- Returns the unit structure associated with the integer
|
|
|
|
* unit or the internal file. */
|
|
|
|
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
gfc_unit *
|
2005-05-17 19:02:38 +02:00
|
|
|
get_unit (int read_flag __attribute__ ((unused)))
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
if (ioparm.internal_unit != NULL)
|
|
|
|
{
|
2005-09-14 22:18:19 +02:00
|
|
|
internal_unit.recl = ioparm.internal_unit_len;
|
|
|
|
if (is_array_io()) ioparm.internal_unit_len *=
|
|
|
|
get_array_unit_len(ioparm.internal_unit_desc);
|
2004-05-13 08:41:07 +02:00
|
|
|
internal_unit.s =
|
|
|
|
open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
|
2005-09-14 22:18:19 +02:00
|
|
|
internal_unit.bytes_left = internal_unit.recl;
|
|
|
|
internal_unit.last_record=0;
|
|
|
|
internal_unit.maxrec=0;
|
|
|
|
internal_unit.current_record=0;
|
|
|
|
|
|
|
|
if (g.mode==WRITING && !is_array_io())
|
|
|
|
empty_internal_buffer (internal_unit.s);
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
/* Set flags for the internal unit */
|
|
|
|
|
|
|
|
internal_unit.flags.access = ACCESS_SEQUENTIAL;
|
|
|
|
internal_unit.flags.action = ACTION_READWRITE;
|
|
|
|
internal_unit.flags.form = FORM_FORMATTED;
|
|
|
|
internal_unit.flags.delim = DELIM_NONE;
|
|
|
|
|
|
|
|
return &internal_unit;
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Has to be an external unit */
|
|
|
|
|
2004-08-31 21:49:33 +02:00
|
|
|
return find_unit (ioparm.unit);
|
2004-05-13 08:41:07 +02:00
|
|
|
}
|
|
|
|
|
|
|
|
|
2005-09-14 22:18:19 +02:00
|
|
|
/* is_internal_unit()-- Determine if the current unit is internal or not */
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
int
|
2005-05-15 15:25:19 +02:00
|
|
|
is_internal_unit (void)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
return current_unit == &internal_unit;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
2005-09-14 22:18:19 +02:00
|
|
|
/* is_array_io ()-- Determine if the I/O is to/from an array */
|
|
|
|
|
|
|
|
int
|
|
|
|
is_array_io (void)
|
|
|
|
{
|
|
|
|
return (ioparm.internal_unit_desc != NULL);
|
|
|
|
}
|
|
|
|
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
/*************************/
|
|
|
|
/* Initialize everything */
|
|
|
|
|
|
|
|
void
|
|
|
|
init_units (void)
|
|
|
|
{
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
gfc_unit *u;
|
2005-05-17 19:02:38 +02:00
|
|
|
unsigned int i;
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
if (options.stdin_unit >= 0)
|
|
|
|
{ /* STDIN */
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
u = get_mem (sizeof (gfc_unit));
|
2005-05-12 19:50:33 +02:00
|
|
|
memset (u, '\0', sizeof (gfc_unit));
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
u->unit_number = options.stdin_unit;
|
|
|
|
u->s = input_stream ();
|
|
|
|
|
|
|
|
u->flags.action = ACTION_READ;
|
|
|
|
|
|
|
|
u->flags.access = ACCESS_SEQUENTIAL;
|
|
|
|
u->flags.form = FORM_FORMATTED;
|
|
|
|
u->flags.status = STATUS_OLD;
|
2005-07-22 19:43:31 +02:00
|
|
|
u->flags.blank = BLANK_UNSPECIFIED;
|
2004-05-13 08:41:07 +02:00
|
|
|
u->flags.position = POSITION_ASIS;
|
|
|
|
|
|
|
|
u->recl = options.default_recl;
|
|
|
|
u->endfile = NO_ENDFILE;
|
|
|
|
|
|
|
|
insert_unit (u);
|
|
|
|
}
|
|
|
|
|
|
|
|
if (options.stdout_unit >= 0)
|
|
|
|
{ /* STDOUT */
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
u = get_mem (sizeof (gfc_unit));
|
2005-05-12 19:50:33 +02:00
|
|
|
memset (u, '\0', sizeof (gfc_unit));
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
u->unit_number = options.stdout_unit;
|
|
|
|
u->s = output_stream ();
|
|
|
|
|
|
|
|
u->flags.action = ACTION_WRITE;
|
|
|
|
|
|
|
|
u->flags.access = ACCESS_SEQUENTIAL;
|
|
|
|
u->flags.form = FORM_FORMATTED;
|
|
|
|
u->flags.status = STATUS_OLD;
|
2005-07-22 19:43:31 +02:00
|
|
|
u->flags.blank = BLANK_UNSPECIFIED;
|
2004-05-13 08:41:07 +02:00
|
|
|
u->flags.position = POSITION_ASIS;
|
|
|
|
|
|
|
|
u->recl = options.default_recl;
|
2005-01-23 01:14:31 +01:00
|
|
|
u->endfile = AT_ENDFILE;
|
|
|
|
|
|
|
|
insert_unit (u);
|
|
|
|
}
|
|
|
|
|
|
|
|
if (options.stderr_unit >= 0)
|
|
|
|
{ /* STDERR */
|
|
|
|
u = get_mem (sizeof (gfc_unit));
|
2005-05-12 19:50:33 +02:00
|
|
|
memset (u, '\0', sizeof (gfc_unit));
|
2005-01-23 01:14:31 +01:00
|
|
|
|
|
|
|
u->unit_number = options.stderr_unit;
|
|
|
|
u->s = error_stream ();
|
|
|
|
|
|
|
|
u->flags.action = ACTION_WRITE;
|
|
|
|
|
|
|
|
u->flags.access = ACCESS_SEQUENTIAL;
|
|
|
|
u->flags.form = FORM_FORMATTED;
|
|
|
|
u->flags.status = STATUS_OLD;
|
2005-07-22 19:43:31 +02:00
|
|
|
u->flags.blank = BLANK_UNSPECIFIED;
|
2005-01-23 01:14:31 +01:00
|
|
|
u->flags.position = POSITION_ASIS;
|
|
|
|
|
|
|
|
u->recl = options.default_recl;
|
2004-05-13 08:41:07 +02:00
|
|
|
u->endfile = AT_ENDFILE;
|
|
|
|
|
|
|
|
insert_unit (u);
|
|
|
|
}
|
|
|
|
|
|
|
|
/* Calculate the maximum file offset in a portable manner.
|
re PR libfortran/15235 (libgfortran doesn't build on Solaris 10)
PR fortran/15235
* gfortran.h (offset_t): Rename to ...
(gfc_offset): ... this.
* io/backspace.c (formatted_backspace, unformatted_backspace),
io/io.h (stream, gfc_unit, global_t, file_length, file_position),
transfer.c (us_read, us_write, next_record_r, next_record_w),
io/unit.c (init_units), unix.c (unix_stream, fd_alloc,
fd_alloc_r_at, fd_alloc_w_at, fd_seek, mmap_alloc,
mmap_alloc_r_at, mmap_alloc_w_at, mmap_seek, mem_alloc_r_at,
mem_alloc_w_at, mem_seek, file_length, file_position): Replace all
occurences of offset_t by gfc_offset.
From-SVN: r81994
2004-05-18 18:06:09 +02:00
|
|
|
* max will be the largest signed number for the type gfc_offset.
|
2004-05-13 08:41:07 +02:00
|
|
|
*
|
|
|
|
* set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
|
|
|
|
|
|
|
|
g.max_offset = 0;
|
2005-05-17 19:02:38 +02:00
|
|
|
for (i = 0; i < sizeof (g.max_offset) * 8 - 1; i++)
|
re PR libfortran/15235 (libgfortran doesn't build on Solaris 10)
PR fortran/15235
* gfortran.h (offset_t): Rename to ...
(gfc_offset): ... this.
* io/backspace.c (formatted_backspace, unformatted_backspace),
io/io.h (stream, gfc_unit, global_t, file_length, file_position),
transfer.c (us_read, us_write, next_record_r, next_record_w),
io/unit.c (init_units), unix.c (unix_stream, fd_alloc,
fd_alloc_r_at, fd_alloc_w_at, fd_seek, mmap_alloc,
mmap_alloc_r_at, mmap_alloc_w_at, mmap_seek, mem_alloc_r_at,
mem_alloc_w_at, mem_seek, file_length, file_position): Replace all
occurences of offset_t by gfc_offset.
From-SVN: r81994
2004-05-18 18:06:09 +02:00
|
|
|
g.max_offset = g.max_offset + ((gfc_offset) 1 << i);
|
2004-05-13 08:41:07 +02:00
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* close_unit()-- Close a unit. The stream is closed, and any memory
|
|
|
|
* associated with the stream is freed. Returns nonzero on I/O error. */
|
|
|
|
|
|
|
|
int
|
re PR libfortran/15234 (libgfortran doesn't compile on Tru64 UNIX V4.0F)
PR fortran/15234
* io/io.h (unit_t): Rename to ...
(gfc_unit) ... this.
(unit_root, current_unit, find_file, find_unit, get_unit): Now
of type gfc_unit.
(delete_file, insert_unit, close_unit): Argument now of type
gfc_unit.
* backspace.c (st_backspace), close.c (st_close), endfile.c
(st_endfile), inquire.c (inquire_via_unit, st_inquire), open.c
(test_endfile, edit_modes, new_unit, already_open, st_open),
rewind.c (st_rewind), transfer.c (current_unit), unit.c
(internal_unit, unit_cache, rotate_left, rotate_right, insert,
insert_unit, delete_root, delete_treap, delete_unit, find_unit,
get_unit, init_units, close_unit), unix.c (find_file0,
find_file, delete_file): Replace all occurences of unit_t by
gfc_unit.
From-SVN: r81903
2004-05-15 22:44:38 +02:00
|
|
|
close_unit (gfc_unit * u)
|
2004-05-13 08:41:07 +02:00
|
|
|
{
|
|
|
|
int i, rc;
|
|
|
|
|
|
|
|
for (i = 0; i < CACHE_SIZE; i++)
|
|
|
|
if (unit_cache[i] == u)
|
|
|
|
unit_cache[i] = NULL;
|
|
|
|
|
|
|
|
rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
|
|
|
|
|
|
|
|
delete_unit (u);
|
|
|
|
free_mem (u);
|
|
|
|
|
|
|
|
return rc;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
/* close_units()-- Delete units on completion. We just keep deleting
|
|
|
|
* the root of the treap until there is nothing left. */
|
|
|
|
|
|
|
|
void
|
|
|
|
close_units (void)
|
|
|
|
{
|
|
|
|
while (g.unit_root != NULL)
|
|
|
|
close_unit (g.unit_root);
|
|
|
|
}
|