1 /* Copyright (C) 2002-2003 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
4 This file is part of the GNU Fortran 95 runtime library (libgfortran).
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 2, or (at your option)
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.
16 You should have received a copy of the GNU General Public License
17 along with Libgfortran; see the file COPYING. If not, write to
18 the Free Software Foundation, 59 Temple Place - Suite 330,
19 Boston, MA 02111-1307, USA. */
24 #include "libgfortran.h"
28 /* Subroutines related to units */
32 static gfc_unit internal_unit, *unit_cache[CACHE_SIZE];
35 /* This implementation is based on Stefan Nilsson's article in the
36 * July 1997 Doctor Dobb's Journal, "Treaps in Java". */
38 /* pseudo_random()-- Simple linear congruential pseudorandom number
39 * generator. The period of this generator is 44071, which is plenty
40 * for our purposes. */
47 x0 = (22611 * x0 + 10) % 44071;
52 /* rotate_left()-- Rotate the treap left */
55 rotate_left (gfc_unit * t)
60 t->right = t->right->left;
67 /* rotate_right()-- Rotate the treap right */
70 rotate_right (gfc_unit * t)
75 t->left = t->left->right;
84 compare (int a, int b)
96 /* insert()-- Recursive insertion function. Returns the updated treap. */
99 insert (gfc_unit * new, gfc_unit * t)
106 c = compare (new->unit_number, t->unit_number);
110 t->left = insert (new, t->left);
111 if (t->priority < t->left->priority)
112 t = rotate_right (t);
117 t->right = insert (new, t->right);
118 if (t->priority < t->right->priority)
123 internal_error ("insert(): Duplicate key found!");
129 /* insert_unit()-- Given a new node, insert it into the treap. It is
130 * an error to insert a key that already exists. */
133 insert_unit (gfc_unit * new)
136 new->priority = pseudo_random ();
137 g.unit_root = insert (new, g.unit_root);
142 delete_root (gfc_unit * t)
148 if (t->right == NULL)
151 if (t->left->priority > t->right->priority)
153 temp = rotate_right (t);
154 temp->right = delete_root (t);
158 temp = rotate_left (t);
159 temp->left = delete_root (t);
166 /* delete_treap()-- Delete an element from a tree. The 'old' value
167 * does not necessarily have to point to the element to be deleted, it
168 * must just point to a treap structure with the key to be deleted.
169 * Returns the new root node of the tree. */
172 delete_treap (gfc_unit * old, gfc_unit * t)
179 c = compare (old->unit_number, t->unit_number);
182 t->left = delete_treap (old, t->left);
184 t->right = delete_treap (old, t->right);
192 /* delete_unit()-- Delete a unit from a tree */
195 delete_unit (gfc_unit * old)
198 g.unit_root = delete_treap (old, g.unit_root);
202 /* find_unit()-- Given an integer, return a pointer to the unit
203 * structure. Returns NULL if the unit does not exist. */
211 for (c = 0; c < CACHE_SIZE; c++)
212 if (unit_cache[c] != NULL && unit_cache[c]->unit_number == n)
221 c = compare (n, p->unit_number);
232 for (c = 0; c < CACHE_SIZE - 1; c++)
233 unit_cache[c] = unit_cache[c + 1];
235 unit_cache[CACHE_SIZE - 1] = p;
241 /* get_unit()-- Returns the unit structure associated with the integer
242 * unit or the internal file. */
245 get_unit (int read_flag)
249 if (ioparm.internal_unit != NULL)
252 open_internal (ioparm.internal_unit, ioparm.internal_unit_len);
254 /* Set flags for the internal unit */
256 internal_unit.flags.access = ACCESS_SEQUENTIAL;
257 internal_unit.flags.action = ACTION_READWRITE;
258 internal_unit.flags.form = FORM_FORMATTED;
259 internal_unit.flags.delim = DELIM_NONE;
261 return &internal_unit;
264 /* Has to be an external unit */
266 u = find_unit (ioparm.unit);
272 /* is_internal_unit()-- Determine if the current unit is internal or
279 return current_unit == &internal_unit;
284 /*************************/
285 /* Initialize everything */
294 if (options.stdin_unit >= 0)
296 u = get_mem (sizeof (gfc_unit));
298 u->unit_number = options.stdin_unit;
299 u->s = input_stream ();
301 u->flags.action = ACTION_READ;
303 u->flags.access = ACCESS_SEQUENTIAL;
304 u->flags.form = FORM_FORMATTED;
305 u->flags.status = STATUS_OLD;
306 u->flags.blank = BLANK_ZERO;
307 u->flags.position = POSITION_ASIS;
309 u->recl = options.default_recl;
310 u->endfile = NO_ENDFILE;
315 if (options.stdout_unit >= 0)
317 u = get_mem (sizeof (gfc_unit));
319 u->unit_number = options.stdout_unit;
320 u->s = output_stream ();
322 u->flags.action = ACTION_WRITE;
324 u->flags.access = ACCESS_SEQUENTIAL;
325 u->flags.form = FORM_FORMATTED;
326 u->flags.status = STATUS_OLD;
327 u->flags.blank = BLANK_ZERO;
328 u->flags.position = POSITION_ASIS;
330 u->recl = options.default_recl;
331 u->endfile = AT_ENDFILE;
336 /* Calculate the maximum file offset in a portable manner.
337 * max will be the largest signed number for the type gfc_offset.
339 * set a 1 in the LSB and keep a running sum, stopping at MSB-1 bit. */
342 for (i=0; i < sizeof(g.max_offset) * 8 - 1; i++)
343 g.max_offset = g.max_offset + ((gfc_offset) 1 << i);
348 /* close_unit()-- Close a unit. The stream is closed, and any memory
349 * associated with the stream is freed. Returns nonzero on I/O error. */
352 close_unit (gfc_unit * u)
356 for (i = 0; i < CACHE_SIZE; i++)
357 if (unit_cache[i] == u)
358 unit_cache[i] = NULL;
360 rc = (u->s == NULL) ? 0 : sclose (u->s) == FAILURE;
369 /* close_units()-- Delete units on completion. We just keep deleting
370 * the root of the treap until there is nothing left. */
376 while (g.unit_root != NULL)
377 close_unit (g.unit_root);